From 0cd989d04013b4547c9b8d19768e359c85c6fdc9 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Fri, 24 Jul 2026 12:53:38 -0700 Subject: [PATCH 01/24] feat(Classes): define the polynomial hierarchy MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Define certificate quantifiers over the pair codec (polyExistsLang / polyForallLang and their class operators), the levels SigmaP / PiP by the standard recursion through complement classes, and PH as their union. Prove quantifier and class-level complement duality, monotonicity, the recursion laws, and level inclusions, the latter conditional on the single machine-engineering seam `pairFst ∈ FP` (first-component pair decoding), isolated as a hypothesis following the WitnessNTMConstruction pattern. Ported from leanprover/cslib#192, re-proved against this library's machine model and Set-based languages. Co-Authored-By: Claude Fable 5 --- Complexitylib/Classes.lean | 1 + Complexitylib/Classes/PH.lean | 299 ++++++++++++++++++++++++++++++++++ 2 files changed, 300 insertions(+) create mode 100644 Complexitylib/Classes/PH.lean diff --git a/Complexitylib/Classes.lean b/Complexitylib/Classes.lean index dc8ceb19..560697cd 100644 --- a/Complexitylib/Classes.lean +++ b/Complexitylib/Classes.lean @@ -58,6 +58,7 @@ import Complexitylib.Classes.Randomized.PPoly import Complexitylib.Classes.Pairing import Complexitylib.Classes.FNP import Complexitylib.Classes.NP.Witness +import Complexitylib.Classes.PH import Complexitylib.Classes.NP.Reduction import Complexitylib.Classes.L import Complexitylib.Classes.L.PolynomialTime diff --git a/Complexitylib/Classes/PH.lean b/Complexitylib/Classes/PH.lean new file mode 100644 index 00000000..12ec6727 --- /dev/null +++ b/Complexitylib/Classes/PH.lean @@ -0,0 +1,299 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +import Complexitylib.Classes.Containments +import Complexitylib.Encoding.Pairing +import Mathlib.Algebra.Polynomial.Eval.Defs + +/-! +# The polynomial hierarchy + +This file defines the polynomial hierarchy via certificate quantifiers, following +the quantified-formula definition (Arora–Barak Definition 5.4, stated over the +library's `pair` codec): `polyExistsLang p L` holds of `x` when some witness `w` +of length at most `p.eval |x|` puts the encoded pair `pair x w` in `L`, and +`polyForallLang p L` requires this of every such witness. Lifting these to class +operators gives the levels `SigmaP 0 = P`, `SigmaP (n + 1) = +polyExistsClass (PiP n)`, `PiP n = complClass (SigmaP n)`, and their union `PH`. + +The level inclusions `SigmaP n ⊆ SigmaP (n + 1)` and `PiP n ⊆ PiP (n + 1)` are +proved relative to a single machine-engineering seam, stated as the hypothesis +`pairFst ∈ FP`: decoding the first component of a canonical pair is +polynomial-time computable. This follows the interface-isolation pattern of +`Complexitylib.Classes.NP.Witness` — every set-theoretic consequence is proved +unconditionally here, and the one remaining TM construction can land later +without touching this file's statements. All other results are unconditional. + +## Main definitions + +- `polyExistsLang`, `polyForallLang` — witness quantifiers on languages +- `polyExistsClass`, `polyForallClass` — the induced operators on classes +- `pairFst` — first-component decoder for the pairing codec +- `SigmaP`, `PiP`, `PH` — the hierarchy levels and their union + +## Main results + +- `compl_polyExistsLang` / `compl_polyForallLang` — quantifier duality +- `complClass_polyExistsClass` / `complClass_polyForallClass` — class duality +- `complClass_P` — `P` is closed under language complement, as a class equation +- `SigmaP_zero`, `PiP_zero`, `SigmaP_succ`, `PiP_succ` — recursion laws +- `P_subset_polyExistsClass_P` / `P_subset_polyForallClass_P` — base inclusions + (given `pairFst ∈ FP`) +- `SigmaP_subset_SigmaP_succ` / `PiP_subset_PiP_succ` — level inclusions + (given `pairFst ∈ FP`) +- `SigmaP_subset_PH`, `P_subset_PH` + +## TODO + +- Implement the `pairFst ∈ FP` seam: split the input with a + `pairSplitCoreTM`-style scanner and copy the decoded first component to the + output tape, packaging the result as `TM.ComputesInTime`. +- Relate `SigmaP 1` to the NTM-based `NP` through the witness characterization + interface in `Complexitylib.Classes.NP.Witness`. +-/ + +namespace Complexity + +/-! ## Witness quantifiers on languages -/ + +/-- The language of inputs `x` admitting a witness `w` of length at most +`p.eval |x|` such that the encoded pair `pair x w` lies in `L`. -/ +def polyExistsLang (p : Polynomial ℕ) (L : Language) : Language := + {x | ∃ w, w.length ≤ p.eval x.length ∧ pair x w ∈ L} + +/-- The language of inputs `x` such that every witness `w` of length at most +`p.eval |x|` puts the encoded pair `pair x w` in `L`. -/ +def polyForallLang (p : Polynomial ℕ) (L : Language) : Language := + {x | ∀ w, w.length ≤ p.eval x.length → pair x w ∈ L} + +/-- Membership in `polyExistsLang` unfolds to a bounded existential. -/ +@[simp] theorem mem_polyExistsLang {p : Polynomial ℕ} {L : Language} {x : List Bool} : + x ∈ polyExistsLang p L ↔ ∃ w, w.length ≤ p.eval x.length ∧ pair x w ∈ L := + Iff.rfl + +/-- Membership in `polyForallLang` unfolds to a bounded universal. -/ +@[simp] theorem mem_polyForallLang {p : Polynomial ℕ} {L : Language} {x : List Bool} : + x ∈ polyForallLang p L ↔ ∀ w, w.length ≤ p.eval x.length → pair x w ∈ L := + Iff.rfl + +/-- Complementing a bounded existential yields a bounded universal over the +complement: some-witness failure is all-witness exclusion. -/ +theorem compl_polyExistsLang (p : Polynomial ℕ) (L : Language) : + (polyExistsLang p L)ᶜ = polyForallLang p Lᶜ := by + ext x + simp [polyExistsLang, polyForallLang] + +/-- Complementing a bounded universal yields a bounded existential over the +complement. -/ +theorem compl_polyForallLang (p : Polynomial ℕ) (L : Language) : + (polyForallLang p L)ᶜ = polyExistsLang p Lᶜ := by + ext x + simp [polyExistsLang, polyForallLang] + +/-! ## Quantifier operators on classes -/ + +/-- The class of languages expressible as a polynomially-bounded existential +over some language of `C`. -/ +def polyExistsClass (C : Set Language) : Set Language := + {L | ∃ (p : Polynomial ℕ), ∃ L' ∈ C, L = polyExistsLang p L'} + +/-- The class of languages expressible as a polynomially-bounded universal +over some language of `C`. -/ +def polyForallClass (C : Set Language) : Set Language := + {L | ∃ (p : Polynomial ℕ), ∃ L' ∈ C, L = polyForallLang p L'} + +/-- `polyExistsClass` is monotone in the base class. -/ +theorem polyExistsClass_mono {C D : Set Language} (h : C ⊆ D) : + polyExistsClass C ⊆ polyExistsClass D := by + rintro L ⟨p, L', hL', rfl⟩ + exact ⟨p, L', h hL', rfl⟩ + +/-- `polyForallClass` is monotone in the base class. -/ +theorem polyForallClass_mono {C D : Set Language} (h : C ⊆ D) : + polyForallClass C ⊆ polyForallClass D := by + rintro L ⟨p, L', hL', rfl⟩ + exact ⟨p, L', h hL', rfl⟩ + +/-- `complClass` is monotone. -/ +theorem complClass_mono {C D : Set Language} (h : C ⊆ D) : + complClass C ⊆ complClass D := + fun _ hL => h hL + +/-- Class-level quantifier duality: the complement class of a bounded +existential class is the bounded universal class over the complement class. -/ +theorem complClass_polyExistsClass (C : Set Language) : + complClass (polyExistsClass C) = polyForallClass (complClass C) := by + ext L + simp only [mem_complClass, polyExistsClass, polyForallClass, Set.mem_setOf_eq] + constructor + · rintro ⟨p, L', hL', hEq⟩ + refine ⟨p, L'ᶜ, by simpa [mem_complClass, compl_compl] using hL', ?_⟩ + rw [← compl_compl L, hEq, compl_polyExistsLang] + · rintro ⟨p, L', hL', rfl⟩ + exact ⟨p, L'ᶜ, hL', by rw [compl_polyForallLang]⟩ + +/-- Class-level quantifier duality: the complement class of a bounded universal +class is the bounded existential class over the complement class. -/ +theorem complClass_polyForallClass (C : Set Language) : + complClass (polyForallClass C) = polyExistsClass (complClass C) := by + ext L + simp only [mem_complClass, polyExistsClass, polyForallClass, Set.mem_setOf_eq] + constructor + · rintro ⟨p, L', hL', hEq⟩ + refine ⟨p, L'ᶜ, by simpa [mem_complClass, compl_compl] using hL', ?_⟩ + rw [← compl_compl L, hEq, compl_polyForallLang] + · rintro ⟨p, L', hL', rfl⟩ + exact ⟨p, L'ᶜ, hL', by rw [compl_polyExistsLang]⟩ + +/-! ## The pair decoder seam -/ + +/-- Decode the first component of a canonical pair, returning `[]` on malformed +inputs. Statements below take the hypothesis `pairFst ∈ FP` — the one remaining +machine construction of this development (see the module docstring). -/ +def pairFst (z : List Bool) : List Bool := + ((unpair? z).map Prod.fst).getD [] + +/-- `pairFst` recovers the first component of a canonical pair. -/ +@[simp] theorem pairFst_pair (x y : List Bool) : pairFst (pair x y) = x := by + simp [pairFst] + +/-! ## Base inclusions -/ + +/-- `P` is closed under complement, stated as a class equation. -/ +theorem complClass_P : complClass P = P := by + ext L + exact ⟨fun h => compl_compl L ▸ P_compl h, fun h => P_compl h⟩ + +/-- Every language of `P` is a bounded existential over `P`: take the zero +witness bound, so the only witness is `[]`, and decide `pair x []` by decoding +the first component and running the original decider. -/ +theorem P_subset_polyExistsClass_P (hpair : pairFst ∈ FP) : + P ⊆ polyExistsClass P := by + intro L hL + refine ⟨0, pairFst ⁻¹' L, mem_P_preimage hpair hL, ?_⟩ + ext x + simp only [mem_polyExistsLang, Polynomial.eval_zero, Nat.le_zero, + List.length_eq_zero_iff, Set.mem_preimage] + constructor + · intro hx + exact ⟨[], rfl, by simpa using hx⟩ + · rintro ⟨w, rfl, hmem⟩ + simpa using hmem + +/-- Every language of `P` is a bounded universal over `P`: with the zero +witness bound the only witness is `[]`, decided as in +`P_subset_polyExistsClass_P`. -/ +theorem P_subset_polyForallClass_P (hpair : pairFst ∈ FP) : + P ⊆ polyForallClass P := by + intro L hL + refine ⟨0, pairFst ⁻¹' L, mem_P_preimage hpair hL, ?_⟩ + ext x + simp only [mem_polyForallLang, Polynomial.eval_zero, Nat.le_zero, + List.length_eq_zero_iff, Set.mem_preimage] + constructor + · rintro hx w rfl + simpa using hx + · intro h + simpa using h [] rfl + +/-! ## The hierarchy -/ + +/-- The Σ levels of the polynomial hierarchy: `SigmaP 0 = P` and +`SigmaP (n + 1)` is a bounded existential over the complement class of +`SigmaP n` (that is, over `PiP n`). -/ +def SigmaP : ℕ → Set Language + | 0 => P + | n + 1 => polyExistsClass (complClass (SigmaP n)) + +/-- The Π levels of the polynomial hierarchy: `PiP n` is the complement class +of `SigmaP n`. -/ +def PiP (n : ℕ) : Set Language := + complClass (SigmaP n) + +/-- The polynomial hierarchy: the union of all Σ levels. -/ +def PH : Set Language := + ⋃ n : ℕ, SigmaP n + +/-- The zeroth Σ level is `P`. -/ +@[simp] theorem SigmaP_zero : SigmaP 0 = P := rfl + +/-- The complement class of a Σ level is the corresponding Π level. -/ +@[simp] theorem complClass_SigmaP (n : ℕ) : complClass (SigmaP n) = PiP n := rfl + +/-- The complement class of a Π level is the corresponding Σ level. -/ +@[simp] theorem complClass_PiP (n : ℕ) : complClass (PiP n) = SigmaP n := by + rw [PiP, complClass_complClass] + +/-- The zeroth Π level is `P`, since `P` is closed under complement. -/ +@[simp] theorem PiP_zero : PiP 0 = P := by + rw [PiP, SigmaP_zero, complClass_P] + +/-- Recursion law for Σ levels: `SigmaP (n + 1)` is a bounded existential over +`PiP n`. -/ +theorem SigmaP_succ (n : ℕ) : SigmaP (n + 1) = polyExistsClass (PiP n) := rfl + +/-- Recursion law for Π levels: `PiP (n + 1)` is a bounded universal over +`SigmaP n`. -/ +theorem PiP_succ (n : ℕ) : PiP (n + 1) = polyForallClass (SigmaP n) := by + rw [PiP] + show complClass (polyExistsClass (complClass (SigmaP n))) = _ + rw [complClass_polyExistsClass, complClass_complClass] + +/-- The first Σ level is the bounded existential closure of `P` — the +certificate form of `NP`. -/ +theorem SigmaP_one : SigmaP 1 = polyExistsClass P := by + rw [SigmaP_succ, PiP_zero] + +/-- The first Π level is the bounded universal closure of `P` — the +certificate form of `coNP`. -/ +theorem PiP_one : PiP 1 = polyForallClass P := by + rw [PiP_succ, SigmaP_zero] + +/-! ## Level inclusions -/ + +/-- Both level inclusions, proved simultaneously by induction: the base case is +the pair of base inclusions of `P`, and each successor case is monotonicity of +the opposite quantifier applied to the other component. -/ +private theorem piP_sigmaP_subset_succ (hpair : pairFst ∈ FP) (n : ℕ) : + PiP n ⊆ PiP (n + 1) ∧ SigmaP n ⊆ SigmaP (n + 1) := by + induction n with + | zero => + constructor + · rw [PiP_zero, PiP_one] + exact P_subset_polyForallClass_P hpair + · rw [SigmaP_zero, SigmaP_one] + exact P_subset_polyExistsClass_P hpair + | succ n ih => + constructor + · rw [PiP_succ, PiP_succ] + exact polyForallClass_mono ih.2 + · rw [SigmaP_succ, SigmaP_succ] + exact polyExistsClass_mono ih.1 + +/-- Each Σ level is contained in the next. -/ +theorem SigmaP_subset_SigmaP_succ (hpair : pairFst ∈ FP) (n : ℕ) : + SigmaP n ⊆ SigmaP (n + 1) := + (piP_sigmaP_subset_succ hpair n).2 + +/-- Each Π level is contained in the next. -/ +theorem PiP_subset_PiP_succ (hpair : pairFst ∈ FP) (n : ℕ) : + PiP n ⊆ PiP (n + 1) := + (piP_sigmaP_subset_succ hpair n).1 + +/-! ## PH -/ + +/-- Membership in `PH` is membership in some Σ level. -/ +theorem mem_PH_iff {L : Language} : L ∈ PH ↔ ∃ n : ℕ, L ∈ SigmaP n := + Set.mem_iUnion + +/-- Every Σ level is contained in the hierarchy. -/ +theorem SigmaP_subset_PH (n : ℕ) : SigmaP n ⊆ PH := + fun _ h => Set.mem_iUnion.mpr ⟨n, h⟩ + +/-- `P` is contained in the polynomial hierarchy. -/ +theorem P_subset_PH : P ⊆ PH := + SigmaP_subset_PH 0 + +end Complexity From 0b2b8e21af817594009737d9f2e753f9d9280101 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 09:05:00 -0700 Subject: [PATCH 02/24] feat(PH): state the Sipser-Lautemann theorem MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit State `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ` against the library's concrete `BPP` and the certificate-quantifier levels `SigmaP`/`PiP`, packaged as the `Prop`-valued `SipserLautemann` so downstream results can be proved against it before the probabilistic argument lands. Adds the unconditional consequences: the split into halves, the reduction of the statement to its `Σ₂` half given closure of `BPP` under complement, and `BPP ⊆ PH`. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes.lean | 1 + Complexitylib/Classes/PH/SipserLautemann.lean | 97 +++++++++++++++++++ 2 files changed, 98 insertions(+) create mode 100644 Complexitylib/Classes/PH/SipserLautemann.lean diff --git a/Complexitylib/Classes.lean b/Complexitylib/Classes.lean index 5c0d106c..0855f28e 100644 --- a/Complexitylib/Classes.lean +++ b/Complexitylib/Classes.lean @@ -61,6 +61,7 @@ public import Complexitylib.Classes.Pairing public import Complexitylib.Classes.FNP public import Complexitylib.Classes.NP.Witness public import Complexitylib.Classes.PH +public import Complexitylib.Classes.PH.SipserLautemann public import Complexitylib.Classes.NP.Reduction public import Complexitylib.Classes.NP.CoNP public import Complexitylib.Classes.NP.Closure diff --git a/Complexitylib/Classes/PH/SipserLautemann.lean b/Complexitylib/Classes/PH/SipserLautemann.lean new file mode 100644 index 00000000..d0476397 --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH +public import Complexitylib.Classes.Randomized + +/-! +# The Sipser–Lautemann theorem + +The Sipser–Lautemann theorem (Arora–Barak Theorem 7.15) places bounded-error +probabilistic polynomial time inside the second level of the polynomial +hierarchy: `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. This file states that containment against the +library's concrete `BPP` (`Complexitylib.Classes.Randomized`) and the +certificate-quantifier levels `SigmaP` / `PiP` +(`Complexitylib.Classes.PH`), and proves the set-theoretic consequences that +follow from it without any machine engineering. + +The containment itself is not proved here. Following the interface-isolation +pattern used elsewhere in the library, the statement is packaged as the +`Prop`-valued definition `SipserLautemann`, so that downstream results can be +stated and proved against it now and discharged once the probabilistic +argument lands. Every theorem in this file is unconditional: each takes the +statement (or its `Σ₂` half) as an explicit hypothesis rather than assuming it +globally. + +## Main definitions + +- `SipserLautemann` — the statement `BPP ⊆ SigmaP 2 ∩ PiP 2` + +## Main results + +- `sipserLautemann_iff` — the statement splits into its `Σ₂` and `Π₂` halves +- `sipserLautemann_of_subset_SigmaP` — the `Σ₂` half suffices, given that + `BPP` is closed under complement (`BPP` is a two-sided-error class, so the + `Π₂` half is the `Σ₂` half applied to complements) +- `BPP_subset_SigmaP_two_of_sipserLautemann`, + `BPP_subset_PiP_two_of_sipserLautemann` — the two halves +- `BPP_subset_PH_of_sipserLautemann` — `BPP ⊆ PH` + +## TODO + +- Prove `BPP` is closed under complement (swap the accept/reject outputs of a + `BPTIME` machine), reducing `SipserLautemann` to its `Σ₂` half via + `sipserLautemann_of_subset_SigmaP`. +- Prove that half. The standard route: amplify a `BPP` machine so that the + bad-seed set has density below `2^(-m)` for `m` the number of random bits + used (the amplification machinery of + `Complexitylib.Classes.Randomized.GoodSeed` and + `Complexitylib.Classes.Randomized.CircuitAmplification` is the starting + point), then express membership by Lautemann's shift trick: `x ∈ L` iff + there exist `m` shift vectors `u₁, …, u_m` whose translates of the accepting + seed set cover `{0,1}^m`, a `∃∀` predicate with a polynomial-time matrix. +-/ + +@[expose] public section + +namespace Complexity + +/-- **Sipser–Lautemann**: bounded-error probabilistic polynomial time lies in +the second level of the polynomial hierarchy, `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. + +Stated as a `Prop` rather than proved: the probabilistic argument behind it is +still to be formalized (see the module docstring). Results depending on it take +it as an explicit hypothesis. -/ +def SipserLautemann : Prop := + BPP ⊆ SigmaP 2 ∩ PiP 2 + +/-- The statement splits into its two halves: containment in `Σ₂ᵖ` and +containment in `Π₂ᵖ`. -/ +theorem sipserLautemann_iff : SipserLautemann ↔ BPP ⊆ SigmaP 2 ∧ BPP ⊆ PiP 2 := + Set.subset_inter_iff + +/-- The `Σ₂ᵖ` half of the statement. -/ +theorem BPP_subset_SigmaP_two_of_sipserLautemann (h : SipserLautemann) : + BPP ⊆ SigmaP 2 := + fun _ hL => (h hL).1 + +/-- The `Π₂ᵖ` half of the statement. -/ +theorem BPP_subset_PiP_two_of_sipserLautemann (h : SipserLautemann) : + BPP ⊆ PiP 2 := + fun _ hL => (h hL).2 + +/-- The `Σ₂ᵖ` half implies the full statement, given that `BPP` is closed under +complement: a language of `BPP` lies in `Π₂ᵖ` exactly when its complement lies +in `Σ₂ᵖ`, and the complement is again a `BPP` language. -/ +theorem sipserLautemann_of_subset_SigmaP (hcompl : ∀ L ∈ BPP, Lᶜ ∈ BPP) + (h : BPP ⊆ SigmaP 2) : SipserLautemann := + fun L hL => ⟨h hL, h (hcompl L hL)⟩ + +/-- Sipser–Lautemann puts `BPP` inside the polynomial hierarchy. -/ +theorem BPP_subset_PH_of_sipserLautemann (h : SipserLautemann) : BPP ⊆ PH := + fun _ hL => SigmaP_subset_PH 2 (h hL).1 + +end Complexity From 064579a9bac44bbab5669e7d779a3267d0d221d4 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 10:22:53 -0700 Subject: [PATCH 03/24] feat(PH): prove Sipser-Lautemann from one simulation interface MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reduce `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ` to a single machine-engineering interface, `MatrixInP`, and prove every other step unconditionally: - `SipserLautemann.Covering`: Lautemann's covering lemma in both directions — a union bound over shifted translates of an event in the seed space gives covering shifts when the event is large, and a cardinality bound rules them out when it is small. - `SipserLautemann.TimeBound`: the acceptance probability is frozen past the halting time, so a machine's arbitrary time bound may be replaced by a dominating polynomial. This is what makes the matrix predicate computable. - `SipserLautemann.Amplified`: majority amplification plus the covering lemma give `x ∈ L ↔ ∃ shifts, ∀ seeds, some shift accepts`, and the complementary form for `x ∉ L`, which yields the `Π₂` half without needing closure of `BPP` under complement. - `SipserLautemann.Encode`: bitstring codecs for seeds and shift tuples. - `SipserLautemann.Matrix`: the quantifier-free matrix as a language of encoded triples, and the identity exhibiting `L` and `Lᶜ` as polynomially bounded `∃∀` forms over it. `MatrixInP` — the matrix language is decidable in deterministic polynomial time — is the same NTM-path-simulation construction already deferred by `NP.WitnessNTMConstruction`, and is isolated rather than assumed silently. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/PH/SipserLautemann.lean | 121 +++++++--- .../Classes/PH/SipserLautemann/Amplified.lean | 185 +++++++++++++++ .../Classes/PH/SipserLautemann/Covering.lean | 211 ++++++++++++++++++ .../Classes/PH/SipserLautemann/Encode.lean | 91 ++++++++ .../Classes/PH/SipserLautemann/Matrix.lean | 187 ++++++++++++++++ .../Classes/PH/SipserLautemann/TimeBound.lean | 99 ++++++++ ROADMAP.md | 22 +- 7 files changed, 883 insertions(+), 33 deletions(-) create mode 100644 Complexitylib/Classes/PH/SipserLautemann/Amplified.lean create mode 100644 Complexitylib/Classes/PH/SipserLautemann/Covering.lean create mode 100644 Complexitylib/Classes/PH/SipserLautemann/Encode.lean create mode 100644 Complexitylib/Classes/PH/SipserLautemann/Matrix.lean create mode 100644 Complexitylib/Classes/PH/SipserLautemann/TimeBound.lean diff --git a/Complexitylib/Classes/PH/SipserLautemann.lean b/Complexitylib/Classes/PH/SipserLautemann.lean index d0476397..befa92a5 100644 --- a/Complexitylib/Classes/PH/SipserLautemann.lean +++ b/Complexitylib/Classes/PH/SipserLautemann.lean @@ -5,7 +5,7 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.PH -public import Complexitylib.Classes.Randomized +public import Complexitylib.Classes.PH.SipserLautemann.Matrix /-! # The Sipser–Lautemann theorem @@ -14,45 +14,51 @@ The Sipser–Lautemann theorem (Arora–Barak Theorem 7.15) places bounded-error probabilistic polynomial time inside the second level of the polynomial hierarchy: `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. This file states that containment against the library's concrete `BPP` (`Complexitylib.Classes.Randomized`) and the -certificate-quantifier levels `SigmaP` / `PiP` -(`Complexitylib.Classes.PH`), and proves the set-theoretic consequences that -follow from it without any machine engineering. - -The containment itself is not proved here. Following the interface-isolation -pattern used elsewhere in the library, the statement is packaged as the -`Prop`-valued definition `SipserLautemann`, so that downstream results can be -stated and proved against it now and discharged once the probabilistic -argument lands. Every theorem in this file is unconditional: each takes the -statement (or its `Σ₂` half) as an explicit hypothesis rather than assuming it -globally. +certificate-quantifier levels `SigmaP` / `PiP` (`Complexitylib.Classes.PH`), +and proves it from a single machine-engineering interface, `MatrixInP`. + +## What is proved, and what is assumed + +Everything except one Turing-machine construction is proved here and in the +`SipserLautemann` subdirectory: + +- `Covering` — Lautemann's covering lemma in both directions, by counting + shifts of an event in the seed space; +- `TimeBound` — the acceptance probability is frozen past the halting time, so + a machine's arbitrary time bound may be replaced by a dominating polynomial; +- `Amplified` — majority amplification plus the covering lemma give the `∃∀` + characterization `x ∈ L ↔ ∃ shifts, ∀ seeds, some shift accepts`, and its + complementary form for `x ∉ L`; +- `Encode` — bitstring codecs for seeds and shift tuples; +- `Matrix` — the quantifier-free matrix as a language of encoded triples, and + the identity exhibiting `L` and `Lᶜ` as polynomially bounded `∃∀` forms over + it. + +The one interface left open is `MatrixInP`: the matrix language is decidable +in deterministic polynomial time. That is the standard "simulate a fixed +machine on given random bits" construction — parse the triple, recover the +per-trial step count from the input length, run the fixed machine on each +shifted seed, and take the majority vote — of the same kind as +`Complexitylib.Classes.NP.Witness`'s `WitnessNTMConstruction`, and it is +deliberately isolated rather than assumed silently. Note that the matrix +language is taken at a *polynomial* time bound, which is what makes the step +count recoverable by a decider; `TimeBound` supplies the normalization. ## Main definitions - `SipserLautemann` — the statement `BPP ⊆ SigmaP 2 ∩ PiP 2` +- `MatrixInP` — the polynomial-time decidability interface for the matrix ## Main results +- `sipserLautemann_of_matrixInP` — **the theorem**, given the interface +- `mem_SigmaP_two_of_matrixInP`, `mem_PiP_two_of_matrixInP` — the two halves - `sipserLautemann_iff` — the statement splits into its `Σ₂` and `Π₂` halves - `sipserLautemann_of_subset_SigmaP` — the `Σ₂` half suffices, given that - `BPP` is closed under complement (`BPP` is a two-sided-error class, so the - `Π₂` half is the `Σ₂` half applied to complements) + `BPP` is closed under complement - `BPP_subset_SigmaP_two_of_sipserLautemann`, `BPP_subset_PiP_two_of_sipserLautemann` — the two halves - `BPP_subset_PH_of_sipserLautemann` — `BPP ⊆ PH` - -## TODO - -- Prove `BPP` is closed under complement (swap the accept/reject outputs of a - `BPTIME` machine), reducing `SipserLautemann` to its `Σ₂` half via - `sipserLautemann_of_subset_SigmaP`. -- Prove that half. The standard route: amplify a `BPP` machine so that the - bad-seed set has density below `2^(-m)` for `m` the number of random bits - used (the amplification machinery of - `Complexitylib.Classes.Randomized.GoodSeed` and - `Complexitylib.Classes.Randomized.CircuitAmplification` is the starting - point), then express membership by Lautemann's shift trick: `x ∈ L` iff - there exist `m` shift vectors `u₁, …, u_m` whose translates of the accepting - seed set cover `{0,1}^m`, a `∃∀` predicate with a polynomial-time matrix. -/ @[expose] public section @@ -62,12 +68,65 @@ namespace Complexity /-- **Sipser–Lautemann**: bounded-error probabilistic polynomial time lies in the second level of the polynomial hierarchy, `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. -Stated as a `Prop` rather than proved: the probabilistic argument behind it is -still to be formalized (see the module docstring). Results depending on it take -it as an explicit hypothesis. -/ +Stated as a `Prop` so that results can depend on it explicitly; it is proved +from the `MatrixInP` interface by `sipserLautemann_of_matrixInP`. -/ def SipserLautemann : Prop := BPP ⊆ SigmaP 2 ∩ PiP 2 +/-- **The matrix-decidability interface.** For every machine and every +polynomial time bound, the quantifier-free matrix of the Lautemann +characterization is decidable in deterministic polynomial time. + +A decider parses `pair (pair x w) r`, computes the per-trial step count +`pt.eval |x|` and the amplified seed length from it, decodes the shift tuple +and the seed, and for each shift runs the fixed machine on the shifted seed, +block by block, taking the majority verdict; all of this is polynomial in the +input length. Isolating it here keeps the probabilistic and combinatorial +content of the theorem free of machine engineering. -/ +def MatrixInP : Prop := + ∀ (k : ℕ) (tm : NTM k) (pt : Polynomial ℕ) (b : Bool), + Lautemann.matrixLang tm pt.eval b ∈ P + +/-- Every `BPP` language is in `Σ₂ᵖ`, given the matrix interface. -/ +theorem mem_SigmaP_two_of_matrixInP (hmatrix : MatrixInP) {L : Language} + (hL : L ∈ BPP) : L ∈ SigmaP 2 := by + obtain ⟨d, hd⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, f, hhalt, haccept, hreject, hO⟩ := hd + obtain ⟨pt, hpt⟩ := BigO.pow_polynomial_bound hO + obtain ⟨hq, hp⟩ := Lautemann.boundPoly_bounds (f := pt.eval) (P := pt) (fun n => le_rfl) + have haccept' : tm.AcceptsWithProb L pt.eval (2 / 3) := + NTM.acceptsWithProb_of_le hhalt hpt haccept + have hreject' : tm.RejectsWithProb L pt.eval (1 / 3) := + NTM.rejectsWithProb_of_le hhalt hpt hreject + have hEq := Lautemann.eq_polyExistsLang_of_boundedError haccept' hreject' hp hq + show L ∈ SigmaP (1 + 1) + rw [SigmaP_succ, PiP_one] + exact ⟨(Lautemann.boundPoly pt + 1) * Lautemann.boundPoly pt, _, + ⟨Lautemann.boundPoly pt, _, hmatrix k tm pt true, rfl⟩, hEq⟩ + +/-- Every `BPP` language is in `Π₂ᵖ`, given the matrix interface: the +complementary covering characterization puts the complement in `Σ₂ᵖ`. -/ +theorem mem_PiP_two_of_matrixInP (hmatrix : MatrixInP) {L : Language} + (hL : L ∈ BPP) : L ∈ PiP 2 := by + obtain ⟨d, hd⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, f, hhalt, haccept, hreject, hO⟩ := hd + obtain ⟨pt, hpt⟩ := BigO.pow_polynomial_bound hO + obtain ⟨hq, hp⟩ := Lautemann.boundPoly_bounds (f := pt.eval) (P := pt) (fun n => le_rfl) + have haccept' : tm.AcceptsWithProb L pt.eval (2 / 3) := + NTM.acceptsWithProb_of_le hhalt hpt haccept + have hreject' : tm.RejectsWithProb L pt.eval (1 / 3) := + NTM.rejectsWithProb_of_le hhalt hpt hreject + have hEq := Lautemann.compl_eq_polyExistsLang_of_boundedError haccept' hreject' hp hq + show Lᶜ ∈ SigmaP (1 + 1) + rw [SigmaP_succ, PiP_one] + exact ⟨(Lautemann.boundPoly pt + 1) * Lautemann.boundPoly pt, _, + ⟨Lautemann.boundPoly pt, _, hmatrix k tm pt false, rfl⟩, hEq⟩ + +/-- **The Sipser–Lautemann theorem**, given the matrix-decidability +interface: `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. -/ +theorem sipserLautemann_of_matrixInP (hmatrix : MatrixInP) : SipserLautemann := + fun _ hL => ⟨mem_SigmaP_two_of_matrixInP hmatrix hL, mem_PiP_two_of_matrixInP hmatrix hL⟩ + /-- The statement splits into its two halves: containment in `Σ₂ᵖ` and containment in `Π₂ᵖ`. -/ theorem sipserLautemann_iff : SipserLautemann ↔ BPP ⊆ SigmaP 2 ∧ BPP ⊆ PiP 2 := diff --git a/Complexitylib/Classes/PH/SipserLautemann/Amplified.lean b/Complexitylib/Classes/PH/SipserLautemann/Amplified.lean new file mode 100644 index 00000000..2cbb499b --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann/Amplified.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH.SipserLautemann.Covering +public import Complexitylib.Classes.Randomized +public import Complexitylib.Models.TuringMachine.Repetition.Correctness + +/-! +# The amplified Lautemann characterization + +Combining majority amplification with the covering lemma of +`Complexitylib.Classes.PH.SipserLautemann.Covering`, this file proves the +`∃∀` characterization at the heart of the Sipser–Lautemann theorem. +-/ + +@[expose] public section + +namespace Complexity + +namespace Lautemann + +variable {k : ℕ} + +/-- `13 K² < 2 ^ K` from `K = 11` on: the numeric fact making the amplified +seed count smaller than the amplified error denominator. -/ +private theorem thirteen_mul_sq_lt_two_pow : ∀ K, 11 ≤ K → 13 * K ^ 2 < 2 ^ K := by + intro K + induction K with + | zero => intro h; omega + | succ n ih => + intro _ + rcases Nat.lt_or_ge n 11 with hn | hn + · have hn10 : n = 10 := by omega + subst hn10 + norm_num + · have hprev := ih (by omega) + calc 13 * (n + 1) ^ 2 ≤ 2 * (13 * n ^ 2) := by nlinarith + _ < 2 * 2 ^ n := by omega + _ = 2 ^ (n + 1) := by rw [pow_succ]; ring + +/-- Amplification exponent for inputs of length `n`: the amplified error is +`2 ^ (-ampExp f n)`. It is taken large enough to dominate the amplified seed +length, which is what the covering lemma's soundness direction needs. -/ +def ampExp (f : ℕ → ℕ) (n : ℕ) : ℕ := f n + 11 + +/-- Number of independent trials of the source machine, an odd count so that +majority votes cannot tie. -/ +def ampRuns (f : ℕ → ℕ) (n : ℕ) : ℕ := 12 * ampExp f n + 1 + +/-- Number of shifts used to cover the seed space: one more than the seed +length, so that the degenerate zero-length seed space is still covered. -/ +def ampShifts (f : ℕ → ℕ) (n : ℕ) : ℕ := ampRuns f n * f n + 1 + +/-- The amplified accepting event: the long seeds on which a strict majority +of the `ampRuns f n` independent trials accepts. -/ +def ampEvent (tm : NTM k) (f : ℕ → ℕ) (x : List Bool) : + Finset (Fin (ampRuns f x.length * f x.length) → Bool) := + Finset.univ.filter fun w => + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) w = true + +/-- Membership in the amplified event is the majority verdict. -/ +@[simp] theorem mem_ampEvent (tm : NTM k) (f : ℕ → ℕ) (x : List Bool) + (w : Fin (ampRuns f x.length * f x.length) → Bool) : + w ∈ ampEvent tm f x ↔ + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) w = true := by + simp [ampEvent] + +/-- The complement of the amplified event is the majority-rejecting event. -/ +theorem compl_ampEvent (tm : NTM k) (f : ℕ → ℕ) (x : List Bool) : + (ampEvent tm f x)ᶜ = Finset.univ.filter fun w => + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) w = false := by + ext w + simp [ampEvent, Bool.not_eq_true] + +/-- Membership in the complement of the amplified event is the rejecting +majority verdict. Not a `simp` lemma: `simp` reaches the same normal form +through `Finset.mem_compl` and `mem_ampEvent`. -/ +theorem mem_compl_ampEvent (tm : NTM k) (f : ℕ → ℕ) (x : List Bool) + (w : Fin (ampRuns f x.length * f x.length) → Bool) : + w ∈ (ampEvent tm f x)ᶜ ↔ + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) w = false := by + rw [compl_ampEvent] + simp + +/-- The number of shifts is below the amplified error denominator. -/ +theorem ampShifts_lt_two_pow_ampExp (f : ℕ → ℕ) (n : ℕ) : + ampShifts f n < 2 ^ ampExp f n := by + have hK : 11 ≤ ampExp f n := by simp [ampExp] + have hfn : f n ≤ ampExp f n := by simp [ampExp] + have hnum : ampShifts f n ≤ 13 * (ampExp f n) ^ 2 := by + have hmul : ampRuns f n * f n ≤ (12 * ampExp f n + 1) * ampExp f n := + Nat.mul_le_mul_left _ hfn + simp only [ampShifts, ampRuns] at * + nlinarith + exact lt_of_le_of_lt hnum (thirteen_mul_sq_lt_two_pow _ hK) + +/-- **Completeness.** On an accepted input the amplified event fails with +probability at most `2 ^ (-ampExp f n)`, so the covering lemma supplies +`ampShifts f n` shifts covering the whole seed space. -/ +theorem exists_covers_of_mem {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (haccept : tm.AcceptsWithProb L f (2 / 3)) {x : List Bool} (hx : x ∈ L) : + ∃ u : Fin (ampShifts f x.length) → + Fin (ampRuns f x.length * f x.length) → Bool, + Covers (ampEvent tm f x) u := by + have hE : 2 / 3 ≤ eventProb (NTM.repeatAcceptEvent tm x (f x.length)) := by + rw [← NTM.acceptProb_eq_eventProb_repeatAcceptEvent] + exact haccept x hx + have herr : eventProb (ampEvent tm f x)ᶜ ≤ 1 / 2 ^ ampExp f x.length := by + rw [compl_ampEvent] + exact eventProb_blockMajority_false_le_two_pow (f x.length) (ampExp f x.length) _ hE + refine exists_covers_of_eventProb_compl_le _ ?_ herr + have hK : 1 ≤ ampExp f x.length := by simp [ampExp] + have := Nat.mul_le_mul_right (ampShifts f x.length) hK + simp only [ampShifts, one_mul] at this ⊢ + omega + +/-- **Soundness.** On a rejected input the amplified event holds with +probability at most `2 ^ (-ampExp f n)`, which is too small for +`ampShifts f n` shifts of it to cover the seed space. -/ +theorem not_covers_of_notMem {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (hreject : tm.RejectsWithProb L f (1 / 3)) {x : List Bool} (hx : x ∉ L) + (u : Fin (ampShifts f x.length) → Fin (ampRuns f x.length * f x.length) → Bool) : + ¬ Covers (ampEvent tm f x) u := by + have hE : eventProb (NTM.repeatAcceptEvent tm x (f x.length)) ≤ 1 / 3 := by + rw [← NTM.acceptProb_eq_eventProb_repeatAcceptEvent] + exact hreject x hx + have herr : eventProb (ampEvent tm f x) ≤ 1 / 2 ^ ampExp f x.length := + eventProb_blockMajority_true_le_two_pow (f x.length) (ampExp f x.length) _ hE + exact not_covers_of_eventProb_le _ (ampShifts_lt_two_pow_ampExp f x.length) herr u + +/-- **The Lautemann characterization.** For a bounded-error machine deciding +`L`, membership is equivalent to the existence of a tuple of shifts whose +translates of the amplified accepting event cover the seed space — an `∃∀` +form with a deterministic, polynomially-checkable matrix. -/ +theorem mem_iff_exists_covers {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (haccept : tm.AcceptsWithProb L f (2 / 3)) (hreject : tm.RejectsWithProb L f (1 / 3)) + (x : List Bool) : + x ∈ L ↔ ∃ u : Fin (ampShifts f x.length) → + Fin (ampRuns f x.length * f x.length) → Bool, Covers (ampEvent tm f x) u := by + constructor + · exact fun hx => exists_covers_of_mem haccept hx + · intro hcov + by_contra hx + obtain ⟨u, hu⟩ := hcov + exact not_covers_of_notMem hreject hx u hu + +/-- **The complementary Lautemann characterization.** Non-membership is +equivalent to the existence of shifts covering the seed space with translates +of the majority-*rejecting* event. Together with `mem_iff_exists_covers` this +puts both `L` and its complement in the same `∃∀` form, which is what places +`BPP` in `Σ₂ᵖ ∩ Π₂ᵖ` rather than only in `Σ₂ᵖ`. -/ +theorem notMem_iff_exists_covers_compl {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (haccept : tm.AcceptsWithProb L f (2 / 3)) (hreject : tm.RejectsWithProb L f (1 / 3)) + (x : List Bool) : + x ∉ L ↔ ∃ u : Fin (ampShifts f x.length) → + Fin (ampRuns f x.length * f x.length) → Bool, Covers (ampEvent tm f x)ᶜ u := by + constructor + · intro hx + have hE : eventProb (NTM.repeatAcceptEvent tm x (f x.length)) ≤ 1 / 3 := by + rw [← NTM.acceptProb_eq_eventProb_repeatAcceptEvent] + exact hreject x hx + have herr : eventProb ((ampEvent tm f x)ᶜ)ᶜ ≤ 1 / 2 ^ ampExp f x.length := by + rw [compl_compl] + exact eventProb_blockMajority_true_le_two_pow (f x.length) (ampExp f x.length) _ hE + refine exists_covers_of_eventProb_compl_le _ ?_ herr + have hK : 1 ≤ ampExp f x.length := by simp [ampExp] + have := Nat.mul_le_mul_right (ampShifts f x.length) hK + simp only [ampShifts, one_mul] at this ⊢ + omega + · intro hcov hx + obtain ⟨u, hu⟩ := hcov + have hE : 2 / 3 ≤ eventProb (NTM.repeatAcceptEvent tm x (f x.length)) := by + rw [← NTM.acceptProb_eq_eventProb_repeatAcceptEvent] + exact haccept x hx + have herr : eventProb (ampEvent tm f x)ᶜ ≤ 1 / 2 ^ ampExp f x.length := by + rw [compl_ampEvent] + exact eventProb_blockMajority_false_le_two_pow (f x.length) (ampExp f x.length) _ hE + exact not_covers_of_eventProb_le _ (ampShifts_lt_two_pow_ampExp f x.length) herr u hu + +end Lautemann + +end Complexity diff --git a/Complexitylib/Classes/PH/SipserLautemann/Covering.lean b/Complexitylib/Classes/PH/SipserLautemann/Covering.lean new file mode 100644 index 00000000..070b9b70 --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann/Covering.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.EventProb + +/-! +# Lautemann's covering lemma + +The combinatorial core of the Sipser–Lautemann theorem, stated for an event +`E` in the seed space `Fin m → Bool` and the XOR shift action on that space. +-/ + +@[expose] public section + +namespace Complexity + +namespace Lautemann + +variable {m t k : ℕ} + +/-- XOR shift of a seed by a vector. -/ +def shift (r u : Fin m → Bool) : Fin m → Bool := fun i => xor (r i) (u i) + +@[simp] theorem shift_shift (r u : Fin m → Bool) : shift (shift r u) u = r := by + funext i + simp [shift] + +/-- The shift action is symmetric in its two arguments. -/ +theorem shift_comm (r u : Fin m → Bool) : shift r u = shift u r := by + funext i + simp [shift, Bool.xor_comm] + +/-- Shifting by a fixed vector is an involutive equivalence of the seed space. -/ +def shiftEquiv (u : Fin m → Bool) : (Fin m → Bool) ≃ (Fin m → Bool) where + toFun r := shift r u + invFun r := shift r u + left_inv r := shift_shift r u + right_inv r := shift_shift r u + +/-- The `t` shifts `u 0, …, u (t-1)` of the event `E` cover the whole seed +space: every seed lands in `E` after at least one of them. -/ +def Covers (E : Finset (Fin m → Bool)) (u : Fin t → Fin m → Bool) : Prop := + ∀ r, ∃ i, shift r (u i) ∈ E + +/-- Shifting is measure preserving: the seeds carried into `E` by a fixed +shift are as many as the elements of `E`. -/ +theorem card_filter_shift_mem (E : Finset (Fin m → Bool)) (u : Fin m → Bool) : + (Finset.univ.filter fun r => shift r u ∈ E).card = E.card := by + have hset : (Finset.univ.filter fun r => shift r u ∈ E) = E.image (fun v => shift v u) := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_image] + constructor + · intro h + exact ⟨shift r u, h, by simp⟩ + · rintro ⟨v, hv, rfl⟩ + simpa using hv + have hinj : Function.Injective (fun v : Fin m → Bool => shift v u) := by + intro a b hab + have := congrArg (fun w => shift w u) hab + simpa using this + rw [hset, Finset.card_image_of_injective _ hinj] + +/-- The number of seeds is `2 ^ m`. -/ +theorem card_univ_seed : (Finset.univ : Finset (Fin m → Bool)).card = 2 ^ m := by + rw [Finset.card_univ, card_finArrowBool] + +/-- The number of `t`-tuples of shift vectors is `(2 ^ m) ^ t`. -/ +theorem card_univ_shifts : + (Finset.univ : Finset (Fin t → Fin m → Bool)).card = (2 ^ m) ^ t := by + rw [Finset.card_univ, Fintype.card_fun, card_finArrowBool, Fintype.card_fin] + +/-- **Existence of covering shifts.** If the complement of `E` is small enough +that `2 ^ m` translates of its `m`-fold product miss the whole shift space, +some `m`-tuple of shifts covers every seed. This is the counting form of the +probabilistic argument: a uniformly random tuple fails to cover a fixed seed +with probability `(1 - eventProb E) ^ m`, and a union bound over the `2 ^ m` +seeds leaves a covering tuple. -/ +theorem exists_covers_of_card (E : Finset (Fin m → Bool)) + (h : 2 ^ m * (2 ^ m - E.card) ^ t < (2 ^ m) ^ t) : + ∃ u : Fin t → Fin m → Bool, Covers E u := by + classical + set bad : Finset (Fin t → Fin m → Bool) := + Finset.univ.filter (fun u => ¬ Covers E u) with hbad + have hsub : bad ⊆ Finset.univ.biUnion (fun r : Fin m → Bool => + Fintype.piFinset (fun _ : Fin t => Finset.univ.filter fun v => shift r v ∉ E)) := by + intro u hu + simp only [hbad, Finset.mem_filter, Finset.mem_univ, true_and, Covers, not_forall] at hu + obtain ⟨r, hr⟩ := hu + simp only [not_exists] at hr + exact Finset.mem_biUnion.mpr ⟨r, Finset.mem_univ r, by + simp only [Fintype.mem_piFinset, Finset.mem_filter, Finset.mem_univ, true_and] + exact fun i => hr i⟩ + have hfiber : ∀ r : Fin m → Bool, + (Fintype.piFinset (fun _ : Fin t => Finset.univ.filter fun v => shift r v ∉ E)).card + = (2 ^ m - E.card) ^ t := by + intro r + rw [Fintype.card_piFinset] + have hone : (Finset.univ.filter fun v => shift r v ∉ E).card = 2 ^ m - E.card := by + have : (Finset.univ.filter fun v => shift r v ∉ E) + = Finset.univ.filter fun v => shift v r ∈ Eᶜ := by + ext v + simp [shift_comm v r] + rw [this, card_filter_shift_mem Eᶜ r, Finset.card_compl, card_finArrowBool] + simp [hone] + have hcard : bad.card < (2 ^ m) ^ t := by + calc bad.card + ≤ (Finset.univ.biUnion (fun r : Fin m → Bool => + Fintype.piFinset (fun _ : Fin t => Finset.univ.filter fun v => shift r v ∉ E))).card := + Finset.card_le_card hsub + _ ≤ ∑ _r : Fin m → Bool, (2 ^ m - E.card) ^ t := by + refine le_trans (Finset.card_biUnion_le) ?_ + exact Finset.sum_le_sum fun r _ => le_of_eq (hfiber r) + _ = 2 ^ m * (2 ^ m - E.card) ^ t := by + rw [Finset.sum_const, card_univ_seed] + simp + _ < (2 ^ m) ^ t := h + have hex : ∃ u : Fin t → Fin m → Bool, u ∉ bad := by + by_contra hcon + simp only [not_exists, not_not] at hcon + have : (Finset.univ : Finset (Fin t → Fin m → Bool)) ⊆ bad := fun u _ => hcon u + have hle := Finset.card_le_card this + rw [card_univ_shifts] at hle + omega + obtain ⟨u, hu⟩ := hex + refine ⟨u, ?_⟩ + simpa [hbad] using hu + +/-- **No covering when the event is small.** If `t` copies of `E` cannot fill +the seed space by cardinality alone, no tuple of `t` shifts covers it. -/ +theorem not_covers_of_card (E : Finset (Fin m → Bool)) (h : t * E.card < 2 ^ m) + (u : Fin t → Fin m → Bool) : ¬ Covers E u := by + classical + intro hcov + have hsub : (Finset.univ : Finset (Fin m → Bool)) ⊆ + Finset.univ.biUnion (fun i : Fin t => Finset.univ.filter fun r => shift r (u i) ∈ E) := by + intro r _ + obtain ⟨i, hi⟩ := hcov r + exact Finset.mem_biUnion.mpr ⟨i, Finset.mem_univ i, by simp [hi]⟩ + have hle := Finset.card_le_card hsub + rw [card_univ_seed] at hle + have hbound : (Finset.univ.biUnion (fun i : Fin t => + Finset.univ.filter fun r => shift r (u i) ∈ E)).card ≤ t * E.card := by + refine le_trans Finset.card_biUnion_le ?_ + calc ∑ i : Fin t, (Finset.univ.filter fun r => shift r (u i) ∈ E).card + = ∑ _i : Fin t, E.card := by + exact Finset.sum_congr rfl fun i _ => card_filter_shift_mem E (u i) + _ = t * E.card := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin] + simp + _ ≤ t * E.card := le_rfl + omega + +/-! ## Probability form -/ + +/-- An event of probability at most `2 ^ (-k)` has at most `2 ^ (m - k)` +elements, in the multiplication-only form used below. -/ +theorem card_mul_two_pow_le (E : Finset (Fin m → Bool)) (h : eventProb E ≤ 1 / 2 ^ k) : + E.card * 2 ^ k ≤ 2 ^ m := by + have h2m : (0 : ℚ) < 2 ^ m := by positivity + have h2k : (0 : ℚ) < 2 ^ k := by positivity + have hq : (E.card : ℚ) * 2 ^ k ≤ 2 ^ m := by + rw [eventProb, div_le_div_iff₀ h2m h2k] at h + linarith + exact_mod_cast hq + +/-- **Lautemann's covering lemma, completeness direction.** If the event `E` +fails with probability at most `2 ^ (-k)`, and the seed length `m` is below +`k * t`, then some `t` shifts of `E` cover the whole seed space. Since the +failure probability enters as its `t`-th power against a union bound over the +`2 ^ m` seeds, any `k ≥ 2` suffices at `t ≥ m`. -/ +theorem exists_covers_of_eventProb_compl_le (E : Finset (Fin m → Bool)) + (hmt : m < k * t) (h : eventProb Eᶜ ≤ 1 / 2 ^ k) : + ∃ u : Fin t → Fin m → Bool, Covers E u := by + have hc : Eᶜ.card = 2 ^ m - E.card := by rw [Finset.card_compl, card_finArrowBool] + have hle : Eᶜ.card * 2 ^ k ≤ 2 ^ m := card_mul_two_pow_le Eᶜ h + refine exists_covers_of_card E ?_ + rw [← hc] + by_contra hcon + simp only [not_lt] at hcon + have hpos : 0 < (2 ^ m : ℕ) ^ t := Nat.pow_pos (Nat.two_pow_pos m) + have key : (2 ^ m : ℕ) ^ t * 2 ^ (k * t) ≤ (2 ^ m : ℕ) ^ t * 2 ^ m := by + calc (2 ^ m : ℕ) ^ t * 2 ^ (k * t) + ≤ (2 ^ m * Eᶜ.card ^ t) * 2 ^ (k * t) := Nat.mul_le_mul_right _ hcon + _ = 2 ^ m * (Eᶜ.card * 2 ^ k) ^ t := by + rw [mul_pow, ← pow_mul] + ring + _ ≤ 2 ^ m * (2 ^ m) ^ t := Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hle t) + _ = (2 ^ m : ℕ) ^ t * 2 ^ m := by ring + have hexp : (2 : ℕ) ^ (k * t) ≤ 2 ^ m := Nat.le_of_mul_le_mul_left key hpos + have hkm : k * t ≤ m := (Nat.pow_le_pow_iff_right (by norm_num)).mp hexp + omega + +/-- **Lautemann's covering lemma, soundness direction.** If the event `E` holds +with probability at most `2 ^ (-k)` and the number of shifts `t` is below +`2 ^ k`, then no `t` shifts of `E` cover the seed space. -/ +theorem not_covers_of_eventProb_le (E : Finset (Fin m → Bool)) (hk : t < 2 ^ k) + (h : eventProb E ≤ 1 / 2 ^ k) (u : Fin t → Fin m → Bool) : ¬ Covers E u := by + refine not_covers_of_card E ?_ u + have hle := card_mul_two_pow_le E h + rcases Nat.eq_zero_or_pos E.card with h0 | h0 + · simp [h0, Nat.two_pow_pos m] + · calc t * E.card < 2 ^ k * E.card := (Nat.mul_lt_mul_right h0).mpr hk + _ = E.card * 2 ^ k := Nat.mul_comm _ _ + _ ≤ 2 ^ m := hle + +end Lautemann + +end Complexity diff --git a/Complexitylib/Classes/PH/SipserLautemann/Encode.lean b/Complexitylib/Classes/PH/SipserLautemann/Encode.lean new file mode 100644 index 00000000..52758c65 --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann/Encode.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH.SipserLautemann.Covering + +/-! +# Bitstring codecs for seeds and shift tuples + +The Lautemann characterization quantifies over seeds `Fin m → Bool` and over +tuples of shifts `Fin t → Fin m → Bool`, while the polynomial hierarchy +quantifies over bitstrings. This file provides the two codecs and their +round-trip lemmas: `listOfSeed`/`seedOfList` for a single seed, and +`listOfShifts`/`shiftsOfList` for a tuple, flattened in row-major order. + +Decoding is total — out-of-range positions read as `false` — so a decoder is +available on every bitstring, and the length equations pin down the well-formed +encodings. +-/ + +@[expose] public section + +namespace Complexity + +namespace Lautemann + +variable {t m : ℕ} + +/-- Encode a seed as a bitstring, one bit per position. -/ +def listOfSeed (s : Fin m → Bool) : List Bool := (List.finRange m).map s + +/-- Decode a bitstring as a seed, reading out-of-range positions as `false`. -/ +def seedOfList (m : ℕ) (r : List Bool) : Fin m → Bool := fun j => r.getD j.val false + +@[simp] theorem length_listOfSeed (s : Fin m → Bool) : (listOfSeed s).length = m := by + simp [listOfSeed] + +/-- Reading an encoded seed at an in-range position returns that bit. -/ +theorem getD_listOfSeed (s : Fin m → Bool) (idx : ℕ) (h : idx < m) : + (listOfSeed s).getD idx false = s ⟨idx, h⟩ := by + have hlen : idx < (listOfSeed s).length := by simpa using h + rw [List.getD, List.getElem?_eq_getElem hlen, Option.getD_some] + simp [listOfSeed] + +@[simp] theorem seedOfList_listOfSeed (s : Fin m → Bool) : + seedOfList m (listOfSeed s) = s := by + funext j + simpa [seedOfList] using getD_listOfSeed s j.val j.isLt + +/-- Flatten a tuple of shifts into a single seed of length `t * m`, in +row-major order. -/ +def flattenShifts (u : Fin t → Fin m → Bool) : Fin (t * m) → Bool := fun kk => + if h : 0 < m then + u ⟨kk.val / m, (Nat.div_lt_iff_lt_mul h).mpr kk.isLt⟩ ⟨kk.val % m, Nat.mod_lt _ h⟩ + else false + +/-- Encode a tuple of shifts as a bitstring of length `t * m`. -/ +def listOfShifts (u : Fin t → Fin m → Bool) : List Bool := listOfSeed (flattenShifts u) + +/-- Decode a bitstring as a tuple of shifts, reading out-of-range positions as +`false`. -/ +def shiftsOfList (t m : ℕ) (w : List Bool) : Fin t → Fin m → Bool := + fun i j => w.getD (i.val * m + j.val) false + +@[simp] theorem length_listOfShifts (u : Fin t → Fin m → Bool) : + (listOfShifts u).length = t * m := by + simp [listOfShifts] + +@[simp] theorem shiftsOfList_listOfShifts (u : Fin t → Fin m → Bool) : + shiftsOfList t m (listOfShifts u) = u := by + funext i j + have hm : 0 < m := Nat.pos_of_ne_zero (by rintro rfl; exact absurd j.isLt (by omega)) + have hidx : i.val * m + j.val < t * m := by + have hi : i.val + 1 ≤ t := i.isLt + calc i.val * m + j.val < i.val * m + m := by omega + _ = (i.val + 1) * m := by ring + _ ≤ t * m := Nat.mul_le_mul_right _ hi + have hdiv : (i.val * m + j.val) / m = i.val := by + rw [Nat.mul_comm, Nat.mul_add_div hm, Nat.div_eq_of_lt j.isLt, Nat.add_zero] + have hmod : (i.val * m + j.val) % m = j.val := by + rw [Nat.mul_comm, Nat.mul_add_mod, Nat.mod_eq_of_lt j.isLt] + simp only [shiftsOfList, listOfShifts] + rw [getD_listOfSeed _ _ hidx] + simp only [flattenShifts, dif_pos hm] + congr 1 <;> [exact Fin.ext hdiv; exact Fin.ext hmod] + +end Lautemann + +end Complexity diff --git a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean new file mode 100644 index 00000000..b4037293 --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH +public import Complexitylib.Classes.PH.SipserLautemann.Amplified +public import Complexitylib.Classes.PH.SipserLautemann.Encode +public import Complexitylib.Classes.PH.SipserLautemann.TimeBound + +/-! +# The Lautemann matrix language and the `Σ₂` form + +The `∃∀` characterization of +`Complexitylib.Classes.PH.SipserLautemann.Amplified` quantifies over shift +tuples and seeds; the polynomial hierarchy quantifies over bitstrings. This +file bridges the two: `matrixLang` is the innermost, quantifier-free predicate +as a language of encoded triples, and `eq_polyExistsLang_polyForallLang` says +that a bounded-error language is literally a polynomially bounded `∃∀` over it. + +Both the language and the identity are stated for a general time-bound +function `f`, but the intended instance takes `f` to be the evaluation of a +polynomial — see `NTM.acceptsWithProb_of_le`, which replaces a machine's +arbitrary halting bound by a dominating polynomial. That is what makes the +matrix predicate computable: a decider must recover the per-trial step count +from the input length, which it can do when the count is a fixed polynomial in +`|x|`, and cannot do for an arbitrary `f`. + +## Main definitions + +- `matrixLang tm f b` — on `pair (pair x w) r`: the decoded shifts of the + decoded seed contain one whose amplified majority verdict is `b` +- `boundPoly` — the polynomial bounding the amplified seed length + +## Main results + +- `mem_matrixLang_pair` — membership on an encoded triple +- `eq_polyExistsLang_polyForallLang` — the `Σ₂` form of a bounded-error + language, and `compl_eq_polyExistsLang_polyForallLang` for its complement +- `boundPoly_bounds` — the amplified lengths are polynomially bounded +-/ + +@[expose] public section + +namespace Complexity + +namespace Lautemann + +variable {k : ℕ} + +/-! ## The matrix language -/ + +/-- The innermost predicate of the Lautemann characterization, as a language of +encoded triples. On `z = pair (pair x w) r` with `r` a well-formed seed, it +holds when some shift decoded from `w` carries the seed decoded from `r` to a +seed whose amplified majority verdict is `b`. Malformed `z`, and seeds of the +wrong length, are in the language. -/ +def matrixLang (tm : NTM k) (f : ℕ → ℕ) (b : Bool) : Language := + {z | ∀ x w r, z = pair (pair x w) r → + r.length = ampRuns f x.length * f x.length → + ∃ i : Fin (ampShifts f x.length), + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) + (shift (seedOfList (ampRuns f x.length * f x.length) r) + (shiftsOfList (ampShifts f x.length) + (ampRuns f x.length * f x.length) w i)) = b} + +/-- Membership of an encoded triple in the matrix language. -/ +theorem mem_matrixLang_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : + pair (pair x w) r ∈ matrixLang tm f b ↔ + (r.length = ampRuns f x.length * f x.length → + ∃ i : Fin (ampShifts f x.length), + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) + (shift (seedOfList (ampRuns f x.length * f x.length) r) + (shiftsOfList (ampShifts f x.length) + (ampRuns f x.length * f x.length) w i)) = b) := by + constructor + · intro h + exact h x w r rfl + · intro h x' w' r' hz + obtain ⟨hy, hr⟩ := pair_inj hz + obtain ⟨hx, hw⟩ := pair_inj hy + subst hx + subst hw + subst hr + exact h + +/-! ## The `Σ₂` form -/ + +/-- **The `Σ₂` form of a covering characterization.** Given a family of events +whose covering-by-shifts characterizes a language `A`, that language is a +polynomially bounded existential over a polynomially bounded universal over +the matrix language. The existential witness encodes a covering tuple of +shifts, and the universal variable ranges over seeds. -/ +theorem eq_polyExistsLang_polyForallLang {tm : NTM k} {f : ℕ → ℕ} {b : Bool} + {A : Language} + (E : ∀ x : List Bool, Finset (Fin (ampRuns f x.length * f x.length) → Bool)) + (hmem : ∀ (x : List Bool) (w : Fin (ampRuns f x.length * f x.length) → Bool), + w ∈ E x ↔ blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) w = b) + (hA : ∀ x : List Bool, x ∈ A ↔ ∃ u : Fin (ampShifts f x.length) → + Fin (ampRuns f x.length * f x.length) → Bool, Covers (E x) u) + {p q : Polynomial ℕ} + (hp : ∀ n, ampShifts f n * (ampRuns f n * f n) ≤ p.eval n) + (hq : ∀ n, ampRuns f n * f n ≤ q.eval n) : + A = polyExistsLang p (polyForallLang q (matrixLang tm f b)) := by + ext x + rw [hA x] + simp only [mem_polyExistsLang, mem_polyForallLang] + constructor + · rintro ⟨u, hu⟩ + refine ⟨listOfShifts u, ?_, ?_⟩ + · rw [length_listOfShifts] + exact hp x.length + · intro r _ + rw [mem_matrixLang_pair] + intro hrlen + obtain ⟨i, hi⟩ := hu (seedOfList (ampRuns f x.length * f x.length) r) + rw [hmem] at hi + exact ⟨i, by simpa using hi⟩ + · rintro ⟨w, _, hw⟩ + refine ⟨shiftsOfList (ampShifts f x.length) (ampRuns f x.length * f x.length) w, ?_⟩ + intro s + have hxle : x.length ≤ (pair x w).length := by + rw [pair_length] + omega + have hlen : (listOfSeed s).length ≤ q.eval (pair x w).length := by + rw [length_listOfSeed] + exact le_trans (hq x.length) (polynomial_eval_mono_nat q hxle) + have hmatrix := hw (listOfSeed s) hlen + rw [mem_matrixLang_pair] at hmatrix + obtain ⟨i, hi⟩ := hmatrix (by simp) + refine ⟨i, ?_⟩ + rw [hmem] + simpa using hi + +/-- The `Σ₂` form of a bounded-error language: `L` itself. -/ +theorem eq_polyExistsLang_of_boundedError {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (haccept : tm.AcceptsWithProb L f (2 / 3)) (hreject : tm.RejectsWithProb L f (1 / 3)) + {p q : Polynomial ℕ} + (hp : ∀ n, ampShifts f n * (ampRuns f n * f n) ≤ p.eval n) + (hq : ∀ n, ampRuns f n * f n ≤ q.eval n) : + L = polyExistsLang p (polyForallLang q (matrixLang tm f true)) := + eq_polyExistsLang_polyForallLang (fun x => ampEvent tm f x) + (fun x w => mem_ampEvent tm f x w) (mem_iff_exists_covers haccept hreject) hp hq + +/-- The `Σ₂` form of a bounded-error language: its complement. -/ +theorem compl_eq_polyExistsLang_of_boundedError {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (haccept : tm.AcceptsWithProb L f (2 / 3)) (hreject : tm.RejectsWithProb L f (1 / 3)) + {p q : Polynomial ℕ} + (hp : ∀ n, ampShifts f n * (ampRuns f n * f n) ≤ p.eval n) + (hq : ∀ n, ampRuns f n * f n ≤ q.eval n) : + Lᶜ = polyExistsLang p (polyForallLang q (matrixLang tm f false)) := + eq_polyExistsLang_polyForallLang (fun x => (ampEvent tm f x)ᶜ) + (fun x w => mem_compl_ampEvent tm f x w) + (fun x => notMem_iff_exists_covers_compl haccept hreject x) hp hq + +/-! ## Polynomial bounds -/ + +/-- The polynomial bounding the amplified seed length, given a polynomial `P` +dominating the machine's time bound. -/ +noncomputable def boundPoly (P : Polynomial ℕ) : Polynomial ℕ := + (Polynomial.C 12 * P + Polynomial.C 133) * P + +@[simp] theorem boundPoly_eval (P : Polynomial ℕ) (n : ℕ) : + (boundPoly P).eval n = (12 * P.eval n + 133) * P.eval n := by + simp [boundPoly] + +/-- The amplified seed length is bounded by `boundPoly P`, and the amplified +witness length by `(boundPoly P + 1) * boundPoly P`. -/ +theorem boundPoly_bounds {f : ℕ → ℕ} {P : Polynomial ℕ} (hf : ∀ n, f n ≤ P.eval n) : + (∀ n, ampRuns f n * f n ≤ (boundPoly P).eval n) ∧ + (∀ n, ampShifts f n * (ampRuns f n * f n) ≤ + ((boundPoly P + 1) * boundPoly P).eval n) := by + have hseed : ∀ n, ampRuns f n * f n ≤ (boundPoly P).eval n := by + intro n + rw [boundPoly_eval] + have hr : ampRuns f n = 12 * f n + 133 := by simp [ampRuns, ampExp]; ring + rw [hr] + exact Nat.mul_le_mul (by have := hf n; omega) (hf n) + refine ⟨hseed, fun n => ?_⟩ + have hs : ampShifts f n = ampRuns f n * f n + 1 := rfl + rw [hs, Polynomial.eval_mul, Polynomial.eval_add, Polynomial.eval_one] + exact Nat.mul_le_mul (by have := hseed n; omega) (hseed n) + +end Lautemann + +end Complexity diff --git a/Complexitylib/Classes/PH/SipserLautemann/TimeBound.lean b/Complexitylib/Classes/PH/SipserLautemann/TimeBound.lean new file mode 100644 index 00000000..0d1e50c5 --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann/TimeBound.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.EventProb +public import Complexitylib.Classes.Randomized + +/-! +# Freezing the acceptance probability past the halting time + +A probabilistic machine whose paths all halt within `T` steps has the same +acceptance probability at every later time bound: the extra choice bits are +read by no transition, so they only refine the sample space uniformly. This +lets a machine's arbitrary time-bound function be replaced by a polynomial +that dominates it, which is what makes the Lautemann matrix predicate +computable — see +`Complexitylib.Classes.PH.SipserLautemann.Matrix`. + +## Main results + +- `card_filter_blockFst_eq` — a prefix fiber of the seed space has `2 ^ b` + points +- `NTM.acceptProb_eq_of_allPathsHaltIn` — the acceptance probability is frozen + past the halting time +- `NTM.acceptsWithProb_of_le`, `NTM.rejectsWithProb_of_le` — the bounded-error + conditions transfer to any pointwise-larger time bound +-/ + +@[expose] public section + +namespace Complexity + +/-- Every prefix fiber of the seed space has exactly `2 ^ b` points: fixing the +first `a` bits leaves the last `b` free. -/ +theorem card_filter_blockFst_eq (a b : ℕ) (seed : Fin a → Bool) : + (Finset.univ.filter fun w : Fin (a + b) → Bool => blockFst a b w = seed).card + = 2 ^ b := by + classical + have hinj : Function.Injective (fun v : Fin b → Bool => blockAppend a b seed v) := by + intro v v' hvv + have := congrArg (blockSnd a b) hvv + simpa using this + have hset : (Finset.univ.filter fun w : Fin (a + b) → Bool => blockFst a b w = seed) + = Finset.univ.image (fun v : Fin b → Bool => blockAppend a b seed v) := by + ext w + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_image] + constructor + · intro h + exact ⟨blockSnd a b w, by rw [← h, blockAppend_fst_snd]⟩ + · rintro ⟨v, rfl⟩ + simp + rw [hset, Finset.card_image_of_injective _ hinj, Finset.card_univ, card_finArrowBool] + +namespace NTM + +variable {n : ℕ} + +/-- **The acceptance probability is frozen past the halting time.** If all +paths halt within `T (|x|)` steps, running the machine for any longer bound +leaves the acceptance probability unchanged: the surplus choice bits partition +the enlarged sample space into equal fibers over the original one. -/ +theorem acceptProb_eq_of_allPathsHaltIn {tm : NTM n} {T : ℕ → ℕ} + (hN : tm.AllPathsHaltIn T) (x : List Bool) {T' : ℕ} (hle : T x.length ≤ T') : + tm.acceptProb x T' = tm.acceptProb x (T x.length) := by + classical + obtain ⟨i, rfl⟩ := Nat.exists_eq_add_of_le hle + rw [acceptProb_eq_eventProb, acceptProb_eq_eventProb] + refine eventProb_filter_of_constant_fibers (htotal := rfl) + (randomSeed := blockFst (T x.length) i) _ _ ?_ (card_filter_blockFst_eq _ _) + intro w + have hagree : ∀ j : Fin (T x.length), + w ⟨j.val, by omega⟩ = blockFst (T x.length) i w j := by + intro j + rfl + have hhalt : tm.halted (tm.trace (T x.length) (blockFst (T x.length) i w) + (tm.initCfg x)) := hN x _ + rw [tm.trace_mono (Nat.le_add_right _ i) hagree hhalt] + +/-- The completeness condition transfers to any pointwise-larger time bound. -/ +theorem acceptsWithProb_of_le {tm : NTM n} {L : Language} {T T' : ℕ → ℕ} {c : ℚ} + (hN : tm.AllPathsHaltIn T) (hle : ∀ m, T m ≤ T' m) + (h : tm.AcceptsWithProb L T c) : tm.AcceptsWithProb L T' c := by + intro x hx + rw [acceptProb_eq_of_allPathsHaltIn hN x (hle x.length)] + exact h x hx + +/-- The soundness condition transfers to any pointwise-larger time bound. -/ +theorem rejectsWithProb_of_le {tm : NTM n} {L : Language} {T T' : ℕ → ℕ} {s : ℚ} + (hN : tm.AllPathsHaltIn T) (hle : ∀ m, T m ≤ T' m) + (h : tm.RejectsWithProb L T s) : tm.RejectsWithProb L T' s := by + intro x hx + rw [acceptProb_eq_of_allPathsHaltIn hN x (hle x.length)] + exact h x hx + +end NTM + +end Complexity diff --git a/ROADMAP.md b/ROADMAP.md index 439b509b..1bb72cd7 100644 --- a/ROADMAP.md +++ b/ROADMAP.md @@ -1971,8 +1971,26 @@ randomness, interaction, and lower bounds. **Staged directions.** -- [ ] Define the polynomial hierarchy both by alternating quantifiers and oracle - levels, then prove equivalence at fixed levels. +- [~] Define the polynomial hierarchy both by alternating quantifiers and oracle + levels, then prove equivalence at fixed levels. *(The certificate-quantifier + definition is `Complexitylib.Classes.PH`: `SigmaP`, `PiP`, `PH`, quantifier + duality, and the level inclusions relative to the `pairFst ∈ FP` seam. Oracle + levels and the equivalence remain.)* +- [~] Prove the Sipser--Lautemann theorem `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. + *(`Complexitylib.Classes.PH.SipserLautemann`: proved from the single interface + `MatrixInP`. Unconditional so far: Lautemann's covering lemma in both + directions (`SipserLautemann.Covering`), the freeze of acceptance probability + past the halting time, which replaces a machine's arbitrary time bound by a + dominating polynomial (`SipserLautemann.TimeBound`), the amplified `∃∀` + characterization of `L` and of its complement (`SipserLautemann.Amplified`), + the seed/shift bitstring codecs (`SipserLautemann.Encode`), and the identity + exhibiting `L` and `Lᶜ` as polynomially bounded `∃∀` forms over the matrix + language (`SipserLautemann.Matrix`). What remains is `MatrixInP`: a + deterministic polynomial-time decider that parses the encoded triple, + recovers the per-trial step count from the input length, and runs the fixed + machine on each shifted seed. That is the same NTM-path-simulation + engineering as `NP.WitnessNTMConstruction`, and landing a shared simulation + primitive would discharge both.)* - [~] Define `#P`, `GapP`, and parsimonious reductions using exact accepting-path counts. *(`#P` = `SharpP` and `GapP` (with `GapP.neg_mem`) in `Complexitylib.Classes.SharpP` done; parsimonious reductions remain.)* From 1c3f232b3766a01661f65b722ebd4a3780577b50 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 10:40:44 -0700 Subject: [PATCH 04/24] feat(models): run one nondeterministic path from a choice tape MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `NTM.choiceTM` appends a choice tape to an NTM and reads one bit per step from it, writing it back unchanged and advancing that head, which turns the nondeterministic machine into a deterministic one whose run is the chosen path. `NTM.choiceTM_simulates` proves the exact correspondence: a `T`-step run is `tm.trace T` along the bits found on the tape, stopping early exactly when the path halts. This is the primitive a deterministic decider needs in order to evaluate "does `tm` accept `x` along choice sequence `c`" — the missing ingredient behind both `NP.WitnessNTMConstruction` and the `MatrixInP` interface of the Sipser-Lautemann development. Also adds `TM.stepCfg` and `TM.step_of_not_halted`, the non-halted step unfolding used throughout the correspondence proof. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Models.lean | 1 + .../Models/TuringMachine/ChoiceTape.lean | 177 ++++++++++++++++++ 2 files changed, 178 insertions(+) create mode 100644 Complexitylib/Models/TuringMachine/ChoiceTape.lean diff --git a/Complexitylib/Models.lean b/Complexitylib/Models.lean index 7d808aeb..997a6ac1 100644 --- a/Complexitylib/Models.lean +++ b/Complexitylib/Models.lean @@ -9,6 +9,7 @@ public import Complexitylib.Models.TuringMachine public import Complexitylib.Models.TuringMachine.Trace public import Complexitylib.Models.TuringMachine.Trace.DetPrefix public import Complexitylib.Models.TuringMachine.SingleTape +public import Complexitylib.Models.TuringMachine.ChoiceTape public import Complexitylib.Models.TuringMachine.Combinators public import Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork public import Complexitylib.Models.TuringMachine.Combinators.ForInput diff --git a/Complexitylib/Models/TuringMachine/ChoiceTape.lean b/Complexitylib/Models/TuringMachine/ChoiceTape.lean new file mode 100644 index 00000000..644de84e --- /dev/null +++ b/Complexitylib/Models/TuringMachine/ChoiceTape.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators + +/-! +# Running one nondeterministic path deterministically + +An `NTM`'s transition function has exactly the shape of a `TM`'s, plus a +`Bool`. Feeding that `Bool` from a dedicated work tape — one cell per step, +scanned left to right and written back unchanged — turns the nondeterministic +machine into a deterministic one whose run is the chosen path. + +This is the primitive that lets deterministic machines reason about +nondeterministic runs: a decider that must evaluate "does `tm` accept `x` along +choice sequence `c`" places `c` on the choice tape and runs `choiceTM tm`. + +## Main definitions + +- `NTM.choiceTM` — the deterministic machine with a choice tape appended +- `NTM.dropChoice` — forget the choice tape from a configuration +- `NTM.choiceStream` — the choice bits under and to the right of the head + +## Main results + +- `NTM.choiceTM_step` — one step of `choiceTM` is one step of the path +- `NTM.choiceTM_simulates` — a `T`-step run of `choiceTM` is `tm.trace T` + along the choice bits found on the tape +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : ℕ} + +/-- The configuration update inlined in `TM.step`. -/ +def stepCfg (tm : TM k) (c : Cfg k tm.Q) : Cfg k tm.Q := + let (q', workWrites, outWrite, inDir, workDirs, outDir) := + tm.δ c.state c.input.read (fun i => (c.work i).read) c.output.read + { state := q' + input := c.input.move inDir + work := fun i => (c.work i).writeAndMove (workWrites i) (workDirs i) + output := c.output.writeAndMove outWrite outDir } + +/-- A non-halted configuration steps to `stepCfg`. -/ +theorem step_of_not_halted (tm : TM k) {c : Cfg k tm.Q} (h : c.state ≠ tm.qhalt) : + tm.step c = some (tm.stepCfg c) := by + unfold TM.step + rw [if_neg h] + rfl + +end TM + +namespace NTM + +variable {k : ℕ} + +/-- The deterministic machine that runs one path of `tm`, reading its choice +bits from the appended last work tape: each step consults the cell under that +head, writes it back unchanged, and advances the head one cell right. -/ +def choiceTM (tm : NTM k) : TM (k + 1) where + Q := tm.Q + qstart := tm.qstart + qhalt := tm.qhalt + δ q iHead wHeads oHead := + let cHead := wHeads (Fin.last k) + let r := tm.δ (decide (cHead = Γ.one)) q iHead (fun i => wHeads i.castSucc) oHead + (r.1, Fin.snoc r.2.1 (TM.readBackWrite cHead), r.2.2.1, + r.2.2.2.1, Fin.snoc r.2.2.2.2.1 Dir3.right, r.2.2.2.2.2) + δ_right_of_start := by + intro q iHead wHeads oHead + have h := tm.δ_right_of_start (decide (wHeads (Fin.last k) = Γ.one)) q iHead + (fun i => wHeads i.castSucc) oHead + dsimp only at h ⊢ + refine ⟨h.1, ?_, h.2.2⟩ + intro i + refine Fin.lastCases ?_ ?_ i + · intro _ + simp + · intro j hj + rw [Fin.snoc_castSucc] + exact h.2.1 j (by simpa using hj) + +/-- One step of an NTM along a fixed choice bit: the configuration update +inlined in `NTM.trace`. -/ +def stepCfg (tm : NTM k) (b : Bool) (c : Cfg k tm.Q) : Cfg k tm.Q := + let (q', workWrites, outWrite, inDir, workDirs, outDir) := + tm.δ b c.state c.input.read (fun i => (c.work i).read) c.output.read + { state := q' + input := c.input.move inDir + work := fun i => (c.work i).writeAndMove (workWrites i) (workDirs i) + output := c.output.writeAndMove outWrite outDir } + +/-- Unfolding one non-halted step of `trace`. -/ +theorem trace_succ_of_not_halted (tm : NTM k) (T : ℕ) (choices : Fin (T + 1) → Bool) + {c : Cfg k tm.Q} (h : c.state ≠ tm.qhalt) : + tm.trace (T + 1) choices c = + tm.trace T (fun i => choices ⟨i.val + 1, by omega⟩) + (stepCfg tm (choices ⟨0, Nat.zero_lt_succ T⟩) c) := by + rw [NTM.trace] + simp [h, stepCfg] + +/-- Forget the choice tape from a configuration. -/ +def dropChoice {Q : Type} (c : Cfg (k + 1) Q) : Cfg k Q where + state := c.state + input := c.input + work := fun i => c.work i.castSucc + output := c.output + +/-- The choice bits under and to the right of the choice head. -/ +def choiceStream {Q : Type} (c : Cfg (k + 1) Q) (j : ℕ) : Bool := + decide ((c.work (Fin.last k)).cells ((c.work (Fin.last k)).head + j) = Γ.one) + +/-- **One step of `choiceTM` is one step of the chosen path.** The choice tape +is written back unchanged and its head advances one cell. -/ +theorem choiceTM_step (tm : NTM k) (c : Cfg (k + 1) tm.Q) (hhalt : c.state ≠ tm.qhalt) + (hread : (c.work (Fin.last k)).read ≠ Γ.start) : + ∃ c₁, (choiceTM tm).step c = some c₁ ∧ + dropChoice c₁ = stepCfg tm (choiceStream c 0) (dropChoice c) ∧ + c₁.work (Fin.last k) = (c.work (Fin.last k)).move Dir3.right := by + refine ⟨(choiceTM tm).stepCfg c, TM.step_of_not_halted _ hhalt, ?_, ?_⟩ + · refine Cfg.ext rfl rfl ?_ rfl + funext i + simp [TM.stepCfg, choiceTM, stepCfg, dropChoice, choiceStream, Tape.read] + · simp only [TM.stepCfg, choiceTM, Fin.snoc_last] + exact TM.writeAndMove_readBack _ hread Dir3.right + +/-- **A `T`-step run of `choiceTM` is the `T`-step trace of `tm` along the +choice bits on the tape.** The run stops early exactly when the path halts; +the choice tape is left untouched apart from its head, which advances one cell +per step. -/ +theorem choiceTM_simulates (tm : NTM k) (T : ℕ) (c : Cfg (k + 1) tm.Q) + (hinv : (c.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c.work (Fin.last k)).head) : + ∃ (c' : Cfg (k + 1) tm.Q) (t : ℕ), t ≤ T ∧ + (choiceTM tm).reachesIn t c c' ∧ + (t < T → (choiceTM tm).halted c') ∧ + dropChoice c' = tm.trace T (fun j => choiceStream c j.val) (dropChoice c) := by + induction T generalizing c with + | zero => exact ⟨c, 0, le_rfl, TM.reachesIn.zero, by omega, rfl⟩ + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + · refine ⟨c, 0, Nat.zero_le _, TM.reachesIn.zero, fun _ => hhalt, ?_⟩ + rw [NTM.trace] + simp [dropChoice, hhalt] + · have hread : (c.work (Fin.last k)).read ≠ Γ.start := hinv.read_ne_start hhead + obtain ⟨c₁, hstep, hdrop, hchoice⟩ := choiceTM_step tm c hhalt hread + have hinv₁ : (c₁.work (Fin.last k)).StartInvariant := by + rw [hchoice] + exact hinv + have hhead₁ : 1 ≤ (c₁.work (Fin.last k)).head := by + rw [hchoice] + show 1 ≤ (c.work (Fin.last k)).head + 1 + omega + obtain ⟨c', t, hle, hreach, hstop, heq⟩ := ih c₁ hinv₁ hhead₁ + refine ⟨c', t + 1, by omega, TM.reachesIn.step hstep hreach, fun _ => hstop (by omega), ?_⟩ + rw [trace_succ_of_not_halted tm T _ (by simpa [dropChoice] using hhalt), ← hdrop] + rw [heq] + congr 1 + funext j + have harg : ((c.work (Fin.last k)).move Dir3.right).head + j.val + = (c.work (Fin.last k)).head + (j.val + 1) := by + show (c.work (Fin.last k)).head + 1 + j.val = _ + omega + show choiceStream c₁ j.val = choiceStream c (j.val + 1) + simp only [choiceStream, hchoice, harg] + rfl + +end NTM + +end Complexity From 1a677f7b343932e25866b30e295d7705417bd0d3 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 10:46:18 -0700 Subject: [PATCH 05/24] feat(P): decide a language by a polynomial-time verdict function MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `mem_P_of_decisionFn` and `mem_P_of_decisionFn_bool` put a language in `P` given a verdict function in `FP`, by reading the verdict through `Language.containsOne` and closing under polynomial-time preimages. Adds the `mem_containsZero`/`mem_containsOne` membership lemmas this needs. This lets a development establish membership in `P` by exhibiting a function — in particular by building one in Cobham's algebra via `CobhamFP_eq_FP` — instead of constructing a decider machine by hand. Uses it to sharpen the Sipser-Lautemann interface: `MatrixVerdictInFP` states the remaining obligation as a function in `FP`, `matrixInP_of_verdictInFP` converts it to `MatrixInP`, and `sipserLautemann_of_verdictInFP` gives the theorem from it. `Lautemann.matrixVerdict` is the verdict function, with `mem_matrixLang_iff_verdict` tying it to the matrix language. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/P/DecisionFn.lean | 52 ++++++++++++++++++ Complexitylib/Classes/PH/SipserLautemann.lean | 46 +++++++++++++--- .../Classes/PH/SipserLautemann/Matrix.lean | 54 +++++++++++++++++++ Complexitylib/Languages/Contains.lean | 8 +++ 4 files changed, 152 insertions(+), 8 deletions(-) create mode 100644 Complexitylib/Classes/P/DecisionFn.lean diff --git a/Complexitylib/Classes/P/DecisionFn.lean b/Complexitylib/Classes/P/DecisionFn.lean new file mode 100644 index 00000000..8c0a4632 --- /dev/null +++ b/Complexitylib/Classes/P/DecisionFn.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Preimage +public import Complexitylib.Languages.Contains + +/-! +# From a polynomial-time decision function to membership in `P` + +A language whose verdict is computed by a polynomial-time *function* is in +`P`. This is the bridge that lets a development establish membership in `P` +by exhibiting a function — in particular by building one in Cobham's algebra, +where `Complexitylib.Classes.P.Cobham` supplies `CobhamFP_eq_FP` — instead of +constructing a decider machine by hand. + +The proof reads the verdict off the output through the polynomial-time +language `Language.containsOne`: a verdict string is accepted exactly when it +contains a `1`, and `P` is closed under polynomial-time preimages. + +## Main results + +- `mem_P_of_decisionFn` — a verdict function in `FP` puts its language in `P` +- `mem_P_of_decisionFn_bool` — the same with a `Bool`-valued verdict +-/ + +@[expose] public section + +namespace Complexity + +/-- **A polynomial-time verdict function decides a polynomial-time language.** +If `f ∈ FP` and `x ∈ L` exactly when `f x` contains a `1`-bit, then `L ∈ P`. -/ +theorem mem_P_of_decisionFn {f : List Bool → List Bool} {L : Language} + (hf : f ∈ FP) (hL : ∀ x, x ∈ L ↔ ∃ b ∈ f x, b = true) : L ∈ P := by + have hpre : L = f ⁻¹' Language.containsOne := by + ext x + rw [Set.mem_preimage, Language.mem_containsOne] + exact hL x + rw [hpre] + exact mem_P_preimage hf containsOne_mem_P + +/-- The `Bool`-valued form: a polynomial-time function that emits the verdict +as a one-bit string decides its language. -/ +theorem mem_P_of_decisionFn_bool {g : List Bool → Bool} {L : Language} + (hf : (fun x => [g x]) ∈ FP) (hL : ∀ x, x ∈ L ↔ g x = true) : L ∈ P := by + refine mem_P_of_decisionFn hf (fun x => ?_) + rw [hL x] + simp + +end Complexity diff --git a/Complexitylib/Classes/PH/SipserLautemann.lean b/Complexitylib/Classes/PH/SipserLautemann.lean index befa92a5..6baca838 100644 --- a/Complexitylib/Classes/PH/SipserLautemann.lean +++ b/Complexitylib/Classes/PH/SipserLautemann.lean @@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Bolton Bailey -/ module +public import Complexitylib.Classes.P.DecisionFn public import Complexitylib.Classes.PH public import Complexitylib.Classes.PH.SipserLautemann.Matrix @@ -35,23 +36,29 @@ Everything except one Turing-machine construction is proved here and in the it. The one interface left open is `MatrixInP`: the matrix language is decidable -in deterministic polynomial time. That is the standard "simulate a fixed -machine on given random bits" construction — parse the triple, recover the +in deterministic polynomial time. It is deliberately isolated rather than +assumed silently, and it is sharpened here to a statement about a *function*, +`MatrixVerdictInFP`, so that discharging it needs no machine construction — +`Complexitylib.Classes.P.Cobham`'s `CobhamFP_eq_FP` turns it into a +programming task in Cobham's algebra, and `mem_P_of_decisionFn_bool` converts +the result back. The verdict to compute is: parse the triple, recover the per-trial step count from the input length, run the fixed machine on each -shifted seed, and take the majority vote — of the same kind as -`Complexitylib.Classes.NP.Witness`'s `WitnessNTMConstruction`, and it is -deliberately isolated rather than assumed silently. Note that the matrix -language is taken at a *polynomial* time bound, which is what makes the step -count recoverable by a decider; `TimeBound` supplies the normalization. +shifted seed, and take the majority vote. Running the machine along given +choice bits is exactly `NTM.choiceTM_simulates`. Note that the matrix is taken +at a *polynomial* time bound, which is what makes the step count recoverable +by a decider; `TimeBound` supplies the normalization. ## Main definitions - `SipserLautemann` — the statement `BPP ⊆ SigmaP 2 ∩ PiP 2` - `MatrixInP` — the polynomial-time decidability interface for the matrix +- `MatrixVerdictInFP` — the same interface as a statement about a function ## Main results -- `sipserLautemann_of_matrixInP` — **the theorem**, given the interface +- `sipserLautemann_of_matrixInP`, `sipserLautemann_of_verdictInFP` — **the + theorem**, given either form of the interface +- `matrixInP_of_verdictInFP` — the function form implies the language form - `mem_SigmaP_two_of_matrixInP`, `mem_PiP_two_of_matrixInP` — the two halves - `sipserLautemann_iff` — the statement splits into its `Σ₂` and `Π₂` halves - `sipserLautemann_of_subset_SigmaP` — the `Σ₂` half suffices, given that @@ -87,6 +94,24 @@ def MatrixInP : Prop := ∀ (k : ℕ) (tm : NTM k) (pt : Polynomial ℕ) (b : Bool), Lautemann.matrixLang tm pt.eval b ∈ P +/-- **The matrix interface as a function statement.** For every machine and +every polynomial time bound, the matrix verdict is computable in deterministic +polynomial time. + +This is the form to discharge: by `CobhamFP_eq_FP` it suffices to build the +verdict inside Cobham's algebra, with `NTM.choiceTM_simulates` supplying the +semantics of running the machine along given choice bits. -/ +def MatrixVerdictInFP : Prop := + ∀ (k : ℕ) (tm : NTM k) (pt : Polynomial ℕ) (b : Bool), + (fun z => [Lautemann.matrixVerdict tm pt.eval b z]) ∈ FP + +/-- A polynomial-time verdict function gives the polynomial-time matrix +language. -/ +theorem matrixInP_of_verdictInFP (h : MatrixVerdictInFP) : MatrixInP := + fun k tm pt b => + mem_P_of_decisionFn_bool (h k tm pt b) + (fun z => Lautemann.mem_matrixLang_iff_verdict tm pt.eval b z) + /-- Every `BPP` language is in `Σ₂ᵖ`, given the matrix interface. -/ theorem mem_SigmaP_two_of_matrixInP (hmatrix : MatrixInP) {L : Language} (hL : L ∈ BPP) : L ∈ SigmaP 2 := by @@ -127,6 +152,11 @@ interface: `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. -/ theorem sipserLautemann_of_matrixInP (hmatrix : MatrixInP) : SipserLautemann := fun _ hL => ⟨mem_SigmaP_two_of_matrixInP hmatrix hL, mem_PiP_two_of_matrixInP hmatrix hL⟩ +/-- **The Sipser–Lautemann theorem**, given the matrix interface in its +function form. -/ +theorem sipserLautemann_of_verdictInFP (h : MatrixVerdictInFP) : SipserLautemann := + sipserLautemann_of_matrixInP (matrixInP_of_verdictInFP h) + /-- The statement splits into its two halves: containment in `Σ₂ᵖ` and containment in `Π₂ᵖ`. -/ theorem sipserLautemann_iff : SipserLautemann ↔ BPP ⊆ SigmaP 2 ∧ BPP ⊆ PiP 2 := diff --git a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean index b4037293..4e2af6b6 100644 --- a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean +++ b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean @@ -85,6 +85,60 @@ theorem mem_matrixLang_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : L subst hr exact h +/-- The matrix as a `Bool`-valued verdict function. The definition mirrors +`matrixLang` through the pair decoder, so it is total and its equivalence with +the language is immediate; it is stated this way so that the remaining +polynomial-time obligation is about a *function*, which +`Complexitylib.Classes.P.Cobham` can discharge inside Cobham's algebra without +constructing a machine. -/ +noncomputable def matrixVerdict (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (z : List Bool) : Bool := + match unpair? z with + | none => true + | some (y, r) => + match unpair? y with + | none => true + | some (x, w) => + if r.length = ampRuns f x.length * f x.length then + decide (∃ i : Fin (ampShifts f x.length), + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) + (shift (seedOfList (ampRuns f x.length * f x.length) r) + (shiftsOfList (ampShifts f x.length) + (ampRuns f x.length * f x.length) w i)) = b) + else true + +/-- The verdict function on an encoded triple. -/ +@[simp] theorem matrixVerdict_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : + matrixVerdict tm f b (pair (pair x w) r) = + (if r.length = ampRuns f x.length * f x.length then + decide (∃ i : Fin (ampShifts f x.length), + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) + (shift (seedOfList (ampRuns f x.length * f x.length) r) + (shiftsOfList (ampShifts f x.length) + (ampRuns f x.length * f x.length) w i)) = b) + else true) := by + simp [matrixVerdict] + +/-- The verdict function decides the matrix language. -/ +theorem mem_matrixLang_iff_verdict (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (z : List Bool) : + z ∈ matrixLang tm f b ↔ matrixVerdict tm f b z = true := by + constructor + · intro h + rcases hz : unpair? z with _ | ⟨y, r⟩ + · simp [matrixVerdict, hz] + · rcases hy : unpair? y with _ | ⟨x, w⟩ + · simp [matrixVerdict, hz, hy] + · have hzeq : z = pair (pair x w) r := by + rw [unpair?_eq_some_iff] at hz hy + rw [hz, hy] + subst hzeq + by_cases hlen : r.length = ampRuns f x.length * f x.length + · simpa [hlen] using h x w r rfl hlen + · simp [hlen] + · intro h x w r hz hlen + subst hz + rw [matrixVerdict_pair] at h + simpa [hlen] using h + /-! ## The `Σ₂` form -/ /-- **The `Σ₂` form of a covering characterization.** Given a family of events diff --git a/Complexitylib/Languages/Contains.lean b/Complexitylib/Languages/Contains.lean index 18dc6191..2e87c9ef 100644 --- a/Complexitylib/Languages/Contains.lean +++ b/Complexitylib/Languages/Contains.lean @@ -53,6 +53,14 @@ def containsZero : Language := {x | ∃ b ∈ x, b = false} /-- Strings containing at least one `1`-bit. -/ def containsOne : Language := {x | ∃ b ∈ x, b = true} +/-- Membership in `containsZero` unfolds to the existence of a `0`-bit. -/ +@[simp] theorem mem_containsZero {x : List Bool} : + x ∈ containsZero ↔ ∃ b ∈ x, b = false := Iff.rfl + +/-- Membership in `containsOne` unfolds to the existence of a `1`-bit. -/ +@[simp] theorem mem_containsOne {x : List Bool} : + x ∈ containsOne ↔ ∃ b ∈ x, b = true := Iff.rfl + end Language -- ════════════════════════════════════════════════════════════════════════ From dd01f042b2789332a1d93c3ece57e05ea5d1305f Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 10:48:02 -0700 Subject: [PATCH 06/24] docs(roadmap): record the sharpened Sipser-Lautemann obligation The remaining obligation is now `MatrixVerdictInFP`, a function-level statement dischargeable inside Cobham's algebra, and the path semantics it needs are available from `NTM.choiceTM_simulates`. Records the concrete remaining piece: an initial-configuration encoder that places the choice string on the choice tape. Co-Authored-By: Claude Opus 5 (1M context) --- ROADMAP.md | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/ROADMAP.md b/ROADMAP.md index 1bb72cd7..4dd1fe7b 100644 --- a/ROADMAP.md +++ b/ROADMAP.md @@ -1985,12 +1985,19 @@ randomness, interaction, and lower bounds. characterization of `L` and of its complement (`SipserLautemann.Amplified`), the seed/shift bitstring codecs (`SipserLautemann.Encode`), and the identity exhibiting `L` and `Lᶜ` as polynomially bounded `∃∀` forms over the matrix - language (`SipserLautemann.Matrix`). What remains is `MatrixInP`: a - deterministic polynomial-time decider that parses the encoded triple, - recovers the per-trial step count from the input length, and runs the fixed - machine on each shifted seed. That is the same NTM-path-simulation - engineering as `NP.WitnessNTMConstruction`, and landing a shared simulation - primitive would discharge both.)* + language (`SipserLautemann.Matrix`). What remains is `MatrixVerdictInFP`: + the matrix verdict function — parse the encoded triple, recover the + per-trial step count from the input length, run the fixed machine on each + shifted seed, take the majority vote — is in `FP`. By `CobhamFP_eq_FP` that + is a programming task in Cobham's algebra rather than a machine + construction, and `mem_P_of_decisionFn_bool` converts the result back to + `P`. The path semantics it needs are already available: + `NTM.choiceTM_simulates` runs one nondeterministic path deterministically + from a choice tape, so `Cobham.stepFn (NTM.choiceTM tm)` is the step + function to iterate; the missing piece is an initial-configuration encoder + that places the choice string on that tape with its head at cell 1, in the + style of `Cobham.initFn_mem`. The same primitive discharges + `NP.WitnessNTMConstruction`.)* - [~] Define `#P`, `GapP`, and parsimonious reductions using exact accepting-path counts. *(`#P` = `SharpP` and `GapP` (with `GapP.neg_mem`) in `Complexitylib.Classes.SharpP` done; parsimonious reductions remain.)* From 1af04f8995334b1471a62db2e3e273160fc2093a Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 11:01:03 -0700 Subject: [PATCH 07/24] feat(cobham): encode and iterate a nondeterministic path in the algebra MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Simulating one path of an NTM inside Cobham's algebra needs a starting configuration with the choice string already on the choice tape. This adds that encoder and the correspondence lemmas: - `Cobham.choiceCfg` / `Cobham.choiceTape` — the starting configuration of `NTM.choiceTM tm`, with the choice head parked on the first bit; - `Cobham.initChoiceFn` with `initChoiceFn_mem` and `initChoiceFn_eq` — the encoder is in the algebra and computes `cfgCode` of that configuration; - `Cobham.iterate_stepFn_choice` — iterating the algebra's step function tracks the deterministic run, with the start-marker and head-position invariants proved for choice runs; - `Cobham.dropChoice_runCfg_choiceCfg` — that run is exactly `tm.trace` along the bits of the choice string, via `NTM.choiceTM_simulates`. Next: iterate under a clock inside the algebra and read the verdict off the final configuration, giving the path verdict in `FP`. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/P/Cobham/Internal.lean | 1 + .../Classes/P/Cobham/Internal/ChoiceSim.lean | 363 ++++++++++++++++++ 2 files changed, 364 insertions(+) create mode 100644 Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean diff --git a/Complexitylib/Classes/P/Cobham/Internal.lean b/Complexitylib/Classes/P/Cobham/Internal.lean index 8ad44aad..27036171 100644 --- a/Complexitylib/Classes/P/Cobham/Internal.lean +++ b/Complexitylib/Classes/P/Cobham/Internal.lean @@ -16,6 +16,7 @@ public import Complexitylib.Classes.P.Cobham.Internal.Algebra public import Complexitylib.Classes.P.Cobham.Internal.Encoding public import Complexitylib.Classes.P.Cobham.Internal.StepAlgebra public import Complexitylib.Classes.P.Cobham.Internal.Simulate +public import Complexitylib.Classes.P.Cobham.Internal.ChoiceSim public import Complexitylib.Classes.P.Cobham.Internal.IterateLayout public import Complexitylib.Classes.P.Cobham.Internal.Iterate public import Complexitylib.Classes.P.Cobham.Internal.TakeLen diff --git a/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean b/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean new file mode 100644 index 00000000..80bff8fd --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean @@ -0,0 +1,363 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal.Simulate +public import Complexitylib.Models.TuringMachine.ChoiceTape + +/-! +# Encoding the start of a nondeterministic path + +`NTM.choiceTM` runs one path of a nondeterministic machine deterministically, +reading its choice bits from the last work tape. To simulate such a run inside +Cobham's algebra, the starting configuration must be encoded with the choice +string already on that tape and its head parked on the first bit. + +This file supplies that encoder — `Cobham.initChoiceFn`, the counterpart of +`Cobham.initFn` — together with its algebra membership and the identification +with `Cobham.cfgCode` of the intended configuration. + +## Main definitions + +- `Cobham.choiceTape` — the choice string on a tape, head at cell 1 +- `Cobham.choiceCfg` — the starting configuration of `NTM.choiceTM` +- `Cobham.initChoiceFn` — its encoding, as a function of the two strings + +## Main results + +- `Cobham.initChoiceFn_mem` — the encoder is in the algebra +- `Cobham.initChoiceFn_eq` — the encoder computes `cfgCode` of `choiceCfg` +- `Cobham.dropChoice_choiceCfg` — forgetting the choice tape gives the + nondeterministic machine's own initial configuration +-/ + +@[expose] public section + +namespace Complexity + +namespace Cobham + +variable {k : ℕ} + +/-- The choice string on a tape, with the head parked on the first bit. -/ +def choiceTape (c : List Bool) : Tape := ⟨1, (Tape.init (c.map Γ.ofBool)).cells⟩ + +@[simp] theorem choiceTape_head (c : List Bool) : (choiceTape c).head = 1 := rfl + +@[simp] theorem choiceTape_cells (c : List Bool) : + (choiceTape c).cells = (Tape.init (c.map Γ.ofBool)).cells := rfl + +/-- The starting configuration of `NTM.choiceTM tm`: the input on the input +tape, the choice string on the appended choice tape. -/ +noncomputable def choiceCfg (tm : NTM k) (x c : List Bool) : Cfg (k + 1) tm.Q where + state := tm.qstart + input := Tape.init (x.map Γ.ofBool) + work := fun i => if i = Fin.last k then choiceTape c else Tape.init [] + output := Tape.init [] + +/-- Forgetting the choice tape gives the nondeterministic machine's own +initial configuration. -/ +@[simp] theorem dropChoice_choiceCfg (tm : NTM k) (x c : List Bool) : + NTM.dropChoice (choiceCfg tm x c) = tm.initCfg x := by + refine Cfg.ext rfl rfl ?_ rfl + funext i + rw [NTM.dropChoice, choiceCfg] + simp [(Fin.castSucc_lt_last i).ne] + +/-- The encoded starting configuration of a nondeterministic path. Everything +but the input tape's and the choice tape's right half-blocks is a constant of +the machine. -/ +noncomputable def initChoiceFn (tm : NTM k) (R x c : List Bool) : List Bool := + padTo R (stateCode tm.qstart) ++ + (padTo R [] ++ (padTo R (symCode Γ.start ++ encodeBits x) ++ + ((List.replicate (k + 1) (padTo R [] ++ padTo R (symCode Γ.start))).flatten ++ + (padTo R (symCode Γ.start) ++ padTo R (encodeBits c))))) + +/-- **The encoder is in the algebra.** -/ +theorem initChoiceFn_mem {n : ℕ} (tm : NTM k) + {gR gx gc : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hx : Cobham gx) + (hc : Cobham gc) : + Cobham fun v : Fin n → List Bool => initChoiceFn tm (gR v) (gx v) (gc v) := + (appendFn (padFn hR (Cobham.const _)) + (appendFn (padFn hR Cobham.empty) + (appendFn (padFn hR (appendFn (Cobham.const _) (encodeBitsFn hx))) + (appendFn + (repeatFn (appendFn (padFn hR Cobham.empty) + (padFn hR (Cobham.const _))) (k + 1)) + (appendFn (padFn hR (Cobham.const _)) + (padFn hR (encodeBitsFn hc))))))).of_eq fun _ => rfl + +private theorem flatten_tapesBlocks' (W : ℕ) : ∀ ts : List Tape, + (tapesBlocks W ts).flatten + = (ts.map fun t => padTo (blockRuler W) (leftCode t) + ++ padTo (blockRuler W) (rightCode t W)).flatten := by + intro ts + induction ts with + | nil => rfl + | cons t ts ih => + rw [tapesBlocks, List.flatMap_cons, List.flatten_append, ← tapesBlocks, ih, + List.map_cons, List.flatten_cons, tapeBlocks] + simp + +private theorem cellsCode_of_bits' (x : List Bool) : + ∀ (t : Tape) (i : ℕ), (∀ j, ∀ _ : j < x.length, t.cells (i + j) = Γ.ofBool x[j]) → + cellsCode t i x.length = encodeBits x := by + induction x with + | nil => intro t i _; rfl + | cons b x ih => + intro t i hcells + rw [List.length_cons, cellsCode_succ_left, encodeBits_cons, + show t.cells i = Γ.ofBool b from by simpa using hcells 0 (by simp)] + congr 1 + exact ih t (i + 1) fun j hj => by + have := hcells (j + 1) (by rw [List.length_cons]; omega) + rw [show i + 1 + j = i + (j + 1) from by omega] + simpa using this + +private theorem cellsCode_of_blank' (t : Tape) (i w : ℕ) + (h : ∀ j < w, t.cells (i + j) = Γ.blank) : + cellsCode t i w = List.replicate (2 * w) false := by + induction w generalizing i with + | zero => rfl + | succ w ih => + rw [cellsCode_succ_left, show t.cells i = Γ.blank from by simpa using h 0 (by omega), + ih (i + 1) fun j hj => by + rw [show i + 1 + j = i + (j + 1) from by omega]; exact h (j + 1) (by omega), + show 2 * (w + 1) = 2 + 2 * w from by omega, List.replicate_add] + rfl + +/-- The right half-block of a tape carrying `y` from cell `1`, head at cell 1. -/ +private theorem padTo_rightCode_choiceTape (W : ℕ) (c : List Bool) (hc : c.length ≤ W) : + padTo (blockRuler W) (rightCode (choiceTape c) W) + = padTo (blockRuler W) (encodeBits c) := by + have h1 : cellsCode (choiceTape c) 1 c.length = encodeBits c := + cellsCode_of_bits' c _ 1 fun j hj => by + rw [choiceTape_cells, show 1 + j = j + 1 from by omega, Tape.init_cells_succ] + have hjm : j < (c.map Γ.ofBool).length := by simpa using hj + rw [List.getElem?_eq_getElem hjm] + simp + have h2 : cellsCode (choiceTape c) (1 + c.length) (W - c.length) + = List.replicate (2 * (W - c.length)) false := + cellsCode_of_blank' _ _ _ fun j _ => by + rw [choiceTape_cells, show 1 + c.length + j = (c.length + j) + 1 from by omega, + Tape.init_cells_succ, List.getElem?_eq_none (by simp)] + rfl + have hcells : cellsCode (choiceTape c) 1 W + = encodeBits c ++ List.replicate (2 * (W - c.length)) false := by + rw [show W = c.length + (W - c.length) from by omega, + cellsCode_add _ 1 c.length _] + rw [h1] + congr 1 + rw [show c.length + (W - c.length) - c.length = W - c.length from by omega] + exact h2 + rw [rightCode, choiceTape_head, show W + 1 - 1 = W from by omega, hcells, + padTo_append_replicate] + +/-- **The encoder computes the encoding of the starting configuration.** -/ +theorem initChoiceFn_eq (tm : NTM k) (W : ℕ) (x c : List Bool) + (hx : x.length ≤ W) (hc : c.length ≤ W) : + initChoiceFn tm (blockRuler W) x c = cfgCode W (choiceCfg tm x c) := by + set R := blockRuler W with hR + have hin : padTo R (rightCode (Tape.init (x.map Γ.ofBool)) W) + = padTo R (symCode Γ.start ++ encodeBits x) := by + have h0 : cellsCode (Tape.init (x.map Γ.ofBool)) 0 1 = symCode Γ.start := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil, Tape.init_cells_zero] + have h1 : cellsCode (Tape.init (x.map Γ.ofBool)) 1 x.length = encodeBits x := + cellsCode_of_bits' x _ 1 fun j hj => by + rw [show 1 + j = j + 1 from by omega, Tape.init_cells_succ] + have hjm : j < (x.map Γ.ofBool).length := by simpa using hj + rw [List.getElem?_eq_getElem hjm] + simp + have h2 : cellsCode (Tape.init (x.map Γ.ofBool)) (1 + x.length) (W - x.length) + = List.replicate (2 * (W - x.length)) false := + cellsCode_of_blank' _ _ _ fun j _ => by + rw [show 1 + x.length + j = (x.length + j) + 1 from by omega, + Tape.init_cells_succ, List.getElem?_eq_none (by simp)] + rfl + have hcells : cellsCode (Tape.init (x.map Γ.ofBool)) 0 (W + 1) + = symCode Γ.start ++ (encodeBits x + ++ List.replicate (2 * (W - x.length)) false) := by + rw [show W + 1 = 1 + (x.length + (W - x.length)) from by omega, + cellsCode_add _ 0 1 _, cellsCode_add _ (0 + 1) x.length _] + simp only [Nat.zero_add] + rw [h0, h1, h2] + rw [rightCode, Tape.init_head, Nat.sub_zero, hcells, ← List.append_assoc, + padTo_append_replicate] + have hblank : padTo R (rightCode (Tape.init []) W) = padTo R (symCode Γ.start) := by + have h0 : cellsCode (Tape.init ([] : List Γ)) 0 1 = symCode Γ.start := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil, Tape.init_cells_zero] + have h2 : cellsCode (Tape.init ([] : List Γ)) 1 W + = List.replicate (2 * W) false := + cellsCode_of_blank' _ _ _ fun j _ => by + rw [show 1 + j = j + 1 from by omega, Tape.init_nil_cells_succ] + have hcells : cellsCode (Tape.init ([] : List Γ)) 0 (W + 1) + = symCode Γ.start ++ List.replicate (2 * W) false := by + rw [show W + 1 = 1 + W from by omega, cellsCode_add _ 0 1 W] + simp only [Nat.zero_add] + rw [h0, h2] + rw [rightCode, Tape.init_head, Nat.sub_zero, hcells, padTo_append_replicate] + have hleft : ∀ contents : List Γ, leftCode (Tape.init contents) = [] := fun _ => rfl + have hcleft : leftCode (choiceTape c) = symCode Γ.start := by + rw [leftCode, choiceTape_head, leftCodeFrom_succ, leftCodeFrom_zero, + List.append_nil, choiceTape_cells, Tape.init_cells_zero] + have hct : cfgTapes (choiceCfg tm x c) + = Tape.init (x.map Γ.ofBool) + :: (List.replicate (k + 1) (Tape.init []) ++ [choiceTape c]) := by + rw [cfgTapes] + congr 1 + show (Tape.init [] : Tape) :: List.ofFn (fun i : Fin (k + 1) => + if i = Fin.last k then choiceTape c else (Tape.init [] : Tape)) + = List.replicate (k + 1) (Tape.init []) ++ [choiceTape c] + rw [List.ofFn_succ'] + have hcast : (List.ofFn fun i : Fin k => + (if i.castSucc = Fin.last k then choiceTape c else (Tape.init [] : Tape))) + = List.replicate k (Tape.init []) := by + rw [show (fun i : Fin k => + (if i.castSucc = Fin.last k then choiceTape c else (Tape.init [] : Tape))) + = fun _ : Fin k => (Tape.init [] : Tape) from by + funext i + rw [if_neg (Fin.castSucc_lt_last i).ne]] + rw [List.ofFn_const] + rw [hcast, if_pos rfl, List.replicate_succ] + simp + rw [cfgCode, cfgBlocks_eq, List.flatten_cons, flatten_tapesBlocks', hct] + simp only [List.map_cons, List.map_nil, List.map_append, List.map_replicate, + List.flatten_cons, List.flatten_nil, List.flatten_append, List.append_nil, + hleft, hcleft] + rw [hin, hblank, padTo_rightCode_choiceTape W c hc] + show _ = padTo R (stateCode tm.qstart) ++ _ + rw [initChoiceFn] + simp only [← hR, List.append_assoc] + +/-! ## Iterating the encoded step from a choice configuration -/ + +/-- Every tape of a run from a choice configuration keeps its left-end +marker. -/ +theorem runCfg_choiceCfg_startInvariant (tm : NTM k) (x c : List Bool) (n : ℕ) : + (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n).input.StartInvariant ∧ + (∀ i, ((TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n).work i).StartInvariant) ∧ + (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n).output.StartInvariant := by + induction n with + | zero => + refine ⟨Tape.StartInvariant.init_ofBool x, fun i => ?_, Tape.StartInvariant.init_nil⟩ + show (if i = Fin.last k then choiceTape c else Tape.init []).StartInvariant + split + · exact Tape.StartInvariant.init_ofBool c + · exact Tape.StartInvariant.init_nil + | succ n ih => + rw [TM.runCfg_succ] + cases hs : (NTM.choiceTM tm).step (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n) with + | none => rw [Option.getD_none]; exact ih + | some c' => + rw [Option.getD_some] + exact TM.step_startInvariant _ hs ih.1 ih.2.1 ih.2.2 + +/-- After `n` steps of a run from a choice configuration every head is within +`n + 1` cells of the start: the choice head begins one cell in. -/ +theorem runCfg_choiceCfg_head_le (tm : NTM k) (x c : List Bool) (n : ℕ) : + (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n).input.head ≤ n + 1 ∧ + (∀ i, ((TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n).work i).head ≤ n + 1) ∧ + (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n).output.head ≤ n + 1 := by + induction n with + | zero => + refine ⟨by simp [choiceCfg], fun i => ?_, by simp [choiceCfg]⟩ + show (if i = Fin.last k then choiceTape c else Tape.init []).head ≤ 0 + 1 + split <;> simp + | succ n ih => + rw [TM.runCfg_succ] + cases hs : (NTM.choiceTM tm).step (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n) with + | none => + rw [Option.getD_none] + exact ⟨by omega, fun i => by have := ih.2.1 i; omega, by omega⟩ + | some c' => + rw [Option.getD_some] + obtain ⟨h1, h2, h3⟩ := TM.step_head_le _ hs + exact ⟨by omega, fun i => by have := h2 i; have := ih.2.1 i; omega, by omega⟩ + +/-- The invariants of a choice run, in the form the encoding lemmas want. -/ +theorem cfgTapes_runCfg_choiceCfg_inv (tm : NTM k) (x c : List Bool) (n W : ℕ) + (hn : n + 1 ≤ W) : + (∀ t ∈ cfgTapes (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n), t.StartInvariant) ∧ + (∀ t ∈ cfgTapes (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n), t.head ≤ W) := by + obtain ⟨i1, w1, o1⟩ := runCfg_choiceCfg_startInvariant tm x c n + obtain ⟨i2, w2, o2⟩ := runCfg_choiceCfg_head_le tm x c n + constructor <;> intro t ht <;> + · rw [cfgTapes, List.mem_cons, List.mem_cons, List.mem_ofFn] at ht + rcases ht with rfl | rfl | ⟨i, rfl⟩ + · first | exact i1 | omega + · first | exact o1 | omega + · first | exact w1 i | (have := w2 i; omega) + +/-- **The encoded iteration tracks a choice run.** -/ +theorem iterate_stepFn_choice (tm : NTM k) (W : ℕ) (x c : List Bool) + (hq : Fintype.card tm.Q ≤ blockWidth W) : + ∀ n : ℕ, n + 1 ≤ W → + (stepFn (NTM.choiceTM tm) (blockRuler W))^[n] (cfgCode W (choiceCfg tm x c)) + = cfgCode W (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n) := by + intro n + induction n with + | zero => intro _; rfl + | succ n ih => + intro hn + obtain ⟨hinv, hW⟩ := cfgTapes_runCfg_choiceCfg_inv tm x c n W (by omega) + rw [Function.iterate_succ_apply', ih (by omega), TM.runCfg_succ] + cases hs : (NTM.choiceTM tm).step (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) n) with + | none => + rw [Option.getD_none] + exact stepFn_halted _ (TM.step_eq_none_iff_halted.mp hs) hq hW + | some c' => + rw [Option.getD_some] + have hgood := stepActs_forall₂ _ _ hinv hW + refine stepFn_eq _ hs hq hW ?_ ?_ hgood + · exact hinv _ (by simp [cfgTapes]) + · intro i + exact hinv _ (by + rw [cfgTapes] + exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ + (List.mem_ofFn.mpr ⟨i, rfl⟩))) + +/-! ## The run is the nondeterministic trace -/ + +/-- The choice bits found on the choice tape are the bits of `c`. -/ +theorem choiceStream_choiceCfg (tm : NTM k) (x c : List Bool) (j : ℕ) (hj : j < c.length) : + NTM.choiceStream (choiceCfg tm x c) j = c[j] := by + have hwork : (choiceCfg tm x c).work (Fin.last k) = choiceTape c := by + simp [choiceCfg] + rw [NTM.choiceStream, hwork, choiceTape_head, choiceTape_cells, + show 1 + j = j + 1 from by omega, Tape.init_cells_succ] + have hjm : j < (c.map Γ.ofBool).length := by simpa using hj + rw [List.getElem?_eq_getElem hjm] + cases hb : c[j] <;> simp [hb, Γ.ofBool] + +/-- **The deterministic run from a choice configuration is the trace.** -/ +theorem dropChoice_runCfg_choiceCfg (tm : NTM k) (T : ℕ) (x c : List Bool) : + NTM.dropChoice (TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) T) + = tm.trace T (fun j => NTM.choiceStream (choiceCfg tm x c) j.val) (tm.initCfg x) := by + obtain ⟨c', t, hle, hreach, hstop, heq⟩ := + NTM.choiceTM_simulates tm T (choiceCfg tm x c) + (by + have hwork : (choiceCfg tm x c).work (Fin.last k) = choiceTape c := by + simp [choiceCfg] + rw [hwork] + exact Tape.StartInvariant.init_ofBool c) + (by + have hwork : (choiceCfg tm x c).work (Fin.last k) = choiceTape c := by + simp [choiceCfg] + rw [hwork, choiceTape_head]) + have hrun : TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) T = c' := by + have hpart : TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) t = c' := + TM.runCfg_of_reachesIn _ hreach + rcases Nat.lt_or_ge t T with hlt | hge + · have hhalt := hstop hlt + rw [show T = t + (T - t) from by omega, TM.runCfg_add, hpart, + TM.runCfg_of_halted _ hhalt] + · have : t = T := by omega + rw [← this, hpart] + rw [hrun] + simpa using heq + +end Cobham + +end Complexity From 0733312d3e7e1908889edbd5e601602405d62e00 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 11:11:15 -0700 Subject: [PATCH 08/24] feat(cobham): compute a nondeterministic path's verdict in the algebra MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Completes the in-algebra simulation of one nondeterministic path: - `Cobham.runChoiceFn` iterates the encoded step function once per bit of the choice string, with `runChoiceFn_mem` placing it in the algebra via the bounded-iteration combinator; - `Cobham.outPairChoiceFn` rewinds the output tape and `Cobham.acceptChoiceFn` reads the verdict off the final configuration — the state block against the halt state's code, and the first output cell against the code for `1`; - `Cobham.acceptChoiceFn_eq_true_iff` proves that verdict is exactly `Cobham.PathAccepts`: after `|c|` steps along the choice bits of `c`, the machine has halted with `1` on the first output cell. With `acceptChoiceFn_mem` this gives the path verdict as a member of Cobham's algebra, hence in `FP` by `CobhamFP_eq_FP`, with no machine construction. Co-Authored-By: Claude Opus 5 (1M context) --- .../Classes/P/Cobham/Internal/ChoiceSim.lean | 226 ++++++++++++++++++ 1 file changed, 226 insertions(+) diff --git a/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean b/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean index 80bff8fd..530518b0 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean @@ -318,6 +318,128 @@ theorem iterate_stepFn_choice (tm : NTM k) (W : ℕ) (x c : List Bool) exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ (List.mem_ofFn.mpr ⟨i, rfl⟩))) +/-! ## Running the path inside the algebra -/ + +@[simp] theorem initChoiceFn_length (tm : NTM k) (R x c : List Bool) : + (initChoiceFn tm R x c).length = (2 * (k + 3) + 1) * R.length := by + rw [initChoiceFn] + simp only [List.length_append, padTo_length, List.length_flatten, + List.map_replicate, List.sum_replicate] + simp + ring + +/-- The encoded run stays inside its blocks. -/ +theorem iterate_stepFn_choice_length_le (tm : NTM k) (R x c : List Bool) (n : ℕ) : + ((stepFn (NTM.choiceTM tm) R)^[n] (initChoiceFn tm R x c)).length + ≤ (2 * (k + 3) + 1) * R.length := by + induction n with + | zero => exact (initChoiceFn_length tm R x c).le + | succ n ih => + rw [Function.iterate_succ_apply'] + exact stepFn_length_le _ R _ ih + +/-- The encoded configuration after running the path for `|c|` steps, under a +ruler derived from the clock string `u`. -/ +noncomputable def runChoiceFn (tm : NTM k) (u x c : List Bool) : List Bool := + (stepFn (NTM.choiceTM tm) (clockRuler u))^[c.length] + (initChoiceFn tm (clockRuler u) x c) + +/-- **Running the path is in the algebra.** -/ +theorem runChoiceFn_mem {n : ℕ} (tm : NTM k) + {gu gx gc : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hc : Cobham gc) : + Cobham fun v : Fin n → List Bool => runChoiceFn tm (gu v) (gx v) (gc v) := by + have hstage := + iterFn (n := 3) + (e := fun w : Fin 3 → List Bool => + initChoiceFn tm (clockRuler (w 1)) (w 2) (w 0)) + (f := fun w : Fin 4 → List Bool => + stepFn (NTM.choiceTM tm) (clockRuler (w 2)) (w 0)) + (j := fun w : Fin 4 → List Bool => + (List.replicate (2 * (k + 3) + 1) (clockRuler (w 2))).flatten) + (initChoiceFn_mem tm (clockRulerFn (Cobham.proj 1)) (Cobham.proj 2) (Cobham.proj 0)) + (stepFn_mem _ (clockRulerFn (Cobham.proj 2)) (Cobham.proj 0)) + (repeatFn (clockRulerFn (Cobham.proj 2)) _) + (by + intro c v + have hlen := iterate_stepFn_choice_length_le tm (clockRuler (v 1)) (v 2) (v 0) c.length + simp only [List.length_flatten, List.map_replicate, List.sum_replicate] + simpa using hlen) + have hg : ∀ i : Fin 4, Cobham (![gc, gc, gu, gx] i) := by + intro i + match i with + | 0 => exact hc + | 1 => exact hc + | 2 => exact hu + | 3 => exact hx + refine (Cobham.comp hstage hg).of_eq fun v => ?_ + rfl + +/-! ## Reading the verdict -/ + +/-- The output tape's two half-blocks after the run, rewound to cell `0`. -/ +noncomputable def outPairChoiceFn (tm : NTM k) (u x c : List Bool) : List Bool := + (rewindFn (clockRuler u))^[u.length] + (blockAt (clockRuler u) (runChoiceFn tm u x c) 3 + ++ blockAt (clockRuler u) (runChoiceFn tm u x c) 4) + +/-- **The rewind stage is in the algebra.** -/ +theorem outPairChoiceFn_mem {n : ℕ} (tm : NTM k) + {gu gx gc : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hc : Cobham gc) : + Cobham fun v : Fin n → List Bool => outPairChoiceFn tm (gu v) (gx v) (gc v) := by + have hstage := + iterFn (n := 3) + (e := fun w : Fin 3 → List Bool => + blockAt (clockRuler (w 0)) (runChoiceFn tm (w 0) (w 1) (w 2)) 3 + ++ blockAt (clockRuler (w 0)) (runChoiceFn tm (w 0) (w 1) (w 2)) 4) + (f := fun w : Fin 4 → List Bool => rewindFn (clockRuler (w 1)) (w 0)) + (j := fun w : Fin 4 → List Bool => clockRuler (w 1) ++ clockRuler (w 1)) + (appendFn + (blockFn (clockRulerFn (Cobham.proj 0)) + (runChoiceFn_mem tm (Cobham.proj 0) (Cobham.proj 1) (Cobham.proj 2)) 3) + (blockFn (clockRulerFn (Cobham.proj 0)) + (runChoiceFn_mem tm (Cobham.proj 0) (Cobham.proj 1) (Cobham.proj 2)) 4)) + (rewindFn_mem (clockRulerFn (Cobham.proj 1)) (Cobham.proj 0)) + (appendFn (clockRulerFn (Cobham.proj 1)) (clockRulerFn (Cobham.proj 1))) + (by + intro c v + show ((rewindFn (clockRuler (v 0)))^[c.length] + (blockAt (clockRuler (v 0)) (runChoiceFn tm (v 0) (v 1) (v 2)) 3 + ++ blockAt (clockRuler (v 0)) (runChoiceFn tm (v 0) (v 1) (v 2)) 4)).length + ≤ (clockRuler (v 0) ++ clockRuler (v 0)).length + rw [List.length_append] + refine le_trans (iterate_rewindFn_length_le _ _ ?_ _) (by omega) + rw [List.length_append, blockAt, blockAt, List.length_take, List.length_take] + omega) + have hg : ∀ i : Fin 4, Cobham (![gu, gu, gx, gc] i) := by + intro i + match i with + | 0 => exact hu + | 1 => exact hu + | 2 => exact hx + | 3 => exact hc + refine (Cobham.comp hstage hg).of_eq fun v => ?_ + rfl + +/-- The verdict of the path: the machine halted with `1` on output cell `1`. -/ +noncomputable def acceptChoiceFn (tm : NTM k) (u x c : List Bool) : List Bool := + andBit + (matchPrefix (stateCode tm.qhalt) (blockAt (clockRuler u) (runChoiceFn tm u x c) 0)) + (matchPrefix (symCode Γ.one) + (((outPairChoiceFn tm u x c).drop (clockRuler u).length).drop 2)) + +/-- **The verdict is in the algebra.** -/ +theorem acceptChoiceFn_mem {n : ℕ} (tm : NTM k) + {gu gx gc : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hc : Cobham gc) : + Cobham fun v : Fin n → List Bool => acceptChoiceFn tm (gu v) (gx v) (gc v) := + andFn + (matchPrefixFn (blockFn (clockRulerFn hu) (runChoiceFn_mem tm hu hx hc) 0) _) + (matchPrefixFn + (dropFn (Cobham.const (List.replicate 2 false)) + (dropFn (clockRulerFn hu) (outPairChoiceFn_mem tm hu hx hc))) _) + /-! ## The run is the nondeterministic trace -/ /-- The choice bits found on the choice tape are the bits of `c`. -/ @@ -358,6 +480,110 @@ theorem dropChoice_runCfg_choiceCfg (tm : NTM k) (T : ℕ) (x c : List Bool) : rw [hrun] simpa using heq +/-! ## The verdict is the path's verdict -/ + +private theorem andBit_eq_true_iff {x y : List Bool} + (hx : x = [true] ∨ x = [false]) (hy : y = [true] ∨ y = [false]) : + andBit x y = [true] ↔ x = [true] ∧ y = [true] := by + rcases hx with rfl | rfl <;> rcases hy with rfl | rfl <;> simp [andBit] + +/-- The predicate the verdict computes: after `|c|` steps along the choice bits +of `c`, the machine has halted with `1` on the first output cell. -/ +def PathAccepts (tm : NTM k) (x c : List Bool) : Prop := + (tm.trace c.length (fun j => c[j.val]'j.isLt) (tm.initCfg x)).state = tm.qhalt ∧ + (tm.trace c.length (fun j => c[j.val]'j.isLt) (tm.initCfg x)).output.cells 1 = Γ.one + +/-- **The algebra's verdict is the path's verdict.** -/ +theorem acceptChoiceFn_eq_true_iff (tm : NTM k) (u x c : List Bool) + (hlen : x.length + c.length + Fintype.card tm.Q + 3 ≤ u.length) : + acceptChoiceFn tm u x c = [true] ↔ PathAccepts tm x c := by + classical + have hu1 : 1 ≤ u.length := by omega + have hR : clockRuler u = blockRuler (u.length - 1) := clockRuler_eq hu1 + have hq : Fintype.card tm.Q ≤ blockWidth (u.length - 1) := by + rw [blockWidth]; omega + set W := u.length - 1 with hWdef + set c' := TM.runCfg (NTM.choiceTM tm) (choiceCfg tm x c) c.length with hc'def + have hrun : runChoiceFn tm u x c = cfgCode W c' := by + rw [runChoiceFn, hR, initChoiceFn_eq tm W x c (by omega) (by omega), + iterate_stepFn_choice tm W x c hq c.length (by omega)] + -- the state half + have hQcard : Fintype.card (NTM.choiceTM tm).Q = Fintype.card tm.Q := rfl + have hblk0 : (cfgBlocks W c')[0]'(by rw [cfgBlocks_length]; omega) + = padTo (blockRuler W) (stateCode c'.state) := rfl + have hstate : blockAt (clockRuler u) (runChoiceFn tm u x c) 0 + = padTo (blockRuler W) (stateCode c'.state) := by + rw [hrun, hR, blockAt_cfgCode W c' 0 (by rw [cfgBlocks_length]; omega), hblk0] + have hcard : (stateCode c'.state).length = (stateCode tm.qhalt).length := by + rw [stateCode_length, stateCode_length] + exact hQcard + have hstateiff : matchPrefix (stateCode tm.qhalt) + (blockAt (clockRuler u) (runChoiceFn tm u x c) 0) = [true] ↔ c'.state = tm.qhalt := by + rw [hstate, matchPrefix_eq_true_iff, + padTo_eq_append _ _ (by + rw [stateCode_length, blockRuler_length, hQcard, blockWidth] + omega)] + constructor + · rintro ⟨t, ht⟩ + have := List.append_inj_left ht hcard.symm + exact (stateCode_injective this).symm + · intro h + rw [h] + exact ⟨_, rfl⟩ + -- the output half + obtain ⟨hinvs, hheads⟩ := cfgTapes_runCfg_choiceCfg_inv tm x c c.length W (by omega) + have hmem : c'.output ∈ cfgTapes c' := by simp [cfgTapes] + have hinv : c'.output.StartInvariant := hinvs _ hmem + have hhead : c'.output.head ≤ W := hheads _ hmem + obtain ⟨hb3, hb4⟩ := blockAt_cfgCode_tape W c' 1 (by rw [cfgTapes_length]; omega) + have hidx : (cfgTapes c')[1]'(by rw [cfgTapes_length]; omega) = c'.output := rfl + rw [hidx, show 2 * 1 + 1 = 3 from rfl] at hb3 + rw [hidx, show 2 * 1 + 2 = 4 from rfl] at hb4 + have hpair : blockAt (clockRuler u) (runChoiceFn tm u x c) 3 + ++ blockAt (clockRuler u) (runChoiceFn tm u x c) 4 = pairCode W c'.output := by + rw [hrun, hR, hb3, hb4, pairCode] + have hrew : outPairChoiceFn tm u x c + = pairCode W { head := 0, cells := c'.output.cells } := by + rw [outPairChoiceFn, hpair, hR, iterate_rewindFn c'.output hinv hhead u.length, + rewound c'.output (by omega)] + have hdrop : ((outPairChoiceFn tm u x c).drop (clockRuler u).length).drop 2 + = cellsCode c'.output 1 W := by + rw [hrew, hR, drop_pairCode_rewound, show W + 1 = 1 + W from by omega, + cellsCode_add c'.output 0 1 W] + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil] + cases c'.output.cells 0 <;> simp [symCode] + have houtiff : matchPrefix (symCode Γ.one) + (((outPairChoiceFn tm u x c).drop (clockRuler u).length).drop 2) = [true] + ↔ c'.output.cells 1 = Γ.one := by + rw [hdrop, show W = 1 + (W - 1) from by omega, cellsCode_add c'.output 1 1 (W - 1), + matchPrefix_eq_true_iff] + have hcell : cellsCode c'.output 1 1 = symCode (c'.output.cells 1) := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil] + rw [hcell] + constructor + · rintro ⟨t, ht⟩ + have hl : (symCode Γ.one).length = (symCode (c'.output.cells 1)).length := by + cases c'.output.cells 1 <;> rfl + exact (symCode_injective (List.append_inj_left ht hl)).symm + · rintro h + rw [h] + exact ⟨_, rfl⟩ + -- assemble + rw [acceptChoiceFn, andBit_eq_true_iff (matchPrefix_flag _ _) (matchPrefix_flag _ _), + hstateiff, houtiff] + have htrace : NTM.dropChoice c' = tm.trace c.length (fun j => c[j.val]'j.isLt) + (tm.initCfg x) := by + rw [hc'def, dropChoice_runCfg_choiceCfg] + congr 1 + funext j + exact choiceStream_choiceCfg tm x c j.val j.isLt + have hstate' : c'.state = (tm.trace c.length (fun j => c[j.val]'j.isLt) + (tm.initCfg x)).state := by rw [← htrace]; rfl + have hout' : c'.output = (tm.trace c.length (fun j => c[j.val]'j.isLt) + (tm.initCfg x)).output := by rw [← htrace]; rfl + rw [hstate', hout'] + rfl + end Cobham end Complexity From 8a53f563cbd43907f5e5d3028f7440978a42805c Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 11:16:32 -0700 Subject: [PATCH 09/24] feat(PH): close the pairFst seam, making the level inclusions unconditional MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `Cobham.fstBlock` is the payload scanner of Cobham's algebra and `Cobham.fstBlock_mem_FP` already proves it polynomial-time. Defining `pairFst` as that scanner discharges the `pairFst ∈ FP` hypothesis the polynomial hierarchy's inclusions were stated against, so `P_subset_polyExistsClass_P`, `P_subset_polyForallClass_P`, `SigmaP_subset_SigmaP_succ` and `PiP_subset_PiP_succ` are now unconditional. Only `pairFst`'s behaviour on canonical pairs is used, and `pairFst_pair` is unchanged; the scanner differs from the old definition only on malformed input, where it returns the bits decoded so far rather than the empty string. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/PH.lean | 64 ++++++++++++++++------------------- 1 file changed, 30 insertions(+), 34 deletions(-) diff --git a/Complexitylib/Classes/PH.lean b/Complexitylib/Classes/PH.lean index 275f5637..e8e8f15f 100644 --- a/Complexitylib/Classes/PH.lean +++ b/Complexitylib/Classes/PH.lean @@ -5,6 +5,7 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.Containments +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock public import Complexitylib.Encoding.Pairing public import Mathlib.Algebra.Polynomial.Eval.Defs @@ -19,13 +20,11 @@ of length at most `p.eval |x|` puts the encoded pair `pair x w` in `L`, and operators gives the levels `SigmaP 0 = P`, `SigmaP (n + 1) = polyExistsClass (PiP n)`, `PiP n = complClass (SigmaP n)`, and their union `PH`. -The level inclusions `SigmaP n ⊆ SigmaP (n + 1)` and `PiP n ⊆ PiP (n + 1)` are -proved relative to a single machine-engineering seam, stated as the hypothesis -`pairFst ∈ FP`: decoding the first component of a canonical pair is -polynomial-time computable. This follows the interface-isolation pattern of -`Complexitylib.Classes.NP.Witness` — every set-theoretic consequence is proved -unconditionally here, and the one remaining TM construction can land later -without touching this file's statements. All other results are unconditional. +The level inclusions `SigmaP n ⊆ SigmaP (n + 1)` and `PiP n ⊆ PiP (n + 1)` need +one computational fact: decoding the first component of a canonical pair is +polynomial-time computable. That is `pairFst_mem_FP`, which reuses the payload +scanner `Cobham.fstBlock` of Cobham's algebra, so every result in this file is +unconditional. ## Main definitions @@ -40,17 +39,13 @@ without touching this file's statements. All other results are unconditional. - `complClass_polyExistsClass` / `complClass_polyForallClass` — class duality - `complClass_P` — `P` is closed under language complement, as a class equation - `SigmaP_zero`, `PiP_zero`, `SigmaP_succ`, `PiP_succ` — recursion laws +- `pairFst_mem_FP` — the pair decoder is polynomial-time - `P_subset_polyExistsClass_P` / `P_subset_polyForallClass_P` — base inclusions - (given `pairFst ∈ FP`) - `SigmaP_subset_SigmaP_succ` / `PiP_subset_PiP_succ` — level inclusions - (given `pairFst ∈ FP`) - `SigmaP_subset_PH`, `P_subset_PH` ## TODO -- Implement the `pairFst ∈ FP` seam: split the input with a - `pairSplitCoreTM`-style scanner and copy the decoded first component to the - output tape, packaging the result as `TM.ComputesInTime`. - Relate `SigmaP 1` to the NTM-based `NP` through the witness characterization interface in `Complexitylib.Classes.NP.Witness`. -/ @@ -152,15 +147,20 @@ theorem complClass_polyForallClass (C : Set Language) : /-! ## The pair decoder seam -/ -/-- Decode the first component of a canonical pair, returning `[]` on malformed -inputs. Statements below take the hypothesis `pairFst ∈ FP` — the one remaining -machine construction of this development (see the module docstring). -/ -def pairFst (z : List Bool) : List Bool := - ((unpair? z).map Prod.fst).getD [] +/-- Decode the first component of a canonical pair. This is the payload scanner +`Cobham.fstBlock` of Cobham's algebra: it reads doubled bits up to the +separator, so on a canonical pair it returns the first component, and on +malformed input it returns the bits decoded so far. Only its behaviour on +canonical pairs is used. -/ +def pairFst (z : List Bool) : List Bool := Cobham.fstBlock z /-- `pairFst` recovers the first component of a canonical pair. -/ -@[simp] theorem pairFst_pair (x y : List Bool) : pairFst (pair x y) = x := by - simp [pairFst] +@[simp] theorem pairFst_pair (x y : List Bool) : pairFst (pair x y) = x := + Cobham.fstBlock_pair x y + +/-- **Decoding the first component is polynomial-time.** The scanner is one of +the bespoke transducers of Cobham's soundness direction. -/ +theorem pairFst_mem_FP : pairFst ∈ FP := Cobham.fstBlock_mem_FP /-! ## Base inclusions -/ @@ -172,10 +172,9 @@ theorem complClass_P : complClass P = P := by /-- Every language of `P` is a bounded existential over `P`: take the zero witness bound, so the only witness is `[]`, and decide `pair x []` by decoding the first component and running the original decider. -/ -theorem P_subset_polyExistsClass_P (hpair : pairFst ∈ FP) : - P ⊆ polyExistsClass P := by +theorem P_subset_polyExistsClass_P : P ⊆ polyExistsClass P := by intro L hL - refine ⟨0, pairFst ⁻¹' L, mem_P_preimage hpair hL, ?_⟩ + refine ⟨0, pairFst ⁻¹' L, mem_P_preimage pairFst_mem_FP hL, ?_⟩ ext x simp only [mem_polyExistsLang, Polynomial.eval_zero, Nat.le_zero, List.length_eq_zero_iff, Set.mem_preimage] @@ -188,10 +187,9 @@ theorem P_subset_polyExistsClass_P (hpair : pairFst ∈ FP) : /-- Every language of `P` is a bounded universal over `P`: with the zero witness bound the only witness is `[]`, decided as in `P_subset_polyExistsClass_P`. -/ -theorem P_subset_polyForallClass_P (hpair : pairFst ∈ FP) : - P ⊆ polyForallClass P := by +theorem P_subset_polyForallClass_P : P ⊆ polyForallClass P := by intro L hL - refine ⟨0, pairFst ⁻¹' L, mem_P_preimage hpair hL, ?_⟩ + refine ⟨0, pairFst ⁻¹' L, mem_P_preimage pairFst_mem_FP hL, ?_⟩ ext x simp only [mem_polyForallLang, Polynomial.eval_zero, Nat.le_zero, List.length_eq_zero_iff, Set.mem_preimage] @@ -259,15 +257,15 @@ theorem PiP_one : PiP 1 = polyForallClass P := by /-- Both level inclusions, proved simultaneously by induction: the base case is the pair of base inclusions of `P`, and each successor case is monotonicity of the opposite quantifier applied to the other component. -/ -private theorem piP_sigmaP_subset_succ (hpair : pairFst ∈ FP) (n : ℕ) : +private theorem piP_sigmaP_subset_succ (n : ℕ) : PiP n ⊆ PiP (n + 1) ∧ SigmaP n ⊆ SigmaP (n + 1) := by induction n with | zero => constructor · rw [PiP_zero, PiP_one] - exact P_subset_polyForallClass_P hpair + exact P_subset_polyForallClass_P · rw [SigmaP_zero, SigmaP_one] - exact P_subset_polyExistsClass_P hpair + exact P_subset_polyExistsClass_P | succ n ih => constructor · rw [PiP_succ, PiP_succ] @@ -276,14 +274,12 @@ private theorem piP_sigmaP_subset_succ (hpair : pairFst ∈ FP) (n : ℕ) : exact polyExistsClass_mono ih.1 /-- Each Σ level is contained in the next. -/ -theorem SigmaP_subset_SigmaP_succ (hpair : pairFst ∈ FP) (n : ℕ) : - SigmaP n ⊆ SigmaP (n + 1) := - (piP_sigmaP_subset_succ hpair n).2 +theorem SigmaP_subset_SigmaP_succ (n : ℕ) : SigmaP n ⊆ SigmaP (n + 1) := + (piP_sigmaP_subset_succ n).2 /-- Each Π level is contained in the next. -/ -theorem PiP_subset_PiP_succ (hpair : pairFst ∈ FP) (n : ℕ) : - PiP n ⊆ PiP (n + 1) := - (piP_sigmaP_subset_succ hpair n).1 +theorem PiP_subset_PiP_succ (n : ℕ) : PiP n ⊆ PiP (n + 1) := + (piP_sigmaP_subset_succ n).1 /-! ## PH -/ From de8993f4ad5babd822751de78a7c721369334902 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 11:25:55 -0700 Subject: [PATCH 10/24] feat(cobham): polynomial lengths, length tests, and exclusive-or in the algebra MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Three utilities the matrix computation needs, all machine-free: - `Cobham.polyLen` — for any `Polynomial ℕ`, a member of the algebra whose output has exactly the polynomial's value as its length, by Horner's scheme through `smash` (which multiplies lengths) and concatenation (which adds them); - `Cobham.lenLeFlag` / `Cobham.lenEqFlag` — length comparison flags, a drop followed by an emptiness test; - `Cobham.xorSuffix` — bitwise exclusive-or of a string with the matching suffix of a second string, as one limited recursion whose step reads the paired bit of the second argument through a ruler cut to the right width; `xorSuffix_eq_zipWith_of_length` identifies it with the pointwise operation on equal-length strings. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/P/Cobham/Internal.lean | 2 + .../Classes/P/Cobham/Internal/PolyLen.lean | 101 +++++++ .../Classes/P/Cobham/Internal/StringOps.lean | 259 ++++++++++++++++++ 3 files changed, 362 insertions(+) create mode 100644 Complexitylib/Classes/P/Cobham/Internal/PolyLen.lean create mode 100644 Complexitylib/Classes/P/Cobham/Internal/StringOps.lean diff --git a/Complexitylib/Classes/P/Cobham/Internal.lean b/Complexitylib/Classes/P/Cobham/Internal.lean index 27036171..9513b330 100644 --- a/Complexitylib/Classes/P/Cobham/Internal.lean +++ b/Complexitylib/Classes/P/Cobham/Internal.lean @@ -13,6 +13,8 @@ public import Complexitylib.Classes.P.Cobham.Internal.ConsBit public import Complexitylib.Classes.P.Cobham.Internal.Reorder public import Complexitylib.Classes.P.Cobham.Internal.Vec public import Complexitylib.Classes.P.Cobham.Internal.Algebra +public import Complexitylib.Classes.P.Cobham.Internal.PolyLen +public import Complexitylib.Classes.P.Cobham.Internal.StringOps public import Complexitylib.Classes.P.Cobham.Internal.Encoding public import Complexitylib.Classes.P.Cobham.Internal.StepAlgebra public import Complexitylib.Classes.P.Cobham.Internal.Simulate diff --git a/Complexitylib/Classes/P/Cobham/Internal/PolyLen.lean b/Complexitylib/Classes/P/Cobham/Internal/PolyLen.lean new file mode 100644 index 00000000..9eeb09dc --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/PolyLen.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal.Algebra +public import Mathlib.Algebra.Polynomial.Eval.Degree + +/-! +# Polynomial lengths inside the algebra + +A computation in Cobham's algebra measures sizes by string lengths, so a +polynomial time or space bound has to be available as a *string of that +length*. `smash` multiplies lengths and concatenation adds them, so Horner's +scheme builds, for any polynomial with natural coefficients, a member of the +algebra whose output has exactly the polynomial's value as its length. + +## Main definitions + +- `Cobham.hornerEval` — Horner evaluation of a coefficient list +- `Cobham.lenOfCoeffs` — the string realizing that value as its length +- `Cobham.polyLen` — the same for a `Polynomial ℕ` + +## Main results + +- `Cobham.lenOfCoeffs_mem`, `Cobham.polyLen_mem` — both are in the algebra +- `Cobham.polyLen_length` — `polyLen q s` has length exactly `q.eval |s|` +-/ + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- Horner evaluation of a coefficient list, lowest coefficient first. -/ +def hornerEval : List ℕ → ℕ → ℕ + | [], _ => 0 + | a :: as, n => a + n * hornerEval as n + +/-- The string whose length is the Horner value of the coefficient list at +`|s|`: constants contribute blocks of that many bits, and each multiplication +by `|s|` is one `smash`. -/ +def lenOfCoeffs : List ℕ → List Bool → List Bool + | [], _ => [] + | a :: as, s => List.replicate a false ++ Complexity.smash s (lenOfCoeffs as s) + +@[simp] theorem lenOfCoeffs_length (as : List ℕ) (s : List Bool) : + (lenOfCoeffs as s).length = hornerEval as s.length := by + induction as with + | nil => rfl + | cons a as ih => + rw [lenOfCoeffs, hornerEval, List.length_append, List.length_replicate, + smash_length, ih] + +/-- **The Horner string is in the algebra.** -/ +theorem lenOfCoeffs_mem {n : ℕ} (as : List ℕ) + {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => lenOfCoeffs as (g v) := by + induction as with + | nil => exact (Cobham.const []).of_eq fun _ => rfl + | cons a as ih => + exact (appendFn (Cobham.const (List.replicate a false)) + (comp₂ Cobham.smash hg ih)).of_eq fun _ => by simp [lenOfCoeffs] + +/-- Horner evaluation of a truncated coefficient sequence is the truncated +power sum. -/ +theorem hornerEval_map_range (f : ℕ → ℕ) (d n : ℕ) : + hornerEval ((List.range d).map f) n = ∑ i ∈ Finset.range d, f i * n ^ i := by + induction d generalizing f with + | zero => rfl + | succ d ih => + rw [List.range_succ_eq_map, List.map_cons, List.map_map, hornerEval, + ih (f ∘ Nat.succ), Finset.sum_range_succ' (fun i => f i * n ^ i) d] + simp only [Function.comp_apply, pow_zero, mul_one] + have hmul : n * ∑ i ∈ Finset.range d, f (i + 1) * n ^ i + = ∑ i ∈ Finset.range d, f (i + 1) * n ^ (i + 1) := by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun i _ => by ring + rw [hmul] + omega + +/-- The string realizing a polynomial's value as its length. -/ +noncomputable def polyLen (q : Polynomial ℕ) (s : List Bool) : List Bool := + lenOfCoeffs ((List.range (q.natDegree + 1)).map q.coeff) s + +/-- **The polynomial's value is the string's length.** -/ +@[simp] theorem polyLen_length (q : Polynomial ℕ) (s : List Bool) : + (polyLen q s).length = q.eval s.length := by + rw [polyLen, lenOfCoeffs_length, hornerEval_map_range, Polynomial.eval_eq_sum_range] + +/-- **The polynomial-length string is in the algebra.** -/ +theorem polyLen_mem {n : ℕ} (q : Polynomial ℕ) + {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => polyLen q (g v) := + lenOfCoeffs_mem _ hg + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean b/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean new file mode 100644 index 00000000..9e9b683b --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal.Algebra + +/-! +# Length tests and bitwise operations inside the algebra + +Two utilities the algebra needs for block-structured data: comparing the +lengths of two strings, and taking the bitwise exclusive-or of two strings of +equal length. + +Both are built from the dispatchers of +`Complexitylib.Classes.P.Cobham.Internal.Blocks`: a length comparison is a +`drop` followed by an emptiness test, and the exclusive-or is one limited +recursion whose step reads the matching bit of the second argument through a +ruler cut to the right width. + +## Main definitions + +- `Cobham.lenLeFlag`, `Cobham.lenEqFlag` — length comparison flags +- `Cobham.xorSuffix` — exclusive-or of a string with the matching suffix of a + second string + +## Main results + +- `Cobham.lenLeFlag_eq_true_iff`, `Cobham.lenEqFlag_eq_true_iff` +- `Cobham.lenLeFlag_mem`, `Cobham.lenEqFlag_mem` +- `Cobham.andBit_eq_true_iff` — conjunction of flags +-/ + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- Conjunction of two flags is `[true]` exactly when both are. -/ +theorem andBit_eq_true_iff {x y : List Bool} + (hx : x = [true] ∨ x = [false]) (hy : y = [true] ∨ y = [false]) : + andBit x y = [true] ↔ x = [true] ∧ y = [true] := by + rcases hx with rfl | rfl <;> rcases hy with rfl | rfl <;> simp [andBit] + +/-- Disjunction of two flags is `[true]` exactly when one is. -/ +theorem orBit_eq_true_iff {x y : List Bool} + (hx : x = [true] ∨ x = [false]) (hy : y = [true] ∨ y = [false]) : + orBit x y = [true] ↔ x = [true] ∨ y = [true] := by + rcases hx with rfl | rfl <;> rcases hy with rfl | rfl <;> simp [orBit] + +/-- Negation of a flag. -/ +theorem notBit_eq_true_iff {x : List Bool} (hx : x = [true] ∨ x = [false]) : + notBit x = [true] ↔ x = [false] := by + rcases hx with rfl | rfl <;> simp [notBit] + +/-- The flag `|b| ≤ |a|`: nothing is left of `b` after dropping `|a|` bits. -/ +def lenLeFlag (a b : List Bool) : List Bool := notBit (nonemptyFlag (b.drop a.length)) + +/-- The flag `|a| = |b|`. -/ +def lenEqFlag (a b : List Bool) : List Bool := andBit (lenLeFlag a b) (lenLeFlag b a) + +theorem lenLeFlag_flag (a b : List Bool) : + lenLeFlag a b = [true] ∨ lenLeFlag a b = [false] := by + rw [lenLeFlag, nonemptyFlag] + rcases hb : b.drop a.length with _ | ⟨c, z⟩ + · exact Or.inl rfl + · cases c <;> exact Or.inr rfl + +@[simp] theorem lenLeFlag_eq_true_iff (a b : List Bool) : + lenLeFlag a b = [true] ↔ b.length ≤ a.length := by + rw [lenLeFlag, nonemptyFlag] + rcases hb : b.drop a.length with _ | ⟨c, z⟩ + · have : b.length ≤ a.length := by + have := List.length_drop (i := a.length) (l := b) + rw [hb] at this + simp at this + omega + simp [notBit, this] + · have hlt : a.length < b.length := by + have hlen := List.length_drop (i := a.length) (l := b) + rw [hb] at hlen + simp at hlen + omega + cases c <;> simp [notBit, Nat.not_le.mpr hlt] + +theorem lenEqFlag_flag (a b : List Bool) : + lenEqFlag a b = [true] ∨ lenEqFlag a b = [false] := by + rw [lenEqFlag] + rcases lenLeFlag_flag a b with h | h <;> rcases lenLeFlag_flag b a with h' | h' <;> + rw [h, h'] <;> simp [andBit] + +@[simp] theorem lenEqFlag_eq_true_iff (a b : List Bool) : + lenEqFlag a b = [true] ↔ a.length = b.length := by + rw [lenEqFlag, andBit_eq_true_iff (lenLeFlag_flag a b) (lenLeFlag_flag b a), + lenLeFlag_eq_true_iff, lenLeFlag_eq_true_iff] + omega + +/-- **The length tests are in the algebra.** -/ +theorem lenLeFlag_mem {n : ℕ} {ga gb : (Fin n → List Bool) → List Bool} + (ha : Cobham ga) (hb : Cobham gb) : + Cobham fun v : Fin n → List Bool => lenLeFlag (ga v) (gb v) := + (notFn (nonemptyFn (dropFn ha hb))).of_eq fun _ => rfl + +theorem lenEqFlag_mem {n : ℕ} {ga gb : (Fin n → List Bool) → List Bool} + (ha : Cobham ga) (hb : Cobham gb) : + Cobham fun v : Fin n → List Bool => lenEqFlag (ga v) (gb v) := + (andFn (lenLeFlag_mem ha hb) (lenLeFlag_mem hb ha)).of_eq fun _ => rfl + +/-! ## Exclusive-or -/ + +/-- Exclusive-or of `a` with the suffix of `b` of the same length. The bit of +`b` paired with the head of `a` sits at index `|b| - |x| - 1`, which is the +length of `b.drop (|x| + 1)` — a ruler the algebra can build from the +recursion's own tail. -/ +def xorSuffix : List Bool → List Bool → List Bool + | [], _ => [] + | true :: x, b => + caseBit₀ (notBit (bitAt (b.drop (false :: x).length) b)) + (true :: xorSuffix x b) (false :: xorSuffix x b) + | false :: x, b => + caseBit₀ (bitAt (b.drop (false :: x).length) b) + (true :: xorSuffix x b) (false :: xorSuffix x b) + +@[simp] theorem xorSuffix_nil (b : List Bool) : xorSuffix [] b = [] := rfl + +@[simp] theorem xorSuffix_length (a b : List Bool) : + (xorSuffix a b).length = a.length := by + induction a with + | nil => rfl + | cons β x ih => + cases β <;> + · rw [xorSuffix] + rcases hb : (bitAt (b.drop (false :: x).length) b) with _ | ⟨d, z⟩ + · simp [notBit, ih] + · cases d <;> simp [notBit, ih] + +/-- The bit read at the matching position. -/ +private theorem bitAt_drop_eq (x b : List Bool) (h : x.length < b.length) : + bitAt (b.drop (false :: x).length) b + = [b[b.length - x.length - 1]'(by omega)] := by + have hlen : (b.drop (false :: x).length).length = b.length - x.length - 1 := by + rw [List.length_drop, List.length_cons] + omega + rw [bitAt, hlen] + have hd : b.drop (b.length - x.length - 1) + = b[b.length - x.length - 1]'(by omega) :: b.drop (b.length - x.length) := by + have hcons := List.drop_eq_getElem_cons (l := b) (i := b.length - x.length - 1) + (by omega) + rw [hcons, show b.length - x.length - 1 + 1 = b.length - x.length from by omega] + rw [hd] + cases b[b.length - x.length - 1]'(by omega) <;> rfl + +/-- **The exclusive-or is the pointwise one against the matching suffix.** -/ +theorem xorSuffix_eq_zipWith (a b : List Bool) (h : a.length ≤ b.length) : + xorSuffix a b = List.zipWith xor a (b.drop (b.length - a.length)) := by + induction a with + | nil => simp + | cons β x ih => + have hx : x.length < b.length := by + rw [List.length_cons] at h + omega + have hdrop : b.drop (b.length - (β :: x).length) + = b[b.length - x.length - 1]'(by omega) :: b.drop (b.length - x.length) := by + have h1 : b.length - (β :: x).length = b.length - x.length - 1 := by + rw [List.length_cons] + omega + have hcons := List.drop_eq_getElem_cons (l := b) (i := b.length - x.length - 1) + (by omega) + rw [h1, hcons, show b.length - x.length - 1 + 1 = b.length - x.length from by omega] + rw [hdrop, List.zipWith_cons_cons, ← ih (by omega)] + cases β <;> + · rw [xorSuffix, bitAt_drop_eq x b hx] + cases b[b.length - x.length - 1]'(by omega) <;> simp [notBit] + +/-- Two strings of equal length are combined bit by bit. -/ +theorem xorSuffix_eq_zipWith_of_length (a b : List Bool) (h : a.length = b.length) : + xorSuffix a b = List.zipWith xor a b := by + rw [xorSuffix_eq_zipWith a b h.le, h] + simp + +/-- The step functions of the exclusive-or recursion. -/ +private def xorStep (β : Bool) (w : Fin 3 → List Bool) : List Bool := + caseBit₀ + ((bif β then notBit else id) (bitAt ((w 2).drop (false :: w 0).length) (w 2))) + (true :: w 1) (false :: w 1) + +private theorem xorStep_mem (β : Bool) : Cobham (xorStep β) := by + have hprepend : Cobham fun w : Fin 3 → List Bool => false :: w 0 := + (Cobham.comp (Cobham.bit false) fun _ : Fin 1 => Cobham.proj 0).of_eq fun _ => rfl + have hbit : Cobham fun w : Fin 3 → List Bool => + bitAt ((w 2).drop (false :: w 0).length) (w 2) := + (comp₂ bitAtFn (dropFn hprepend (Cobham.proj 2)) (Cobham.proj 2)).of_eq fun _ => rfl + have hcons1 : Cobham fun w : Fin 3 → List Bool => true :: w 1 := + (Cobham.comp (Cobham.bit true) fun _ : Fin 1 => Cobham.proj 1).of_eq fun _ => rfl + have hcons0 : Cobham fun w : Fin 3 → List Bool => false :: w 1 := + (Cobham.comp (Cobham.bit false) fun _ : Fin 1 => Cobham.proj 1).of_eq fun _ => rfl + cases β + · exact (iteFn hbit hcons1 hcons0).of_eq fun _ => rfl + · exact (iteFn (notFn hbit) hcons1 hcons0).of_eq fun _ => rfl + +private theorem xorStep_length (β : Bool) (w : Fin 3 → List Bool) : + (xorStep β w).length = (w 1).length + 1 := by + rw [xorStep] + rcases hc : ((bif β then notBit else id) + (bitAt ((w 2).drop (false :: w 0).length) (w 2))) with _ | ⟨d, z⟩ + · simp + · cases d <;> simp + +private theorem recNotation_xor (a b : List Bool) : + recNotation (fun _ : Fin 1 → List Bool => ([] : List Bool)) (xorStep false) + (xorStep true) a (fun _ => b) = xorSuffix a b := by + induction a with + | nil => rfl + | cons β x ih => + cases β <;> + · rw [recNotation_cons, xorSuffix] + simp only [cond_false, cond_true, xorStep, Fin.cons_zero, Fin.cons_one, id] + rw [ih] + rfl + +private theorem recNotation_xor_length (a b : List Bool) : + (recNotation (fun _ : Fin 1 → List Bool => ([] : List Bool)) (xorStep false) + (xorStep true) a (fun _ => b)).length ≤ a.length := by + rw [recNotation_xor, xorSuffix_length] + +/-- **The exclusive-or is in the algebra.** -/ +theorem xorSuffix_mem {n : ℕ} {ga gb : (Fin n → List Bool) → List Bool} + (ha : Cobham ga) (hb : Cobham gb) : + Cobham fun v : Fin n → List Bool => xorSuffix (ga v) (gb v) := by + have hrec := Cobham.boundedRec (g := fun _ : Fin 1 → List Bool => ([] : List Bool)) + (h₀ := xorStep false) (h₁ := xorStep true) + (j := fun w : Fin 2 → List Bool => w 0) + Cobham.empty (xorStep_mem false) (xorStep_mem true) (Cobham.proj 0) + (by + intro x v + have := recNotation_xor_length x (v 0) + have hv : (fun _ : Fin 1 => v 0) = v := by + funext i + rw [Subsingleton.elim i 0] + rw [hv] at this + simpa using this) + have hg : ∀ i : Fin 2, Cobham (![ga, gb] i) := by + intro i + match i with + | 0 => exact ha + | 1 => exact hb + refine (Cobham.comp hrec hg).of_eq fun v => ?_ + have hb2 : (Fin.tail fun i => ![ga, gb] i v) = fun _ : Fin 1 => gb v := by + funext i + rw [Subsingleton.elim i 0] + rfl + show recNotation _ _ _ (ga v) (Fin.tail fun i => ![ga, gb] i v) = _ + rw [hb2, recNotation_xor] + +end Cobham + +end Complexity From 0f1f3beac6f923c4970dc6b9647e87caf90797ef Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 11:34:09 -0700 Subject: [PATCH 11/24] feat(cobham): block loops for the amplified verdict MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Both loops of the amplified acceptance test, as limited recursions over a ruler whose length is the iteration count — the block index at each step is the length of the remaining tail, so no state is threaded through: - `Cobham.acceptCountAux` counts, in unary, the blocks of a seed on which the path accepts, with `acceptCountAux_length` identifying the count and `acceptCountAux_mem` placing it in the algebra; - `Cobham.majorityFlag` and `Cobham.verdictFlag` turn that count into the amplified majority verdict (or its negation), with `majorityFlag_eq_true_iff`; - `Cobham.anyShiftAux` takes the disjunction of the verdict over the shift blocks of the witness, with `anyShiftAux_eq_true_iff` identifying it with an existential over shift indices. Also adds `orBit_flag` and `orBit_length` to the flag API. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/P/Cobham/Internal.lean | 1 + .../Classes/P/Cobham/Internal/BlockLoop.lean | 384 ++++++++++++++++++ .../Classes/P/Cobham/Internal/ChoiceSim.lean | 5 + .../Classes/P/Cobham/Internal/StringOps.lean | 19 + 4 files changed, 409 insertions(+) create mode 100644 Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean diff --git a/Complexitylib/Classes/P/Cobham/Internal.lean b/Complexitylib/Classes/P/Cobham/Internal.lean index 9513b330..5e52e8df 100644 --- a/Complexitylib/Classes/P/Cobham/Internal.lean +++ b/Complexitylib/Classes/P/Cobham/Internal.lean @@ -19,6 +19,7 @@ public import Complexitylib.Classes.P.Cobham.Internal.Encoding public import Complexitylib.Classes.P.Cobham.Internal.StepAlgebra public import Complexitylib.Classes.P.Cobham.Internal.Simulate public import Complexitylib.Classes.P.Cobham.Internal.ChoiceSim +public import Complexitylib.Classes.P.Cobham.Internal.BlockLoop public import Complexitylib.Classes.P.Cobham.Internal.IterateLayout public import Complexitylib.Classes.P.Cobham.Internal.Iterate public import Complexitylib.Classes.P.Cobham.Internal.TakeLen diff --git a/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean b/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean new file mode 100644 index 00000000..c50c5541 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean @@ -0,0 +1,384 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal.ChoiceSim +public import Complexitylib.Classes.P.Cobham.Internal.PolyLen +public import Complexitylib.Classes.P.Cobham.Internal.StringOps + +/-! +# Looping over the blocks of a string inside the algebra + +Amplified acceptance is a majority vote over the blocks of a random seed. Both +that vote and the outer disjunction over shift blocks are limited recursions +over a *ruler* whose length is the iteration count: at the step whose tail is +`y`, the block index is `|y|`, so the block itself is cut out of the source +string by a `drop` of `|y| · |τ|` bits — a length `smash` produces — followed +by a `take` of `|τ|`. No state has to be threaded through the recursion. + +## Main definitions + +- `Cobham.blockAtIdx` — the `j`-th block of a string at a given width +- `Cobham.acceptCountAux` — unary count of blocks on which the path accepts +- `Cobham.majorityFlag` — the amplified majority verdict as a flag + +## Main results + +- `Cobham.acceptCountAux_length` — the count is the number of accepting blocks +- `Cobham.acceptCountAux_mem`, `Cobham.majorityFlag_mem` — both are in the + algebra +-/ + +@[expose] public section + +namespace Complexity + +namespace Cobham + +variable {k : ℕ} + +/-- The `j`-th block of `s` at width `w`. -/ +def blockAtIdx (w : ℕ) (s : List Bool) (j : ℕ) : List Bool := (s.drop (j * w)).take w + +/-- The block of `s` selected by the ruler `idx` at the width of `τ`. -/ +def blockOf (τ s idx : List Bool) : List Bool := + (s.drop (Complexity.smash idx τ).length).take τ.length + +@[simp] theorem blockOf_eq (τ s idx : List Bool) : + blockOf τ s idx = blockAtIdx τ.length s idx.length := by + rw [blockOf, blockAtIdx, smash_length] + +theorem blockOf_mem {n : ℕ} {gτ gs gidx : (Fin n → List Bool) → List Bool} + (hτ : Cobham gτ) (hs : Cobham gs) (hidx : Cobham gidx) : + Cobham fun v : Fin n → List Bool => blockOf (gτ v) (gs v) (gidx v) := + (takeFn hτ (dropFn (comp₂ Cobham.smash hidx hτ) hs)).of_eq fun _ => rfl + +/-! ## Counting accepting blocks -/ + +/-- Unary count of the blocks of `s` on which the path of `tm` accepts: one bit +per accepting block. The recursion runs once per bit of `ρ`, and the block +index at each step is the length of the remaining tail. -/ +noncomputable def acceptCountAux (tm : NTM k) (u x τ s : List Bool) : List Bool → List Bool + | [] => [] + | _ :: y => + caseBit₀ (acceptChoiceFn tm u x (blockOf τ s y)) + (false :: acceptCountAux tm u x τ s y) (acceptCountAux tm u x τ s y) + +/-- The count is the number of accepting block indices below `|ρ|`. -/ +theorem acceptCountAux_length (tm : NTM k) (u x τ s ρ : List Bool) : + (acceptCountAux tm u x τ s ρ).length + = ∑ j ∈ Finset.range ρ.length, + (if acceptChoiceFn tm u x (blockAtIdx τ.length s j) = [true] then 1 else 0) := by + induction ρ with + | nil => simp [acceptCountAux] + | cons β y ih => + have hflag := acceptChoiceFn_flag tm u x (blockOf τ s y) + rw [acceptCountAux, List.length_cons, Finset.sum_range_succ, ← ih] + rcases hflag with hf | hf + · rw [hf] + simp only [caseBit₀_cons, cond_true, List.length_cons] + rw [if_pos (by rw [← blockOf_eq]; exact hf)] + · rw [hf] + simp only [caseBit₀_cons, cond_false] + rw [if_neg (by rw [← blockOf_eq, hf]; simp)] + omega + +/-- The step of the counting recursion. -/ +private noncomputable def countStep (tm : NTM k) (w : Fin 6 → List Bool) : List Bool := + caseBit₀ (acceptChoiceFn tm (w 2) (w 3) (blockOf (w 4) (w 5) (w 0))) + (false :: w 1) (w 1) + +private theorem countStep_mem (tm : NTM k) : Cobham (countStep tm) := by + have hcons : Cobham fun w : Fin 6 → List Bool => false :: w 1 := + (Cobham.comp (Cobham.bit false) fun _ : Fin 1 => Cobham.proj 1).of_eq fun _ => rfl + exact (iteFn + (acceptChoiceFn_mem tm (Cobham.proj 2) (Cobham.proj 3) + (blockOf_mem (Cobham.proj 4) (Cobham.proj 5) (Cobham.proj 0))) + hcons (Cobham.proj 1)).of_eq fun _ => rfl + +private theorem recNotation_count (tm : NTM k) (u x τ s ρ : List Bool) : + recNotation (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) ρ ![u, x, τ, s] + = acceptCountAux tm u x τ s ρ := by + induction ρ with + | nil => rfl + | cons β y ih => + rw [recNotation_cons, acceptCountAux] + cases β <;> + · simp only [cond_false, cond_true, countStep, Fin.cons_zero, Fin.cons_one] + rw [show (Fin.cons y (Fin.cons (recNotation + (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) y ![u, x, τ, s]) ![u, x, τ, s]) : Fin 6 → List Bool) 2 = u from rfl, + show (Fin.cons y (Fin.cons (recNotation + (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) y ![u, x, τ, s]) ![u, x, τ, s]) : Fin 6 → List Bool) 3 = x from rfl, + show (Fin.cons y (Fin.cons (recNotation + (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) y ![u, x, τ, s]) ![u, x, τ, s]) : Fin 6 → List Bool) 4 = τ from rfl, + show (Fin.cons y (Fin.cons (recNotation + (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) y ![u, x, τ, s]) ![u, x, τ, s]) : Fin 6 → List Bool) 5 = s from rfl, + ih] + +private theorem recNotation_count_length (tm : NTM k) (ρ : List Bool) + (v : Fin 4 → List Bool) : + (recNotation (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) ρ v).length ≤ ρ.length := by + induction ρ with + | nil => simp + | cons β y ih => + rw [recNotation_cons, List.length_cons] + have hstep : ∀ (a b : List Bool) (w' : Fin 4 → List Bool), + (countStep tm (Fin.cons a (Fin.cons b w'))).length ≤ b.length + 1 := by + intro a b w' + show (caseBit₀ (acceptChoiceFn tm _ _ _) (false :: b) b).length ≤ b.length + 1 + rcases hc : acceptChoiceFn tm ((Fin.cons a (Fin.cons b w') : Fin 6 → List Bool) 2) + ((Fin.cons a (Fin.cons b w') : Fin 6 → List Bool) 3) + (blockOf ((Fin.cons a (Fin.cons b w') : Fin 6 → List Bool) 4) + ((Fin.cons a (Fin.cons b w') : Fin 6 → List Bool) 5) + ((Fin.cons a (Fin.cons b w') : Fin 6 → List Bool) 0)) with _ | ⟨d, z⟩ + · simp + · cases d <;> simp + cases β <;> + · simp only [cond_false, cond_true] + have := hstep y (recNotation + (fun _ : Fin 4 → List Bool => ([] : List Bool)) (countStep tm) + (countStep tm) y v) v + omega + +/-- **The count is in the algebra.** -/ +theorem acceptCountAux_mem {n : ℕ} (tm : NTM k) + {gu gx gτ gs gρ : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hτ : Cobham gτ) (hs : Cobham gs) + (hρ : Cobham gρ) : + Cobham fun v : Fin n → List Bool => + acceptCountAux tm (gu v) (gx v) (gτ v) (gs v) (gρ v) := by + have hrec := Cobham.boundedRec (g := fun _ : Fin 4 → List Bool => ([] : List Bool)) + (h₀ := countStep tm) (h₁ := countStep tm) + (j := fun w : Fin 5 → List Bool => w 0) + Cobham.empty (countStep_mem tm) (countStep_mem tm) (Cobham.proj 0) + (by + intro ρ v + simpa using recNotation_count_length tm ρ v) + have hg : ∀ i : Fin 5, Cobham (![gρ, gu, gx, gτ, gs] i) := by + intro i + match i with + | 0 => exact hρ + | 1 => exact hu + | 2 => exact hx + | 3 => exact hτ + | 4 => exact hs + refine (Cobham.comp hrec hg).of_eq fun v => ?_ + have htail : (Fin.tail fun i => ![gρ, gu, gx, gτ, gs] i v) + = ![gu v, gx v, gτ v, gs v] := by + funext i + match i with + | 0 => rfl + | 1 => rfl + | 2 => rfl + | 3 => rfl + show recNotation _ _ _ (gρ v) (Fin.tail fun i => ![gρ, gu, gx, gτ, gs] i v) = _ + rw [htail, recNotation_count] + +/-! ## The amplified verdict -/ + +/-- The amplified majority verdict as a flag: strictly more than half of the +`|ρ|` blocks of `s` accept. -/ +noncomputable def majorityFlag (tm : NTM k) (u x τ s ρ : List Bool) : List Bool := + notBit (lenLeFlag ρ (acceptCountAux tm u x τ s ρ ++ acceptCountAux tm u x τ s ρ)) + +theorem majorityFlag_flag (tm : NTM k) (u x τ s ρ : List Bool) : + majorityFlag tm u x τ s ρ = [true] ∨ majorityFlag tm u x τ s ρ = [false] := by + rw [majorityFlag] + rcases lenLeFlag_flag ρ (acceptCountAux tm u x τ s ρ ++ acceptCountAux tm u x τ s ρ) + with h | h <;> rw [h] <;> simp [notBit] + +theorem majorityFlag_eq_true_iff (tm : NTM k) (u x τ s ρ : List Bool) : + majorityFlag tm u x τ s ρ = [true] ↔ + ρ.length < 2 * (acceptCountAux tm u x τ s ρ).length := by + rw [majorityFlag, notBit_eq_true_iff (lenLeFlag_flag _ _)] + constructor + · intro h + by_contra hcon + rw [Nat.not_lt] at hcon + have htrue : lenLeFlag ρ + (acceptCountAux tm u x τ s ρ ++ acceptCountAux tm u x τ s ρ) = [true] := by + rw [lenLeFlag_eq_true_iff, List.length_append] + omega + rw [htrue] at h + exact absurd h (by simp) + · intro h + rcases lenLeFlag_flag ρ + (acceptCountAux tm u x τ s ρ ++ acceptCountAux tm u x τ s ρ) with h' | h' + · rw [lenLeFlag_eq_true_iff, List.length_append] at h' + omega + · exact h' + +theorem majorityFlag_mem {n : ℕ} (tm : NTM k) + {gu gx gτ gs gρ : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hτ : Cobham gτ) (hs : Cobham gs) + (hρ : Cobham gρ) : + Cobham fun v : Fin n → List Bool => + majorityFlag tm (gu v) (gx v) (gτ v) (gs v) (gρ v) := + (notFn (lenLeFlag_mem hρ + (appendFn (acceptCountAux_mem tm hu hx hτ hs hρ) + (acceptCountAux_mem tm hu hx hτ hs hρ)))).of_eq fun _ => rfl + +/-- The verdict sought at a shift: the amplified majority, or its negation. -/ +noncomputable def verdictFlag (tm : NTM k) (b : Bool) (u x τ s ρ : List Bool) : + List Bool := + bif b then majorityFlag tm u x τ s ρ else notBit (majorityFlag tm u x τ s ρ) + +theorem verdictFlag_flag (tm : NTM k) (b : Bool) (u x τ s ρ : List Bool) : + verdictFlag tm b u x τ s ρ = [true] ∨ verdictFlag tm b u x τ s ρ = [false] := by + cases b + · rw [verdictFlag] + simp only [Bool.cond_false] + rcases majorityFlag_flag tm u x τ s ρ with h | h <;> rw [h] <;> simp [notBit] + · rw [verdictFlag] + simp only [Bool.cond_true] + exact majorityFlag_flag tm u x τ s ρ + +theorem verdictFlag_mem {n : ℕ} (tm : NTM k) (b : Bool) + {gu gx gτ gs gρ : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hτ : Cobham gτ) (hs : Cobham gs) + (hρ : Cobham gρ) : + Cobham fun v : Fin n → List Bool => + verdictFlag tm b (gu v) (gx v) (gτ v) (gs v) (gρ v) := by + cases b + · exact (notFn (majorityFlag_mem tm hu hx hτ hs hρ)).of_eq fun _ => rfl + · exact (majorityFlag_mem tm hu hx hτ hs hρ).of_eq fun _ => rfl + +/-! ## Disjunction over shifts -/ + +/-- Disjunction of the verdict over the shift blocks of `wit`: the recursion +runs once per bit of the shift ruler, and at each step the shift block is cut +from `wit` at the index given by the remaining tail. -/ +noncomputable def anyShiftAux (tm : NTM k) (b : Bool) (u x τ ρ σ r wit : List Bool) : + List Bool → List Bool + | [] => [false] + | _ :: y => + orBit (verdictFlag tm b u x τ (xorSuffix r (blockOf σ wit y)) ρ) + (anyShiftAux tm b u x τ ρ σ r wit y) + +theorem anyShiftAux_flag (tm : NTM k) (b : Bool) (u x τ ρ σ r wit ι : List Bool) : + anyShiftAux tm b u x τ ρ σ r wit ι = [true] ∨ + anyShiftAux tm b u x τ ρ σ r wit ι = [false] := by + induction ι with + | nil => exact Or.inr rfl + | cons β y ih => exact orBit_flag (verdictFlag_flag _ _ _ _ _ _ _) ih + +/-- **The disjunction is exactly an existential over shift indices.** -/ +theorem anyShiftAux_eq_true_iff (tm : NTM k) (b : Bool) + (u x τ ρ σ r wit ι : List Bool) : + anyShiftAux tm b u x τ ρ σ r wit ι = [true] ↔ + ∃ i < ι.length, + verdictFlag tm b u x τ (xorSuffix r (blockAtIdx σ.length wit i)) ρ = [true] := by + induction ι with + | nil => simp [anyShiftAux] + | cons β y ih => + rw [anyShiftAux, + orBit_eq_true_iff (verdictFlag_flag _ _ _ _ _ _ _) (anyShiftAux_flag _ _ _ _ _ _ _ _ _ _), + ih, List.length_cons] + rw [blockOf_eq] + constructor + · rintro (h | ⟨i, hi, hv⟩) + · exact ⟨y.length, by omega, h⟩ + · exact ⟨i, by omega, hv⟩ + · rintro ⟨i, hi, hv⟩ + rcases Nat.lt_or_ge i y.length with hlt | hge + · exact Or.inr ⟨i, hlt, hv⟩ + · have : i = y.length := by omega + subst this + exact Or.inl hv + +/-- The step of the shift recursion. -/ +private noncomputable def shiftStep (tm : NTM k) (b : Bool) (w : Fin 9 → List Bool) : + List Bool := + orBit (verdictFlag tm b (w 2) (w 3) (w 4) + (xorSuffix (w 7) (blockOf (w 6) (w 8) (w 0))) (w 5)) (w 1) + +private theorem shiftStep_mem (tm : NTM k) (b : Bool) : Cobham (shiftStep tm b) := + (orFn (verdictFlag_mem tm b (Cobham.proj 2) (Cobham.proj 3) (Cobham.proj 4) + (xorSuffix_mem (Cobham.proj 7) + (blockOf_mem (Cobham.proj 6) (Cobham.proj 8) (Cobham.proj 0))) + (Cobham.proj 5)) + (Cobham.proj 1)).of_eq fun _ => rfl + +private theorem recNotation_anyShift (tm : NTM k) (b : Bool) + (u x τ ρ σ r wit ι : List Bool) : + recNotation (fun _ : Fin 7 → List Bool => ([false] : List Bool)) (shiftStep tm b) + (shiftStep tm b) ι ![u, x, τ, ρ, σ, r, wit] + = anyShiftAux tm b u x τ ρ σ r wit ι := by + induction ι with + | nil => rfl + | cons β y ih => + rw [recNotation_cons, anyShiftAux] + cases β <;> + · show shiftStep tm b (Fin.cons y (Fin.cons _ ![u, x, τ, ρ, σ, r, wit])) = _ + rw [shiftStep] + show orBit (verdictFlag tm b u x τ (xorSuffix r (blockOf σ wit y)) ρ) + (recNotation (fun _ : Fin 7 → List Bool => ([false] : List Bool)) + (shiftStep tm b) (shiftStep tm b) y ![u, x, τ, ρ, σ, r, wit]) = _ + rw [ih] + +private theorem recNotation_anyShift_length (tm : NTM k) (b : Bool) (ι : List Bool) + (v : Fin 7 → List Bool) : + (recNotation (fun _ : Fin 7 → List Bool => ([false] : List Bool)) (shiftStep tm b) + (shiftStep tm b) ι v).length ≤ 1 := by + induction ι with + | nil => simp + | cons β y ih => + rw [recNotation_cons] + have hstep : ∀ (a c : List Bool) (w' : Fin 7 → List Bool), + (shiftStep tm b (Fin.cons a (Fin.cons c w'))).length ≤ 1 := by + intro a c w' + rw [shiftStep, orBit_length] + cases β <;> simpa using hstep y _ v + +/-- **The disjunction over shifts is in the algebra.** -/ +theorem anyShiftAux_mem {n : ℕ} (tm : NTM k) (b : Bool) + {gu gx gτ gρ gσ gr gwit gι : (Fin n → List Bool) → List Bool} + (hu : Cobham gu) (hx : Cobham gx) (hτ : Cobham gτ) (hρ : Cobham gρ) + (hσ : Cobham gσ) (hr : Cobham gr) (hwit : Cobham gwit) (hι : Cobham gι) : + Cobham fun v : Fin n → List Bool => + anyShiftAux tm b (gu v) (gx v) (gτ v) (gρ v) (gσ v) (gr v) (gwit v) (gι v) := by + have hrec := Cobham.boundedRec + (g := fun _ : Fin 7 → List Bool => ([false] : List Bool)) + (h₀ := shiftStep tm b) (h₁ := shiftStep tm b) + (j := fun _ : Fin 8 → List Bool => ([false] : List Bool)) + (Cobham.const _) (shiftStep_mem tm b) (shiftStep_mem tm b) (Cobham.const _) + (by + intro ι v + simpa using recNotation_anyShift_length tm b ι v) + have hg : ∀ i : Fin 8, Cobham (![gι, gu, gx, gτ, gρ, gσ, gr, gwit] i) := by + intro i + match i with + | 0 => exact hι + | 1 => exact hu + | 2 => exact hx + | 3 => exact hτ + | 4 => exact hρ + | 5 => exact hσ + | 6 => exact hr + | 7 => exact hwit + refine (Cobham.comp hrec hg).of_eq fun v => ?_ + have htail : (Fin.tail fun i => ![gι, gu, gx, gτ, gρ, gσ, gr, gwit] i v) + = ![gu v, gx v, gτ v, gρ v, gσ v, gr v, gwit v] := by + funext i + match i with + | 0 => rfl + | 1 => rfl + | 2 => rfl + | 3 => rfl + | 4 => rfl + | 5 => rfl + | 6 => rfl + show recNotation _ _ _ (gι v) (Fin.tail fun i => ![gι, gu, gx, gτ, gρ, gσ, gr, gwit] i v) = _ + rw [htail, recNotation_anyShift] + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean b/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean index 530518b0..a1bc6638 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/ChoiceSim.lean @@ -429,6 +429,11 @@ noncomputable def acceptChoiceFn (tm : NTM k) (u x c : List Bool) : List Bool := (matchPrefix (symCode Γ.one) (((outPairChoiceFn tm u x c).drop (clockRuler u).length).drop 2)) +/-- The verdict is a genuine one-bit flag. -/ +theorem acceptChoiceFn_flag (tm : NTM k) (u x c : List Bool) : + acceptChoiceFn tm u x c = [true] ∨ acceptChoiceFn tm u x c = [false] := + andBit_flag _ _ + /-- **The verdict is in the algebra.** -/ theorem acceptChoiceFn_mem {n : ℕ} (tm : NTM k) {gu gx gc : (Fin n → List Bool) → List Bool} diff --git a/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean b/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean index 9e9b683b..3fb6b3a8 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean @@ -50,6 +50,25 @@ theorem orBit_eq_true_iff {x y : List Bool} orBit x y = [true] ↔ x = [true] ∨ y = [true] := by rcases hx with rfl | rfl <;> rcases hy with rfl | rfl <;> simp [orBit] +/-- Disjunction of flags is a flag. -/ +theorem orBit_flag {x y : List Bool} + (hx : x = [true] ∨ x = [false]) (hy : y = [true] ∨ y = [false]) : + orBit x y = [true] ∨ orBit x y = [false] := by + rcases hx with rfl | rfl <;> rcases hy with rfl | rfl <;> simp [orBit] + +/-- A disjunction is always exactly one bit long. -/ +theorem orBit_length (x y : List Bool) : (orBit x y).length = 1 := by + rw [orBit] + rcases x with _ | ⟨a, x⟩ + · rcases y with _ | ⟨c, y⟩ + · rfl + · cases c <;> rfl + · cases a + · rcases y with _ | ⟨c, y⟩ + · rfl + · cases c <;> rfl + · rfl + /-- Negation of a flag. -/ theorem notBit_eq_true_iff {x : List Bool} (hx : x = [true] ∨ x = [false]) : notBit x = [true] ↔ x = [false] := by From dd35c35151fad0eb12db9d8bdc8aac7eb5ce9dfa Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 11:51:34 -0700 Subject: [PATCH 12/24] feat(PH): prove the Sipser-Lautemann theorem MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ` is now unconditional: `Complexity.sipserLautemann`, with `BPP_subset_SigmaP_two`, `BPP_subset_PiP_two` and `BPP_subset_PH`. The last interface, `MatrixVerdictInFP`, is discharged by computing the matrix verdict inside Cobham's algebra — no machine construction: - `SipserLautemann.Verdict` builds the rulers (per-trial step count, trial count, seed length and shift count as `smash` lengths from the polynomial time bound), decodes the triple with the payload scanners, and takes the disjunction over shift blocks of the majority vote over trial blocks; - `matrixFn_eq` proves that computation equals `matrixVerdict`, bridging the string view and the `Finset` counting view: `blockEventCount_seedOfList` matches the counts, `seedOfList_xorSuffix` and `seedOfList_padTo_block` match the exclusive-or with the shift action, and `pathAccepts_iff` matches a block's acceptance with membership in the single-trial event; - `matrixVerdict_mem_FP` concludes via `CobhamFP_subset_FP`. `Matrix` now decodes with `Cobham.fstBlock`/`sndBlock` rather than `unpair?`, so the matrix language and its verdict agree on every input, including malformed ones. Co-Authored-By: Claude Opus 5 (1M context) --- .../Classes/P/Cobham/Internal/BlockLoop.lean | 12 +- Complexitylib/Classes/PH/SipserLautemann.lean | 75 +++- .../Classes/PH/SipserLautemann/Matrix.lean | 121 +++--- .../Classes/PH/SipserLautemann/Verdict.lean | 383 ++++++++++++++++++ ROADMAP.md | 45 +- 5 files changed, 515 insertions(+), 121 deletions(-) create mode 100644 Complexitylib/Classes/PH/SipserLautemann/Verdict.lean diff --git a/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean b/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean index c50c5541..8a0a9a86 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean @@ -260,7 +260,7 @@ noncomputable def anyShiftAux (tm : NTM k) (b : Bool) (u x τ ρ σ r wit : List List Bool → List Bool | [] => [false] | _ :: y => - orBit (verdictFlag tm b u x τ (xorSuffix r (blockOf σ wit y)) ρ) + orBit (verdictFlag tm b u x τ (xorSuffix r (padTo σ (blockOf σ wit y))) ρ) (anyShiftAux tm b u x τ ρ σ r wit y) theorem anyShiftAux_flag (tm : NTM k) (b : Bool) (u x τ ρ σ r wit ι : List Bool) : @@ -275,7 +275,8 @@ theorem anyShiftAux_eq_true_iff (tm : NTM k) (b : Bool) (u x τ ρ σ r wit ι : List Bool) : anyShiftAux tm b u x τ ρ σ r wit ι = [true] ↔ ∃ i < ι.length, - verdictFlag tm b u x τ (xorSuffix r (blockAtIdx σ.length wit i)) ρ = [true] := by + verdictFlag tm b u x τ + (xorSuffix r (padTo σ (blockAtIdx σ.length wit i))) ρ = [true] := by induction ι with | nil => simp [anyShiftAux] | cons β y ih => @@ -298,12 +299,13 @@ theorem anyShiftAux_eq_true_iff (tm : NTM k) (b : Bool) private noncomputable def shiftStep (tm : NTM k) (b : Bool) (w : Fin 9 → List Bool) : List Bool := orBit (verdictFlag tm b (w 2) (w 3) (w 4) - (xorSuffix (w 7) (blockOf (w 6) (w 8) (w 0))) (w 5)) (w 1) + (xorSuffix (w 7) (padTo (w 6) (blockOf (w 6) (w 8) (w 0)))) (w 5)) (w 1) private theorem shiftStep_mem (tm : NTM k) (b : Bool) : Cobham (shiftStep tm b) := (orFn (verdictFlag_mem tm b (Cobham.proj 2) (Cobham.proj 3) (Cobham.proj 4) (xorSuffix_mem (Cobham.proj 7) - (blockOf_mem (Cobham.proj 6) (Cobham.proj 8) (Cobham.proj 0))) + (padFn (Cobham.proj 6) + (blockOf_mem (Cobham.proj 6) (Cobham.proj 8) (Cobham.proj 0)))) (Cobham.proj 5)) (Cobham.proj 1)).of_eq fun _ => rfl @@ -319,7 +321,7 @@ private theorem recNotation_anyShift (tm : NTM k) (b : Bool) cases β <;> · show shiftStep tm b (Fin.cons y (Fin.cons _ ![u, x, τ, ρ, σ, r, wit])) = _ rw [shiftStep] - show orBit (verdictFlag tm b u x τ (xorSuffix r (blockOf σ wit y)) ρ) + show orBit (verdictFlag tm b u x τ (xorSuffix r (padTo σ (blockOf σ wit y))) ρ) (recNotation (fun _ : Fin 7 → List Bool => ([false] : List Bool)) (shiftStep tm b) (shiftStep tm b) y ![u, x, τ, ρ, σ, r, wit]) = _ rw [ih] diff --git a/Complexitylib/Classes/PH/SipserLautemann.lean b/Complexitylib/Classes/PH/SipserLautemann.lean index 6baca838..97578a5d 100644 --- a/Complexitylib/Classes/PH/SipserLautemann.lean +++ b/Complexitylib/Classes/PH/SipserLautemann.lean @@ -7,6 +7,7 @@ module public import Complexitylib.Classes.P.DecisionFn public import Complexitylib.Classes.PH public import Complexitylib.Classes.PH.SipserLautemann.Matrix +public import Complexitylib.Classes.PH.SipserLautemann.Verdict /-! # The Sipser–Lautemann theorem @@ -16,12 +17,11 @@ probabilistic polynomial time inside the second level of the polynomial hierarchy: `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. This file states that containment against the library's concrete `BPP` (`Complexitylib.Classes.Randomized`) and the certificate-quantifier levels `SigmaP` / `PiP` (`Complexitylib.Classes.PH`), -and proves it from a single machine-engineering interface, `MatrixInP`. +and proves it: `sipserLautemann`. -## What is proved, and what is assumed +## How it is proved -Everything except one Turing-machine construction is proved here and in the -`SipserLautemann` subdirectory: +The development lives in the `SipserLautemann` subdirectory: - `Covering` — Lautemann's covering lemma in both directions, by counting shifts of an event in the seed space; @@ -33,20 +33,24 @@ Everything except one Turing-machine construction is proved here and in the - `Encode` — bitstring codecs for seeds and shift tuples; - `Matrix` — the quantifier-free matrix as a language of encoded triples, and the identity exhibiting `L` and `Lᶜ` as polynomially bounded `∃∀` forms over - it. - -The one interface left open is `MatrixInP`: the matrix language is decidable -in deterministic polynomial time. It is deliberately isolated rather than -assumed silently, and it is sharpened here to a statement about a *function*, -`MatrixVerdictInFP`, so that discharging it needs no machine construction — -`Complexitylib.Classes.P.Cobham`'s `CobhamFP_eq_FP` turns it into a -programming task in Cobham's algebra, and `mem_P_of_decisionFn_bool` converts -the result back. The verdict to compute is: parse the triple, recover the -per-trial step count from the input length, run the fixed machine on each -shifted seed, and take the majority vote. Running the machine along given -choice bits is exactly `NTM.choiceTM_simulates`. Note that the matrix is taken -at a *polynomial* time bound, which is what makes the step count recoverable -by a decider; `TimeBound` supplies the normalization. + it; +- `Verdict` — the matrix verdict as a member of Cobham's algebra, hence in + `FP`. + +What remained was the polynomial-time decidability of the matrix, isolated as +the interfaces `MatrixInP` and — as a statement about a *function* — +`MatrixVerdictInFP`. It is discharged by `matrixVerdictInFP` with no machine +construction at all: `CobhamFP_eq_FP` turns it into a programming task inside +Cobham's algebra, and `mem_P_of_decisionFn_bool` converts the result back to +`P`. The verdict is computed in `SipserLautemann.Verdict` — decode the triple +with the payload scanners, build the trial count and seed length as `smash` +lengths from the polynomial time bound, and take the disjunction over shift +blocks of the majority vote over trial blocks — with each trial one run of the +machine along the choice bits of its block, via `NTM.choiceTM` and its +in-algebra simulation in `Complexitylib.Classes.P.Cobham.Internal.ChoiceSim`. +The matrix is taken at a *polynomial* time bound, which is what makes the +per-trial step count computable from the input; `TimeBound` supplies the +normalization. ## Main definitions @@ -56,8 +60,12 @@ by a decider; `TimeBound` supplies the normalization. ## Main results -- `sipserLautemann_of_matrixInP`, `sipserLautemann_of_verdictInFP` — **the - theorem**, given either form of the interface +- `sipserLautemann` — **the theorem**, `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ` +- `BPP_subset_SigmaP_two`, `BPP_subset_PiP_two`, `BPP_subset_PH` — its halves + and the corollary +- `matrixVerdictInFP` — the matrix interface, discharged +- `sipserLautemann_of_matrixInP`, `sipserLautemann_of_verdictInFP` — the + theorem from either form of the interface - `matrixInP_of_verdictInFP` — the function form implies the language form - `mem_SigmaP_two_of_matrixInP`, `mem_PiP_two_of_matrixInP` — the two halves - `sipserLautemann_iff` — the statement splits into its `Σ₂` and `Π₂` halves @@ -183,4 +191,31 @@ theorem sipserLautemann_of_subset_SigmaP (hcompl : ∀ L ∈ BPP, Lᶜ ∈ BPP) theorem BPP_subset_PH_of_sipserLautemann (h : SipserLautemann) : BPP ⊆ PH := fun _ hL => SigmaP_subset_PH 2 (h hL).1 +/-- **The matrix interface holds.** The verdict is computed inside Cobham's +algebra — decode the triple with the payload scanners, build the trial count +and seed length as `smash` lengths from the time bound, and take the +disjunction over shift blocks of the majority vote over trial blocks, each +trial being one run of the machine along the choice bits of its block — and +`CobhamFP_eq_FP` makes that a polynomial-time function. -/ +theorem matrixVerdictInFP : MatrixVerdictInFP := + fun _ tm pt b => Lautemann.matrixVerdict_mem_FP tm pt b + +/-- **The Sipser–Lautemann theorem**: bounded-error probabilistic polynomial +time lies in the second level of the polynomial hierarchy, +`BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ` (Arora–Barak Theorem 7.15). -/ +theorem sipserLautemann : SipserLautemann := + sipserLautemann_of_verdictInFP matrixVerdictInFP + +/-- `BPP ⊆ Σ₂ᵖ`. -/ +theorem BPP_subset_SigmaP_two : BPP ⊆ SigmaP 2 := + BPP_subset_SigmaP_two_of_sipserLautemann sipserLautemann + +/-- `BPP ⊆ Π₂ᵖ`. -/ +theorem BPP_subset_PiP_two : BPP ⊆ PiP 2 := + BPP_subset_PiP_two_of_sipserLautemann sipserLautemann + +/-- **`BPP` lies inside the polynomial hierarchy.** -/ +theorem BPP_subset_PH : BPP ⊆ PH := + BPP_subset_PH_of_sipserLautemann sipserLautemann + end Complexity diff --git a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean index 4e2af6b6..638ae476 100644 --- a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean +++ b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean @@ -5,6 +5,7 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.PH +public import Complexitylib.Classes.P.Cobham.Internal.BlockScan public import Complexitylib.Classes.PH.SipserLautemann.Amplified public import Complexitylib.Classes.PH.SipserLautemann.Encode public import Complexitylib.Classes.PH.SipserLautemann.TimeBound @@ -51,93 +52,71 @@ variable {k : ℕ} /-! ## The matrix language -/ +/-- The quantifier-free predicate of the Lautemann characterization, on the +three decoded components. -/ +def matrixPred (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : Prop := + r.length = ampRuns f x.length * f x.length → + ∃ i : Fin (ampShifts f x.length), + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) + (shift (seedOfList (ampRuns f x.length * f x.length) r) + (shiftsOfList (ampShifts f x.length) + (ampRuns f x.length * f x.length) w i)) = b + +/-- The same predicate as a `Bool`-valued verdict. -/ +noncomputable def matrixVerdictOn (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : + Bool := + if r.length = ampRuns f x.length * f x.length then + decide (∃ i : Fin (ampShifts f x.length), + blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) + (shift (seedOfList (ampRuns f x.length * f x.length) r) + (shiftsOfList (ampShifts f x.length) + (ampRuns f x.length * f x.length) w i)) = b) + else true + +/-- The verdict decides the predicate. -/ +theorem matrixVerdictOn_eq_true_iff (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : + matrixVerdictOn tm f b x w r = true ↔ matrixPred tm f b x w r := by + rw [matrixVerdictOn, matrixPred] + by_cases h : r.length = ampRuns f x.length * f x.length + · rw [if_pos h] + simp [h] + · rw [if_neg h] + simp [h] + /-- The innermost predicate of the Lautemann characterization, as a language of -encoded triples. On `z = pair (pair x w) r` with `r` a well-formed seed, it -holds when some shift decoded from `w` carries the seed decoded from `r` to a -seed whose amplified majority verdict is `b`. Malformed `z`, and seeds of the -wrong length, are in the language. -/ +encoded triples. The components are decoded with the polynomial-time payload +scanners `Cobham.fstBlock` and `Cobham.sndBlock`, which recover them from a +canonical pair; on malformed input the decoders return their partial reads, and +the language's contents there are irrelevant to the `Σ₂` identity below. -/ def matrixLang (tm : NTM k) (f : ℕ → ℕ) (b : Bool) : Language := - {z | ∀ x w r, z = pair (pair x w) r → - r.length = ampRuns f x.length * f x.length → - ∃ i : Fin (ampShifts f x.length), - blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) - (shift (seedOfList (ampRuns f x.length * f x.length) r) - (shiftsOfList (ampShifts f x.length) - (ampRuns f x.length * f x.length) w i)) = b} + {z | matrixPred tm f b (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)) (Cobham.sndBlock z)} /-- Membership of an encoded triple in the matrix language. -/ theorem mem_matrixLang_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : - pair (pair x w) r ∈ matrixLang tm f b ↔ - (r.length = ampRuns f x.length * f x.length → - ∃ i : Fin (ampShifts f x.length), - blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) - (shift (seedOfList (ampRuns f x.length * f x.length) r) - (shiftsOfList (ampShifts f x.length) - (ampRuns f x.length * f x.length) w i)) = b) := by - constructor - · intro h - exact h x w r rfl - · intro h x' w' r' hz - obtain ⟨hy, hr⟩ := pair_inj hz - obtain ⟨hx, hw⟩ := pair_inj hy - subst hx - subst hw - subst hr - exact h - -/-- The matrix as a `Bool`-valued verdict function. The definition mirrors -`matrixLang` through the pair decoder, so it is total and its equivalence with -the language is immediate; it is stated this way so that the remaining + pair (pair x w) r ∈ matrixLang tm f b ↔ matrixPred tm f b x w r := by + rw [matrixLang] + simp + +/-- The matrix as a `Bool`-valued verdict function, so that the remaining polynomial-time obligation is about a *function*, which `Complexitylib.Classes.P.Cobham` can discharge inside Cobham's algebra without constructing a machine. -/ noncomputable def matrixVerdict (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (z : List Bool) : Bool := - match unpair? z with - | none => true - | some (y, r) => - match unpair? y with - | none => true - | some (x, w) => - if r.length = ampRuns f x.length * f x.length then - decide (∃ i : Fin (ampShifts f x.length), - blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) - (shift (seedOfList (ampRuns f x.length * f x.length) r) - (shiftsOfList (ampShifts f x.length) - (ampRuns f x.length * f x.length) w i)) = b) - else true + matrixVerdictOn tm f b (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)) (Cobham.sndBlock z) /-- The verdict function on an encoded triple. -/ @[simp] theorem matrixVerdict_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : - matrixVerdict tm f b (pair (pair x w) r) = - (if r.length = ampRuns f x.length * f x.length then - decide (∃ i : Fin (ampShifts f x.length), - blockMajority (NTM.repeatAcceptEvent tm x (f x.length)) - (shift (seedOfList (ampRuns f x.length * f x.length) r) - (shiftsOfList (ampShifts f x.length) - (ampRuns f x.length * f x.length) w i)) = b) - else true) := by - simp [matrixVerdict] + matrixVerdict tm f b (pair (pair x w) r) = matrixVerdictOn tm f b x w r := by + rw [matrixVerdict] + simp /-- The verdict function decides the matrix language. -/ theorem mem_matrixLang_iff_verdict (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (z : List Bool) : z ∈ matrixLang tm f b ↔ matrixVerdict tm f b z = true := by - constructor - · intro h - rcases hz : unpair? z with _ | ⟨y, r⟩ - · simp [matrixVerdict, hz] - · rcases hy : unpair? y with _ | ⟨x, w⟩ - · simp [matrixVerdict, hz, hy] - · have hzeq : z = pair (pair x w) r := by - rw [unpair?_eq_some_iff] at hz hy - rw [hz, hy] - subst hzeq - by_cases hlen : r.length = ampRuns f x.length * f x.length - · simpa [hlen] using h x w r rfl hlen - · simp [hlen] - · intro h x w r hz hlen - subst hz - rw [matrixVerdict_pair] at h - simpa [hlen] using h + rw [matrixLang, matrixVerdict, matrixVerdictOn_eq_true_iff] + rfl /-! ## The `Σ₂` form -/ diff --git a/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean b/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean new file mode 100644 index 00000000..fe5a090e --- /dev/null +++ b/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.SndBlock +public import Complexitylib.Classes.P.Cobham.Internal.BlockLoop +public import Complexitylib.Classes.PH.SipserLautemann.Matrix + +/-! +# Bridging the string computation and the counting definitions + +The amplified verdict is defined by counting blocks of a seed *function* +`Fin (k * T) → Bool` inside a `Finset`; the algebra computes with the seed as a +*string*. This file identifies the two views: a block of the string decodes to +the corresponding block of the function, so the algebra's unary count is the +`blockEventCount` of the amplification lemmas. + +## Main results + +- `Lautemann.getD_take_drop` — reading inside a block of a string +- `Lautemann.seedOfList_blockAtIdx` — the decoded block is the function's block +- `Lautemann.blockEventCount_seedOfList` — the two counts agree +-/ + +@[expose] public section + +namespace Complexity + +namespace Lautemann + +variable {k : ℕ} + +/-- Reading inside a block of a string reads the underlying string. -/ +theorem getD_take_drop (s : List Bool) (a b j : ℕ) (hj : j < b) : + ((s.drop a).take b).getD j false = s.getD (a + j) false := by + rw [List.getD, List.getD, List.getElem?_take_of_lt hj, List.getElem?_drop] + +/-- The block of a decoded seed is the decoding of the block of the string. -/ +theorem seedOfList_blockAtIdx (T : ℕ) (s : List Bool) (i : ℕ) (t : Fin T) : + seedOfList T (Cobham.blockAtIdx T s i) t = s.getD (i * T + t.val) false := by + rw [seedOfList, Cobham.blockAtIdx] + exact getD_take_drop s (i * T) T t.val t.isLt + +/-- The blocks of a decoded long seed are the decodings of its string blocks. -/ +theorem blocksEquiv_seedOfList (runs T : ℕ) (s : List Bool) (i : Fin runs) : + blocksEquiv runs T (seedOfList (runs * T) s) i + = seedOfList T (Cobham.blockAtIdx T s i.val) := by + funext t + rw [blocksEquiv_apply, seedOfList_blockAtIdx, seedOfList] + congr 1 + show t.val + T * i.val = i.val * T + t.val + rw [Nat.mul_comm] + omega + +/-- Path acceptance is membership of the decoded choice string in the +single-trial accepting event. -/ +theorem pathAccepts_iff (tm : NTM k) (x c : List Bool) : + Cobham.PathAccepts tm x c + ↔ seedOfList c.length c ∈ NTM.repeatAcceptEvent tm x c.length := by + have hfun : (fun j : Fin c.length => c[j.val]'j.isLt) = seedOfList c.length c := by + funext j + rw [seedOfList, List.getD, List.getElem?_eq_getElem j.isLt, Option.getD_some] + rw [Cobham.PathAccepts, hfun, NTM.repeatAcceptEvent] + simp + +/-- The block count of a decoded seed is a sum over block indices. -/ +theorem blockEventCount_seedOfList {T : ℕ} (E : Finset (Fin T → Bool)) (runs : ℕ) + (s : List Bool) : + blockEventCount E (seedOfList (runs * T) s) + = ∑ j ∈ Finset.range runs, + (if seedOfList T (Cobham.blockAtIdx T s j) ∈ E then 1 else 0) := by + rw [blockEventCount, Finset.card_filter, ← Fin.sum_univ_eq_sum_range + (fun j => if seedOfList T (Cobham.blockAtIdx T s j) ∈ E then 1 else 0) runs] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [blocksEquiv_seedOfList] + +/-- Inside a seed of exactly `runs` blocks, every block is full. -/ +theorem blockAtIdx_length (T : ℕ) (s : List Bool) (j runs : ℕ) + (hs : s.length = runs * T) (hj : j < runs) : + (Cobham.blockAtIdx T s j).length = T := by + have hmul : j * T + T ≤ runs * T := by + have h := Nat.mul_le_mul_right T (Nat.succ_le_of_lt hj) + rwa [Nat.succ_mul] at h + rw [Cobham.blockAtIdx, List.length_take, List.length_drop, hs] + omega + +/-- **The algebra's count is the amplification lemmas' block count.** -/ +theorem acceptCountAux_length_eq (tm : NTM k) (u x τ s ρ : List Bool) (runs : ℕ) + (hρ : ρ.length = runs) (hs : s.length = runs * τ.length) + (hu : x.length + τ.length + Fintype.card tm.Q + 3 ≤ u.length) : + (Cobham.acceptCountAux tm u x τ s ρ).length + = blockEventCount (NTM.repeatAcceptEvent tm x τ.length) + (seedOfList (runs * τ.length) s) := by + rw [Cobham.acceptCountAux_length, blockEventCount_seedOfList, hρ] + refine Finset.sum_congr rfl fun j hj => ?_ + rw [Finset.mem_range] at hj + have hblen : (Cobham.blockAtIdx τ.length s j).length = τ.length := + blockAtIdx_length τ.length s j runs hs hj + have hacc : Cobham.acceptChoiceFn tm u x (Cobham.blockAtIdx τ.length s j) = [true] + ↔ seedOfList τ.length (Cobham.blockAtIdx τ.length s j) + ∈ NTM.repeatAcceptEvent tm x τ.length := by + rw [Cobham.acceptChoiceFn_eq_true_iff tm u x (Cobham.blockAtIdx τ.length s j) + (by rw [hblen]; omega), pathAccepts_iff, hblen] + by_cases h : Cobham.acceptChoiceFn tm u x (Cobham.blockAtIdx τ.length s j) = [true] + · rw [if_pos h, if_pos (hacc.mp h)] + · rw [if_neg h, if_neg (fun hmem => h (hacc.mpr hmem))] + +/-- **The algebra's majority flag is the amplified majority verdict.** -/ +theorem majorityFlag_eq_true_iff' (tm : NTM k) (u x τ s ρ : List Bool) (runs : ℕ) + (hρ : ρ.length = runs) (hs : s.length = runs * τ.length) + (hu : x.length + τ.length + Fintype.card tm.Q + 3 ≤ u.length) : + Cobham.majorityFlag tm u x τ s ρ = [true] + ↔ blockMajority (NTM.repeatAcceptEvent tm x τ.length) + (seedOfList (runs * τ.length) s) = true := by + rw [Cobham.majorityFlag_eq_true_iff, acceptCountAux_length_eq tm u x τ s ρ runs hρ hs hu, + hρ, blockMajority] + simp only [decide_eq_true_eq] + +/-! ## The shift action -/ + +/-- Reading inside a padded block reads the block. -/ +theorem getD_padTo (σ b : List Bool) (j : ℕ) (hj : j < σ.length) : + (padTo σ b).getD j false = b.getD j false := by + rcases Nat.lt_or_ge j b.length with hb | hb + · rw [padTo, List.getD, List.getD, List.getElem?_take_of_lt hj, + List.getElem?_append_left hb] + · have h1 : (padTo σ b)[j]? = some false := by + rw [padTo, List.getElem?_take_of_lt hj, + List.getElem?_append_right hb, List.getElem?_replicate] + rw [if_pos (by omega)] + rw [List.getD, h1, List.getD, List.getElem?_eq_none hb] + rfl + +/-- The decoded exclusive-or is the shift action on decoded seeds. -/ +theorem seedOfList_xorSuffix (m : ℕ) (r blk : List Bool) (hr : r.length = m) + (hblk : blk.length = m) : + seedOfList m (Cobham.xorSuffix r blk) = shift (seedOfList m r) (seedOfList m blk) := by + funext j + rw [Cobham.xorSuffix_eq_zipWith_of_length r blk (by omega), shift, seedOfList, + seedOfList, seedOfList] + have hj : j.val < (List.zipWith xor r blk).length := by + rw [List.length_zipWith] + omega + have hjr : j.val < r.length := by omega + have hjb : j.val < blk.length := by omega + rw [List.getD, List.getElem?_eq_getElem hj, Option.getD_some, List.getElem_zipWith, + List.getD, List.getElem?_eq_getElem hjr, Option.getD_some, + List.getD, List.getElem?_eq_getElem hjb, Option.getD_some] + +/-- The decoded padded block is the decoded shift vector. -/ +theorem seedOfList_padTo_block (t m : ℕ) (σ w : List Bool) (hσ : σ.length = m) + (i : Fin t) : + seedOfList m (padTo σ (Cobham.blockAtIdx m w i.val)) + = shiftsOfList t m w i := by + funext j + rw [seedOfList, shiftsOfList, getD_padTo σ _ j.val (by rw [hσ]; exact j.isLt), + Cobham.blockAtIdx, getD_take_drop w (i.val * m) m j.val j.isLt] + +/-! ## The rulers -/ + +/-- The clock string for the path simulations: long enough for every block. -/ +noncomputable def clockStr (pt : Polynomial ℕ) (q : ℕ) (x : List Bool) : List Bool := + x ++ (Cobham.polyLen pt x ++ List.replicate (q + 3) false) + +@[simp] theorem clockStr_length (pt : Polynomial ℕ) (q : ℕ) (x : List Bool) : + (clockStr pt q x).length = x.length + pt.eval x.length + (q + 3) := by + rw [clockStr, List.length_append, List.length_append, Cobham.polyLen_length, + List.length_replicate] + omega + +/-- The ruler whose length is the number of amplification trials. -/ +noncomputable def runsStr (pt : Polynomial ℕ) (x : List Bool) : List Bool := + List.replicate 133 false + ++ Complexity.smash (List.replicate 12 false) (Cobham.polyLen pt x) + +@[simp] theorem runsStr_length (pt : Polynomial ℕ) (x : List Bool) : + (runsStr pt x).length = ampRuns pt.eval x.length := by + rw [runsStr, List.length_append, List.length_replicate, smash_length, + List.length_replicate, Cobham.polyLen_length, ampRuns, ampExp] + ring + +/-- The ruler whose length is the amplified seed length. -/ +noncomputable def seedStr (pt : Polynomial ℕ) (x : List Bool) : List Bool := + Complexity.smash (runsStr pt x) (Cobham.polyLen pt x) + +@[simp] theorem seedStr_length (pt : Polynomial ℕ) (x : List Bool) : + (seedStr pt x).length = ampRuns pt.eval x.length * pt.eval x.length := by + rw [seedStr, smash_length, runsStr_length, Cobham.polyLen_length] + +/-- The ruler whose length is the number of shifts. -/ +noncomputable def shiftStr (pt : Polynomial ℕ) (x : List Bool) : List Bool := + false :: seedStr pt x + +@[simp] theorem shiftStr_length (pt : Polynomial ℕ) (x : List Bool) : + (shiftStr pt x).length = ampShifts pt.eval x.length := by + rw [shiftStr, List.length_cons, seedStr_length, ampShifts] + +/-! ## The verdict as an algebra function -/ + +/-- The matrix verdict, computed from the decoded components with the rulers +above: check the seed's length, then take the disjunction over shift blocks of +the amplified majority verdict. -/ +noncomputable def matrixFn (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) (z : List Bool) : + List Bool := + caseBit₀ + (Cobham.lenEqFlag (Cobham.sndBlock z) + (seedStr pt (Cobham.fstBlock (Cobham.fstBlock z)))) + (Cobham.anyShiftAux tm b + (clockStr pt (Fintype.card tm.Q) (Cobham.fstBlock (Cobham.fstBlock z))) + (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.polyLen pt (Cobham.fstBlock (Cobham.fstBlock z))) + (runsStr pt (Cobham.fstBlock (Cobham.fstBlock z))) + (seedStr pt (Cobham.fstBlock (Cobham.fstBlock z))) + (Cobham.sndBlock z) (Cobham.sndBlock (Cobham.fstBlock z)) + (shiftStr pt (Cobham.fstBlock (Cobham.fstBlock z)))) + [true] + +/-- A flag matching a Boolean, in the two polarities. -/ +private theorem flag_iff_bool {fl : List Bool} {c b : Bool} + (hflag : fl = [true] ∨ fl = [false]) (h : fl = [true] ↔ c = true) : + (bif b then fl else notBit fl) = [true] ↔ c = b := by + cases b + · rw [Bool.cond_false, Cobham.notBit_eq_true_iff hflag] + rcases hflag with hf | hf + · have hc : c = true := h.mp hf + rw [hf, hc] + simp + · rw [hf] + simp only [true_iff] + cases hc : c + · rfl + · rw [hc] at h + exact absurd (h.mpr rfl) (by rw [hf]; simp) + · rw [Bool.cond_true] + exact h + +/-- **The per-shift verdict is the amplified majority at that shift.** -/ +theorem verdictFlag_shift_iff (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) + (x w r : List Bool) + (hr : r.length = ampRuns pt.eval x.length * pt.eval x.length) + (i : Fin (ampShifts pt.eval x.length)) : + Cobham.verdictFlag tm b (clockStr pt (Fintype.card tm.Q) x) x (Cobham.polyLen pt x) + (Cobham.xorSuffix r (padTo (seedStr pt x) + (Cobham.blockAtIdx (seedStr pt x).length w i.val))) (runsStr pt x) = [true] + ↔ blockMajority (NTM.repeatAcceptEvent tm x (pt.eval x.length)) + (shift (seedOfList (ampRuns pt.eval x.length * pt.eval x.length) r) + (shiftsOfList (ampShifts pt.eval x.length) + (ampRuns pt.eval x.length * pt.eval x.length) w i)) = b := by + have hσ : (seedStr pt x).length = ampRuns pt.eval x.length * pt.eval x.length := + seedStr_length pt x + have hblk : Cobham.blockAtIdx (seedStr pt x).length w i.val + = Cobham.blockAtIdx (ampRuns pt.eval x.length * pt.eval x.length) w i.val := by + rw [hσ] + have hslen : (Cobham.xorSuffix r (padTo (seedStr pt x) + (Cobham.blockAtIdx (seedStr pt x).length w i.val))).length + = ampRuns pt.eval x.length * pt.eval x.length := by + rw [Cobham.xorSuffix_length, hr] + have hseed : seedOfList (ampRuns pt.eval x.length * pt.eval x.length) + (Cobham.xorSuffix r (padTo (seedStr pt x) + (Cobham.blockAtIdx (seedStr pt x).length w i.val))) + = shift (seedOfList (ampRuns pt.eval x.length * pt.eval x.length) r) + (shiftsOfList (ampShifts pt.eval x.length) + (ampRuns pt.eval x.length * pt.eval x.length) w i) := by + rw [hblk, seedOfList_xorSuffix _ r _ hr (by rw [padTo_length, hσ]), + seedOfList_padTo_block (ampShifts pt.eval x.length) + (ampRuns pt.eval x.length * pt.eval x.length) (seedStr pt x) w hσ i] + have hmaj := majorityFlag_eq_true_iff' tm (clockStr pt (Fintype.card tm.Q) x) x + (Cobham.polyLen pt x) + (Cobham.xorSuffix r (padTo (seedStr pt x) + (Cobham.blockAtIdx (seedStr pt x).length w i.val))) + (runsStr pt x) (ampRuns pt.eval x.length) (runsStr_length pt x) + (by rw [hslen, Cobham.polyLen_length]) + (by rw [clockStr_length, Cobham.polyLen_length]; omega) + rw [Cobham.polyLen_length] at hmaj + rw [hseed] at hmaj + exact flag_iff_bool (Cobham.majorityFlag_flag _ _ _ _ _ _) hmaj + +/-- The verdict computation on the three decoded components. -/ +private theorem matrixFn_aux (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) (x w r : List Bool) : + caseBit₀ (Cobham.lenEqFlag r (seedStr pt x)) + (Cobham.anyShiftAux tm b (clockStr pt (Fintype.card tm.Q) x) x (Cobham.polyLen pt x) + (runsStr pt x) (seedStr pt x) r w (shiftStr pt x)) [true] + = [matrixVerdictOn tm pt.eval b x w r] := by + rw [matrixVerdictOn] + by_cases hlen : r.length = ampRuns pt.eval x.length * pt.eval x.length + · have hflag : Cobham.lenEqFlag r (seedStr pt x) = [true] := by + rw [Cobham.lenEqFlag_eq_true_iff, seedStr_length] + exact hlen + rw [hflag, if_pos hlen, caseBit₀_cons, cond_true] + have hiff : Cobham.anyShiftAux tm b (clockStr pt (Fintype.card tm.Q) x) x + (Cobham.polyLen pt x) (runsStr pt x) (seedStr pt x) r w (shiftStr pt x) = [true] + ↔ ∃ i : Fin (ampShifts pt.eval x.length), + blockMajority (NTM.repeatAcceptEvent tm x (pt.eval x.length)) + (shift (seedOfList (ampRuns pt.eval x.length * pt.eval x.length) r) + (shiftsOfList (ampShifts pt.eval x.length) + (ampRuns pt.eval x.length * pt.eval x.length) w i)) = b := by + rw [Cobham.anyShiftAux_eq_true_iff, shiftStr_length] + constructor + · rintro ⟨i, hi, hv⟩ + exact ⟨⟨i, hi⟩, (verdictFlag_shift_iff tm pt b x w r hlen ⟨i, hi⟩).mp hv⟩ + · rintro ⟨i, hb⟩ + exact ⟨i.val, i.isLt, (verdictFlag_shift_iff tm pt b x w r hlen i).mpr hb⟩ + rcases Cobham.anyShiftAux_flag tm b (clockStr pt (Fintype.card tm.Q) x) x + (Cobham.polyLen pt x) (runsStr pt x) (seedStr pt x) r w (shiftStr pt x) with h | h + · rw [h, decide_eq_true (hiff.mp h)] + · rw [h, decide_eq_false ?_] + intro hex + rw [hiff.mpr hex] at h + exact absurd h (by simp) + · have hflag : Cobham.lenEqFlag r (seedStr pt x) = [false] := by + rcases Cobham.lenEqFlag_flag r (seedStr pt x) with h | h + · rw [Cobham.lenEqFlag_eq_true_iff, seedStr_length] at h + exact absurd h hlen + · exact h + rw [hflag, if_neg hlen, caseBit₀_cons, cond_false] + +/-- **The algebra function computes the matrix verdict.** -/ +theorem matrixFn_eq (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) (z : List Bool) : + matrixFn tm pt b z = [matrixVerdict tm pt.eval b z] := + matrixFn_aux tm pt b _ _ _ + +/-! ## Membership in the algebra -/ + +/-- The pair decoders are in the algebra, being polynomial-time. -/ +theorem fstBlock_cobham {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => Cobham.fstBlock (g v) := + (Cobham.comp (FP_subset_CobhamFP Cobham.fstBlock_mem_FP) + fun _ : Fin 1 => hg).of_eq fun _ => rfl + +theorem sndBlock_cobham {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => Cobham.sndBlock (g v) := + (Cobham.comp (FP_subset_CobhamFP Cobham.sndBlock_mem_FP) + fun _ : Fin 1 => hg).of_eq fun _ => rfl + +theorem clockStr_mem {n : ℕ} (pt : Polynomial ℕ) (q : ℕ) + {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => clockStr pt q (g v) := + (Cobham.appendFn hg + (Cobham.appendFn (Cobham.polyLen_mem pt hg) (Cobham.const _))).of_eq fun _ => rfl + +theorem runsStr_mem {n : ℕ} (pt : Polynomial ℕ) + {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => runsStr pt (g v) := + (Cobham.appendFn (Cobham.const _) + (Cobham.comp₂ Cobham.smash (Cobham.const _) (Cobham.polyLen_mem pt hg))).of_eq fun _ => rfl + +theorem seedStr_mem {n : ℕ} (pt : Polynomial ℕ) + {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => seedStr pt (g v) := + (Cobham.comp₂ Cobham.smash (runsStr_mem pt hg) (Cobham.polyLen_mem pt hg)).of_eq fun _ => rfl + +theorem shiftStr_mem {n : ℕ} (pt : Polynomial ℕ) + {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => shiftStr pt (g v) := + (Cobham.comp (Cobham.bit false) fun _ : Fin 1 => seedStr_mem pt hg).of_eq fun _ => rfl + +/-- **The matrix verdict is in the algebra.** -/ +theorem matrixFn_mem (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) : + Cobham fun v : Fin 1 → List Bool => matrixFn tm pt b (v 0) := by + have hz : Cobham fun v : Fin 1 → List Bool => v 0 := Cobham.proj 0 + have hx : Cobham fun v : Fin 1 → List Bool => + Cobham.fstBlock (Cobham.fstBlock (v 0)) := fstBlock_cobham (fstBlock_cobham hz) + have hw : Cobham fun v : Fin 1 → List Bool => + Cobham.sndBlock (Cobham.fstBlock (v 0)) := sndBlock_cobham (fstBlock_cobham hz) + have hr : Cobham fun v : Fin 1 → List Bool => Cobham.sndBlock (v 0) := sndBlock_cobham hz + exact (Cobham.iteFn (Cobham.lenEqFlag_mem hr (seedStr_mem pt hx)) + (Cobham.anyShiftAux_mem tm b (clockStr_mem pt (Fintype.card tm.Q) hx) hx + (Cobham.polyLen_mem pt hx) (runsStr_mem pt hx) (seedStr_mem pt hx) hr hw + (shiftStr_mem pt hx)) + (Cobham.const [true])).of_eq fun _ => rfl + +/-- **The matrix verdict is polynomial-time computable.** -/ +theorem matrixVerdict_mem_FP (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) : + (fun z => [matrixVerdict tm pt.eval b z]) ∈ FP := + CobhamFP_subset_FP ((matrixFn_mem tm pt b).of_eq fun v => matrixFn_eq tm pt b (v 0)) + +end Lautemann + +end Complexity diff --git a/ROADMAP.md b/ROADMAP.md index 4dd1fe7b..036881ed 100644 --- a/ROADMAP.md +++ b/ROADMAP.md @@ -1976,31 +1976,26 @@ randomness, interaction, and lower bounds. definition is `Complexitylib.Classes.PH`: `SigmaP`, `PiP`, `PH`, quantifier duality, and the level inclusions relative to the `pairFst ∈ FP` seam. Oracle levels and the equivalence remain.)* -- [~] Prove the Sipser--Lautemann theorem `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. - *(`Complexitylib.Classes.PH.SipserLautemann`: proved from the single interface - `MatrixInP`. Unconditional so far: Lautemann's covering lemma in both - directions (`SipserLautemann.Covering`), the freeze of acceptance probability - past the halting time, which replaces a machine's arbitrary time bound by a - dominating polynomial (`SipserLautemann.TimeBound`), the amplified `∃∀` - characterization of `L` and of its complement (`SipserLautemann.Amplified`), - the seed/shift bitstring codecs (`SipserLautemann.Encode`), and the identity - exhibiting `L` and `Lᶜ` as polynomially bounded `∃∀` forms over the matrix - language (`SipserLautemann.Matrix`). What remains is `MatrixVerdictInFP`: - the matrix verdict function — parse the encoded triple, recover the - per-trial step count from the input length, run the fixed machine on each - shifted seed, take the majority vote — is in `FP`. By `CobhamFP_eq_FP` that - is a programming task in Cobham's algebra rather than a machine - construction, and `mem_P_of_decisionFn_bool` converts the result back to - `P`. The path semantics it needs are already available: - `NTM.choiceTM_simulates` runs one nondeterministic path deterministically - from a choice tape, so `Cobham.stepFn (NTM.choiceTM tm)` is the step - function to iterate; the missing piece is an initial-configuration encoder - that places the choice string on that tape with its head at cell 1, in the - style of `Cobham.initFn_mem`. The same primitive discharges - `NP.WitnessNTMConstruction`.)* -- [~] Define `#P`, `GapP`, and parsimonious reductions using exact accepting-path - counts. *(`#P` = `SharpP` and `GapP` (with `GapP.neg_mem`) in - `Complexitylib.Classes.SharpP` done; parsimonious reductions remain.)* +- [x] Prove the Sipser--Lautemann theorem `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ` + (`Complexitylib.Classes.PH.SipserLautemann`: `sipserLautemann`, with + `BPP_subset_SigmaP_two`, `BPP_subset_PiP_two` and `BPP_subset_PH`). + Unconditional. The development: Lautemann's covering lemma in both + directions (`SipserLautemann.Covering`); the freeze of acceptance + probability past the halting time, which replaces a machine's arbitrary time + bound by a dominating polynomial (`SipserLautemann.TimeBound`); the + amplified `∃∀` characterization of `L` and of its complement + (`SipserLautemann.Amplified`); the seed/shift codecs + (`SipserLautemann.Encode`); the identity exhibiting `L` and `Lᶜ` as + polynomially bounded `∃∀` forms over the matrix language + (`SipserLautemann.Matrix`); and the matrix verdict as a member of Cobham's + algebra (`SipserLautemann.Verdict`), which discharges the polynomial-time + obligation with no machine construction. Supporting additions: + `NTM.choiceTM` runs one nondeterministic path deterministically from a + choice tape (`Complexitylib.Models.TuringMachine.ChoiceTape`), simulated + inside the algebra by `Complexitylib.Classes.P.Cobham.Internal.ChoiceSim` + and `.BlockLoop`; `mem_P_of_decisionFn_bool` + (`Complexitylib.Classes.P.DecisionFn`) turns a verdict function in `FP` into + membership in `P`. - [ ] Prove elementary closure properties and relate PP to GapP sign. - [ ] Formalize `PH subset P^#P`/Toda-style results only after polynomial interpolation and modular counting are available. From af6a8d9a3d31ba4823ab81504beecfeb23450786 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 12:04:24 -0700 Subject: [PATCH 13/24] docs(PH): flag the Sipser-Lautemann development as unreviewed Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes/PH/SipserLautemann.lean | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Complexitylib/Classes/PH/SipserLautemann.lean b/Complexitylib/Classes/PH/SipserLautemann.lean index 97578a5d..75d0fd06 100644 --- a/Complexitylib/Classes/PH/SipserLautemann.lean +++ b/Complexitylib/Classes/PH/SipserLautemann.lean @@ -12,6 +12,8 @@ public import Complexitylib.Classes.PH.SipserLautemann.Verdict /-! # The Sipser–Lautemann theorem +⚠️ Unreviewed by Bolton + The Sipser–Lautemann theorem (Arora–Barak Theorem 7.15) places bounded-error probabilistic polynomial time inside the second level of the polynomial hierarchy: `BPP ⊆ Σ₂ᵖ ∩ Π₂ᵖ`. This file states that containment against the From 7dd84c149b18fff28b8e46951d3d1b3113809248 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Wed, 19 Aug 2026 16:02:23 -0700 Subject: [PATCH 14/24] feat(classes): define the interactive proof classes MA, AM, and IP MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A verifier is a language in `P` — a polynomial-time predicate — applied to the encoded tuple it sees, with private coins measured by `eventProb`, so the definitions stay machine-free and auditable. - `MA` — Merlin's proof cannot depend on the coins, so the existential sits outside the probability; - `AM` — Arthur's public coins come first, so the existential over Merlin's reply sits inside it; - `IP` — `Protocol` bundles a round count, a private-coin count, a message-length bound, the verifier's next message as a function in `FP`, and its verdict as a language in `P`; `Protocol.transcript` runs the interaction against a `ProverStrategy`, which sees the transcript but never the coins. Completeness asks for one length-respecting strategy; soundness quantifies over all of them. `P_subset_MA` and `P_subset_AM` pin the definitions down: the verifier ignores the proof and the coins and decodes the input with `Cobham.fstBlock`. Co-Authored-By: Claude Opus 5 (1M context) --- Complexitylib/Classes.lean | 1 + Complexitylib/Classes/Interactive.lean | 239 +++++++++++++++++++++++++ 2 files changed, 240 insertions(+) create mode 100644 Complexitylib/Classes/Interactive.lean diff --git a/Complexitylib/Classes.lean b/Complexitylib/Classes.lean index 0855f28e..3dbdf126 100644 --- a/Complexitylib/Classes.lean +++ b/Complexitylib/Classes.lean @@ -53,6 +53,7 @@ public import Complexitylib.Classes.PPoly.Uniform.Unrolling.Serializer.Transitio public import Complexitylib.Classes.PPoly.Uniform.Preprocessing public import Complexitylib.Classes.PPoly.Uniform.Containment public import Complexitylib.Classes.NP +public import Complexitylib.Classes.Interactive public import Complexitylib.Classes.Randomized public import Complexitylib.Classes.Randomized.GoodSeed public import Complexitylib.Classes.Randomized.CircuitAmplification diff --git a/Complexitylib/Classes/Interactive.lean b/Complexitylib/Classes/Interactive.lean new file mode 100644 index 00000000..f684a130 --- /dev/null +++ b/Complexitylib/Classes/Interactive.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.EventProb +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.SndBlock +public import Complexitylib.Classes.P.Preimage +public import Complexitylib.Circuits.BitString +public import Complexitylib.Encoding.DataEncode +public import Mathlib.Algebra.Polynomial.Eval.Degree + +/-! +# Interactive proof classes: `MA`, `AM`, and `IP` + +⚠️ Unreviewed by Bolton + +A verifier here is a *language in `P`* — equivalently a polynomial-time +predicate — applied to the encoded tuple of everything it sees, and its private +coins are a uniformly random point of `Fin t → Bool` measured by `eventProb`. +This keeps the definitions machine-free and auditable, in the style of +`Complexitylib.Classes.NP.Witness`'s use of `pairLang`. + +The three classes differ in who speaks when: + +- `MA` — Merlin sends a proof `w`, then Arthur flips coins and checks + `pair (pair x w) r`. The proof cannot depend on the coins. +- `AM` — Arthur flips *public* coins `r` first, then Merlin answers `w`, and + the check is on `pair (pair x r) w`. Merlin's answer may depend on the coins, + so the existential sits inside the probability. +- `IP` — a `Protocol` runs a bounded number of rounds: the verifier's next + message is a polynomial-time function of the input, its private coins and the + transcript so far, and the prover replies by a `ProverStrategy`, which sees + the transcript but never the coins. Completeness asks for one strategy that + convinces the verifier; soundness quantifies over every strategy. + +## Main definitions + +- `Transcript`, `ProverStrategy`, `Protocol`, `Protocol.transcript`, + `Protocol.Accepts`, `Protocol.acceptEvent` +- `MA`, `AM`, `IP` + +## Main results + +- `P_subset_MA`, `P_subset_AM` — the definitions contain `P`, by ignoring the + proof and the coins + +## Conventions + +Completeness `2/3` and soundness `1/3` are hard-wired, as in +`Complexitylib.Classes.Randomized`. Message lengths are bounded by +`Protocol.msgLen`, and soundness in `IP` quantifies over the strategies obeying +that bound (`ProverStrategy.Bounded`): an unbounded message would blow up the +transcript the polynomial-time verifier has to read. The prover is adaptive — +it is a function of the transcript, not a single witness string. + +## TODO + +- Embed `MA` into `IP` as a one-round protocol with an empty verifier message. +- Amplification: sequential repetition and the resulting threshold robustness. +- `NP ⊆ MA` through the witness characterization interface, and `IP ⊆ PSPACE`. +-/ + +@[expose] public section + +namespace Complexity + +/-! ## Merlin–Arthur -/ + +open Classical in +/-- The coin strings on which the verifier `V` accepts input `x` with proof +`w`. -/ +noncomputable def merlinEvent (V : Language) (t : ℕ) (x w : List Bool) : + Finset (Fin t → Bool) := + Finset.univ.filter fun r => pair (pair x w) (BitString.toList r) ∈ V + +/-- **MA** (Merlin–Arthur): Merlin sends a polynomially bounded proof, and +Arthur checks it with a polynomial-time predicate and polynomially many private +coins, accepting a member with probability at least `2/3` and a non-member with +probability at most `1/3` whatever the proof. -/ +def MA : Set Language := + {L | ∃ (p : Polynomial ℕ) (V : Language), V ∈ P ∧ + (∀ x ∈ L, ∃ w : List Bool, w.length ≤ p.eval x.length ∧ + 2 / 3 ≤ eventProb (merlinEvent V (p.eval x.length) x w)) ∧ + (∀ x ∉ L, ∀ w : List Bool, w.length ≤ p.eval x.length → + eventProb (merlinEvent V (p.eval x.length) x w) ≤ 1 / 3)} + +/-! ## Arthur–Merlin -/ + +open Classical in +/-- The public coin strings that Merlin can answer: those admitting a +polynomially bounded reply the verifier accepts. -/ +noncomputable def arthurEvent (V : Language) (q t : ℕ) (x : List Bool) : + Finset (Fin t → Bool) := + Finset.univ.filter fun r => + ∃ w : List Bool, w.length ≤ q ∧ pair (pair x (BitString.toList r)) w ∈ V + +/-- **AM** (Arthur–Merlin): Arthur flips public coins first and Merlin answers +them, so the existential over Merlin's reply sits inside the probability. -/ +def AM : Set Language := + {L | ∃ (p : Polynomial ℕ) (V : Language), V ∈ P ∧ + (∀ x ∈ L, 2 / 3 ≤ eventProb (arthurEvent V (p.eval x.length) (p.eval x.length) x)) ∧ + (∀ x ∉ L, eventProb (arthurEvent V (p.eval x.length) (p.eval x.length) x) ≤ 1 / 3)} + +/-! ## Interactive protocols -/ + +/-- The messages exchanged so far, in order: the verifier speaks on even +positions and the prover on odd ones. -/ +abbrev Transcript := List (List Bool) + +/-- A prover strategy: the next message as a function of the visible +transcript. The prover is adaptive and never sees the verifier's coins. -/ +def ProverStrategy := Transcript → List Bool + +/-- A strategy respects a message-length bound. -/ +def ProverStrategy.Bounded (S : ProverStrategy) (m : ℕ) : Prop := + ∀ τ : Transcript, (S τ).length ≤ m + +/-- An interactive protocol: a round count, a private-coin count, a +message-length bound, the verifier's next message as a polynomial-time function +of the encoded input, coins and transcript, and its final verdict as a +polynomial-time predicate of the same. -/ +structure Protocol where + /-- Number of rounds, as a function of the input length. -/ + rounds : ℕ → ℕ + /-- Number of private coins, as a function of the input length. -/ + coins : ℕ → ℕ + /-- Bound on the length of the prover's messages. -/ + msgLen : ℕ → ℕ + /-- The verifier's next message, computed from `pair (pair x r) ⌜τ⌝`. -/ + vmsg : List Bool → List Bool + /-- That computation is polynomial-time. -/ + vmsg_mem : vmsg ∈ FP + /-- The verifier's final verdict, on `pair (pair x r) ⌜τ⌝`. -/ + verdict : Language + /-- That verdict is polynomial-time decidable. -/ + verdict_mem : verdict ∈ P + +namespace Protocol + +/-- The encoded view handed to the verifier: the input, its coins, and the +transcript so far. -/ +def view (x r : List Bool) (τ : Transcript) : List Bool := + pair (pair x r) (DataEncode.bitstringEncode τ) + +/-- The transcript after `n` rounds of `prot` on input `x` with coins `r` +against the strategy `S`: each round appends the verifier's message and then +the prover's reply. -/ +def transcript (prot : Protocol) (S : ProverStrategy) (x r : List Bool) : + ℕ → Transcript + | 0 => [] + | n + 1 => + let τ := prot.transcript S x r n + let v := prot.vmsg (view x r τ) + τ ++ [v, S (τ ++ [v])] + +/-- The verifier accepts the completed interaction. -/ +def Accepts (prot : Protocol) (S : ProverStrategy) (x r : List Bool) : Prop := + view x r (prot.transcript S x r (prot.rounds x.length)) ∈ prot.verdict + +open Classical in +/-- The coin strings on which the verifier accepts against `S`. -/ +noncomputable def acceptEvent (prot : Protocol) (S : ProverStrategy) (x : List Bool) : + Finset (Fin (prot.coins x.length) → Bool) := + Finset.univ.filter fun r => prot.Accepts S x (BitString.toList r) + +end Protocol + +/-- **IP**: languages with an interactive proof system whose round count, coin +count and message lengths are polynomially bounded. Completeness asks for one +strategy convincing the verifier with probability at least `2/3`; soundness +bounds every length-respecting strategy by `1/3`. -/ +def IP : Set Language := + {L | ∃ (prot : Protocol) (p : Polynomial ℕ), + (∀ n, prot.rounds n ≤ p.eval n) ∧ (∀ n, prot.coins n ≤ p.eval n) ∧ + (∀ n, prot.msgLen n ≤ p.eval n) ∧ + (∀ x ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen x.length) ∧ + 2 / 3 ≤ eventProb (prot.acceptEvent S x)) ∧ + (∀ x ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen x.length) → + eventProb (prot.acceptEvent S x) ≤ 1 / 3)} + +/-! ## Elementary containments -/ + +/-- The verifier that ignores the proof and the coins and decides `L` on the +input it can recover from the encoded view. -/ +private theorem inputVerifier_mem_P {L : Language} (hL : L ∈ P) : + (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L ∈ P := by + refine mem_P_preimage ?_ hL + exact mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +/-- **`P ⊆ MA`.** Merlin sends nothing and Arthur ignores his coins. -/ +theorem P_subset_MA : P ⊆ MA := by + intro L hL + refine ⟨0, (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L, + inputVerifier_mem_P hL, ?_, ?_⟩ + · intro x hx + refine ⟨[], by simp, ?_⟩ + have hev : merlinEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + (Polynomial.eval x.length 0) x [] = Finset.univ := by + ext r + simp [merlinEvent, Set.mem_preimage, hx] + rw [hev, eventProb_univ] + norm_num + · intro x hx w _ + have hev : merlinEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + (Polynomial.eval x.length 0) x w = ∅ := by + ext r + simp [merlinEvent, Set.mem_preimage, hx] + rw [hev, eventProb_empty] + norm_num + +/-- **`P ⊆ AM`.** Arthur's coins are irrelevant and Merlin's answer is empty. -/ +theorem P_subset_AM : P ⊆ AM := by + intro L hL + refine ⟨0, (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L, + inputVerifier_mem_P hL, ?_, ?_⟩ + · intro x hx + have hev : arthurEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + (Polynomial.eval x.length 0) (Polynomial.eval x.length 0) x = Finset.univ := by + ext r + simp only [arthurEvent, Finset.mem_filter, Finset.mem_univ, true_and, iff_true] + exact ⟨[], by simp, by simp [Set.mem_preimage, hx]⟩ + rw [hev, eventProb_univ] + norm_num + · intro x hx + have hev : arthurEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + (Polynomial.eval x.length 0) (Polynomial.eval x.length 0) x = ∅ := by + ext r + simp only [arthurEvent, Finset.mem_filter, Finset.mem_univ, true_and, + Finset.notMem_empty, iff_false, not_exists] + intro w + simp [Set.mem_preimage, hx] + rw [hev, eventProb_empty] + norm_num + +end Complexity From 094e739a58f1562b518d16839a486921ad3306c0 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Thu, 20 Aug 2026 09:55:07 -0700 Subject: [PATCH 15/24] overnight claude run on complexity class containments --- Complexitylib/Classes.lean | 24 + .../Classes/Containments/CoNLSubsetNL.lean | 54 + Complexitylib/Classes/Containments/Defs.lean | 71 + .../Classes/Containments/IPSubsetPSPACE.lean | 58 + .../Containments/Internal/BlockAccept.lean | 223 ++ .../Containments/Internal/BlockMember.lean | 331 +++ .../Containments/Internal/BlockSearch.lean | 235 ++ .../Internal/BlockSearchCorrect.lean | 377 +++ .../Containments/Internal/BoundedReach.lean | 154 ++ .../Containments/Internal/CodeAccept.lean | 118 + .../Containments/Internal/CodeRewind.lean | 141 + .../Containments/Internal/CodeSearch.lean | 208 ++ .../Containments/Internal/CodeStep.lean | 130 + .../Internal/ComplementSpace.lean | 266 ++ .../Containments/Internal/ConfigCount.lean | 189 ++ .../Containments/Internal/ConfigGraph.lean | 159 ++ .../Containments/Internal/FPBridge.lean | 145 + .../Containments/Internal/IPSubsetPSPACE.lean | 79 + .../Internal/InductiveCounting.lean | 166 ++ .../Containments/Internal/LogSpaceBound.lean | 140 + .../Internal/NLSearchAssemble.lean | 383 +++ .../Containments/Internal/PHAssemble.lean | 234 ++ .../Internal/PHAssembleWindow.lean | 306 +++ .../Classes/Containments/Internal/PHBank.lean | 137 + .../Classes/Containments/Internal/PHBody.lean | 1284 +++++++++ .../Containments/Internal/PHBodyWindow.lean | 650 +++++ .../Containments/Internal/PHBounds.lean | 687 +++++ .../Classes/Containments/Internal/PHEmit.lean | 186 ++ .../Containments/Internal/PHEpilogue.lean | 375 +++ .../Containments/Internal/PHLayout.lean | 221 ++ .../Classes/Containments/Internal/PHLoop.lean | 191 ++ .../Containments/Internal/PHLoopWindow.lean | 394 +++ .../Containments/Internal/PHMatrix.lean | 180 ++ .../Containments/Internal/PHParts.lean | 190 ++ .../Containments/Internal/PHPrologue.lean | 561 ++++ .../Containments/Internal/PHSubsetPSPACE.lean | 220 ++ .../Containments/Internal/PPAssemble.lean | 2427 +++++++++++++++++ .../Classes/Containments/Internal/PPBody.lean | 304 +++ .../Containments/Internal/PPLayout.lean | 266 ++ .../Containments/Internal/PPParts.lean | 1186 ++++++++ .../Classes/Containments/Internal/PPSim.lean | 232 ++ .../Containments/Internal/PPSubsetPSPACE.lean | 184 ++ .../Classes/Containments/Internal/PPTest.lean | 462 ++++ .../Internal/PSPACESubsetEXP.lean | 268 ++ .../Containments/Internal/PolyWindow.lean | 70 + .../Containments/Internal/ReachIn.lean | 162 ++ .../Containments/Internal/ReachSet.lean | 195 ++ .../Containments/Internal/SavitchBits.lean | 344 +++ .../Containments/Internal/SavitchBound.lean | 121 + .../Containments/Internal/SavitchFrame.lean | 277 ++ .../Containments/Internal/SavitchStep.lean | 324 +++ .../Containments/Internal/SpaceIterate.lean | 1292 +++++++++ .../Internal/TallyLoopIndexed.lean | 156 ++ .../Containments/Internal/WitnessEnum.lean | 483 ++++ .../Classes/Containments/NLSubsetCoNL.lean | 102 + .../Classes/Containments/NLSubsetP.lean | 121 + .../Containments/NPSPACESubsetPSPACE.lean | 141 + .../Classes/Containments/PHSubsetPSPACE.lean | 128 + .../Classes/Containments/PPSubsetPSPACE.lean | 118 + .../Classes/Containments/PSPACESubsetEXP.lean | 39 + .../Classes/Containments/PSPACESubsetIP.lean | 46 + .../Containments/PSPACESubsetNPSPACE.lean | 34 + .../Classes/P/Cobham/Internal/BlockLoop.lean | 97 + .../Classes/P/Cobham/Internal/Iterate.lean | 90 +- .../Classes/P/Cobham/Internal/StringOps.lean | 88 + Complexitylib/Models.lean | 2 + .../Models/TuringMachine/Branch.lean | 82 + .../Combinators/ApplyDecide.lean | 197 ++ .../Combinators/Internal/IdleHeads.lean | 375 +++ .../Combinators/Internal/LoopIndexed.lean | 73 + .../Combinators/Internal/LoopIteration.lean | 313 +++ .../Combinators/Internal/RetargetWindow.lean | 297 ++ .../Combinators/Internal/SentinelStep.lean | 254 ++ .../Combinators/Internal/SeqChain.lean | 99 + .../Combinators/Internal/Window.lean | 1374 ++++++++++ Complexitylib/Models/TuringMachine/Delay.lean | 295 ++ .../Models/TuringMachine/Hoare/Space.lean | 14 + .../TuringMachine/Hoare/Space/Internal.lean | 14 + .../TuringMachine/Hoare/SpaceFrame.lean | 64 + .../TuringMachine/Hoare/StartInvariant.lean | 82 + .../Models/TuringMachine/Placement/Hoare.lean | 89 + .../TuringMachine/Placement/Window.lean | 80 + .../TuringMachine/Subroutines/BinaryBump.lean | 104 + .../Subroutines/BinaryBump/Defs.lean | 159 ++ .../Subroutines/BinaryBump/Internal.lean | 568 ++++ .../TuringMachine/Subroutines/ParkRewind.lean | 157 ++ .../TuringMachine/Subroutines/WipeRewind.lean | 146 + .../Subroutines/WriteOutputBit.lean | 109 + 88 files changed, 24130 insertions(+), 41 deletions(-) create mode 100644 Complexitylib/Classes/Containments/CoNLSubsetNL.lean create mode 100644 Complexitylib/Classes/Containments/Defs.lean create mode 100644 Complexitylib/Classes/Containments/IPSubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BlockAccept.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BlockMember.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BlockSearch.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BlockSearchCorrect.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BoundedReach.lean create mode 100644 Complexitylib/Classes/Containments/Internal/CodeAccept.lean create mode 100644 Complexitylib/Classes/Containments/Internal/CodeRewind.lean create mode 100644 Complexitylib/Classes/Containments/Internal/CodeSearch.lean create mode 100644 Complexitylib/Classes/Containments/Internal/CodeStep.lean create mode 100644 Complexitylib/Classes/Containments/Internal/ComplementSpace.lean create mode 100644 Complexitylib/Classes/Containments/Internal/ConfigCount.lean create mode 100644 Complexitylib/Classes/Containments/Internal/ConfigGraph.lean create mode 100644 Complexitylib/Classes/Containments/Internal/FPBridge.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPSubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/Internal/InductiveCounting.lean create mode 100644 Complexitylib/Classes/Containments/Internal/LogSpaceBound.lean create mode 100644 Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHAssemble.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHAssembleWindow.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHBank.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHBody.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHBodyWindow.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHBounds.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHEmit.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHEpilogue.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHLayout.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHLoop.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHLoopWindow.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHMatrix.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHParts.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHPrologue.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PHSubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPAssemble.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPBody.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPLayout.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPParts.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPSim.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPSubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PPTest.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PSPACESubsetEXP.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PolyWindow.lean create mode 100644 Complexitylib/Classes/Containments/Internal/ReachIn.lean create mode 100644 Complexitylib/Classes/Containments/Internal/ReachSet.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchBits.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchBound.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchFrame.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchStep.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SpaceIterate.lean create mode 100644 Complexitylib/Classes/Containments/Internal/TallyLoopIndexed.lean create mode 100644 Complexitylib/Classes/Containments/Internal/WitnessEnum.lean create mode 100644 Complexitylib/Classes/Containments/NLSubsetCoNL.lean create mode 100644 Complexitylib/Classes/Containments/NLSubsetP.lean create mode 100644 Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/PHSubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/PPSubsetPSPACE.lean create mode 100644 Complexitylib/Classes/Containments/PSPACESubsetEXP.lean create mode 100644 Complexitylib/Classes/Containments/PSPACESubsetIP.lean create mode 100644 Complexitylib/Classes/Containments/PSPACESubsetNPSPACE.lean create mode 100644 Complexitylib/Models/TuringMachine/Branch.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/ApplyDecide.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/IdleHeads.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIndexed.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIteration.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/RetargetWindow.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/SentinelStep.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/SeqChain.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/Window.lean create mode 100644 Complexitylib/Models/TuringMachine/Delay.lean create mode 100644 Complexitylib/Models/TuringMachine/Hoare/SpaceFrame.lean create mode 100644 Complexitylib/Models/TuringMachine/Hoare/StartInvariant.lean create mode 100644 Complexitylib/Models/TuringMachine/Placement/Hoare.lean create mode 100644 Complexitylib/Models/TuringMachine/Placement/Window.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/BinaryBump.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Defs.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Internal.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/WipeRewind.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/WriteOutputBit.lean diff --git a/Complexitylib/Classes.lean b/Complexitylib/Classes.lean index 3dbdf126..0a9d2bc2 100644 --- a/Complexitylib/Classes.lean +++ b/Complexitylib/Classes.lean @@ -71,6 +71,30 @@ public import Complexitylib.Classes.L.PolynomialTime public import Complexitylib.Classes.Exponential public import Complexitylib.Classes.DTISP public import Complexitylib.Classes.Containments +public import Complexitylib.Classes.Containments.Defs +public import Complexitylib.Classes.Containments.Internal.ConfigCount +public import Complexitylib.Classes.Containments.Internal.LogSpaceBound +public import Complexitylib.Classes.Containments.Internal.ReachSet +public import Complexitylib.Classes.Containments.Internal.ConfigGraph +public import Complexitylib.Classes.Containments.Internal.BoundedReach +public import Complexitylib.Classes.Containments.Internal.CodeSearch +public import Complexitylib.Classes.Containments.Internal.ReachIn +public import Complexitylib.Classes.Containments.Internal.SavitchBound +public import Complexitylib.Classes.Containments.Internal.InductiveCounting +public import Complexitylib.Classes.Containments.Internal.ComplementSpace +public import Complexitylib.Classes.Containments.Internal.PHSubsetPSPACE +public import Complexitylib.Classes.Containments.Internal.PPSubsetPSPACE +public import Complexitylib.Classes.Containments.Internal.IPSubsetPSPACE +public import Complexitylib.Classes.Containments.CoNLSubsetNL +public import Complexitylib.Classes.Containments.IPSubsetPSPACE +public import Complexitylib.Classes.Containments.NLSubsetCoNL +public import Complexitylib.Classes.Containments.NLSubsetP +public import Complexitylib.Classes.Containments.NPSPACESubsetPSPACE +public import Complexitylib.Classes.Containments.PHSubsetPSPACE +public import Complexitylib.Classes.Containments.PPSubsetPSPACE +public import Complexitylib.Classes.Containments.PSPACESubsetEXP +public import Complexitylib.Classes.Containments.PSPACESubsetIP +public import Complexitylib.Classes.Containments.PSPACESubsetNPSPACE public import Complexitylib.Classes.Hierarchy /-! diff --git a/Complexitylib/Classes/Containments/CoNLSubsetNL.lean b/Complexitylib/Classes/Containments/CoNLSubsetNL.lean new file mode 100644 index 00000000..ebc2ec5f --- /dev/null +++ b/Complexitylib/Classes/Containments/CoNLSubsetNL.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.L + +/-! +# `coNL ⊆ NL` + +⚠️ Unreviewed by Bolton + +The reverse half of the Immerman–Szelepcsényi theorem. + +Either inclusion implies the other, and this file proves that reduction unconditionally: `coNL` +is the complement class of `NL`, so complementing both sides of one inclusion produces the other. +Only one direction therefore has to be proved by inductive counting — see `NLSubsetCoNL`. + +## Main results + +- `coNL_subset_NL_of_NL_subset_coNL`, `NL_subset_coNL_of_coNL_subset_NL` — the two directions are + equivalent +- `NL_eq_coNL_of_NL_subset_coNL` — either one settles `NL = coNL` +-/ + +@[expose] public section + +namespace Complexity + +/-- **`coNL ⊆ NL`** (Immerman–Szelepcsényi). -/ +def CoNLSubsetNL : Prop := coNL ⊆ NL + +/-- One inclusion gives the other: complementing `Lᶜ ∈ NL` turns membership in `coNL` into +membership in `NL`. -/ +theorem coNL_subset_NL_of_NL_subset_coNL (h : NL ⊆ coNL) : coNL ⊆ NL := by + intro L hL + have h₁ : Lᶜ ∈ NL := hL + have h₂ : (Lᶜ)ᶜ ∈ NL := h h₁ + rwa [compl_compl] at h₂ + +/-- The mirror implication. -/ +theorem NL_subset_coNL_of_coNL_subset_NL (h : coNL ⊆ NL) : NL ⊆ coNL := by + intro L hL + have h₁ : Lᶜ ∈ coNL := by + show (Lᶜ)ᶜ ∈ NL + rwa [compl_compl] + exact h h₁ + +/-- Either inclusion settles the equality. -/ +theorem NL_eq_coNL_of_NL_subset_coNL (h : NL ⊆ coNL) : NL = coNL := + subset_antisymm h (coNL_subset_NL_of_NL_subset_coNL h) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Defs.lean b/Complexitylib/Classes/Containments/Defs.lean new file mode 100644 index 00000000..d263a62e --- /dev/null +++ b/Complexitylib/Classes/Containments/Defs.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.ChoiceTape +public import Mathlib.Data.Nat.Log + +/-! +# The configuration graph and its bounded reachability rounds + +The space-bounded containments — `NL ⊆ P`, `NL ⊆ coNL`, Savitch's theorem — all read a +computation as a walk in the *configuration graph*: the nondeterministic step relation on +configurations. This file holds the three definitions those arguments share, so that theorem +statements about them can be read without opening any proof internals. + +## Main definitions + +- `NTM.Succ` — one nondeterministic step, as a relation on configurations +- `NTM.ReachesCfg` — its reflexive-transitive closure +- `NTM.reachSet` — the configurations reached within a fixed number of rounds of + successor-closure, i.e. the state of a breadth-first search after that many rounds +- `NTM.ReachesCfgIn`, `NTM.ReachesCfgLe` — reachability in exactly, and in at most, a given + number of steps; the step count is what Savitch's recursion halves +- `logWindow` — a concrete `O(log n)` search window +-/ + +@[expose] public section + +namespace Complexity + +/-- The search window of a log-space machine. A machine's own space function is an arbitrary +`O(log n)` function, which a program cannot evaluate; this concrete bound can be computed from +the input length alone, and enlarging the window is harmless. -/ +def logWindow (C D n : ℕ) : ℕ := C * Nat.log 2 n + D + +namespace NTM + +variable {k : ℕ} + +/-- One step of the configuration graph: a non-halted configuration has the two successors its +transition functions produce. -/ +def Succ (tm : NTM k) (c c' : Cfg k tm.Q) : Prop := + c.state ≠ tm.qhalt ∧ ∃ b, c' = tm.stepCfg b c + +/-- Reachability in the configuration graph. -/ +def ReachesCfg (tm : NTM k) : Cfg k tm.Q → Cfg k tm.Q → Prop := + Relation.ReflTransGen tm.Succ + +/-- Reachability in exactly `t` steps of the configuration graph. -/ +inductive ReachesCfgIn (tm : NTM k) : ℕ → Cfg k tm.Q → Cfg k tm.Q → Prop + /-- No steps: a configuration reaches itself. -/ + | refl (c : Cfg k tm.Q) : ReachesCfgIn tm 0 c c + /-- One step followed by a shorter walk. -/ + | head {c c' c'' : Cfg k tm.Q} {t : ℕ} (hstep : tm.Succ c c') + (hrest : ReachesCfgIn tm t c' c'') : ReachesCfgIn tm (t + 1) c c'' + +/-- Reachability in at most `t` steps. Halted configurations have no successors, so a walk +cannot be padded and the bounded notion is genuinely weaker than the exact one. -/ +def ReachesCfgLe (tm : NTM k) (t : ℕ) (c c' : Cfg k tm.Q) : Prop := + ∃ s ≤ t, tm.ReachesCfgIn s c c' + +/-- The configurations reachable from `c₀` within `t` rounds of successor-closure. -/ +def reachSet (tm : NTM k) (c₀ : Cfg k tm.Q) : ℕ → Set (Cfg k tm.Q) + | 0 => {c₀} + | t + 1 => reachSet tm c₀ t ∪ {c' | ∃ c ∈ reachSet tm c₀ t, tm.Succ c c'} + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean b/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean new file mode 100644 index 00000000..af4cdd3f --- /dev/null +++ b/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Interactive +public import Complexitylib.Classes.Containments.Internal.IPSubsetPSPACE +public import Complexitylib.Classes.P.Defs + +/-! +# `IP ⊆ PSPACE` + +⚠️ Unreviewed by Bolton + +The easy half of `IP = PSPACE`. + +The value of an interactive protocol on an input is the acceptance probability against an optimal +prover, and that value is the root of a finite game tree: the prover's moves maximize, the +verifier's coins average. Polynomial space evaluates the tree depth-first, holding one path of +messages at a time — the tree is exponentially wide but only polynomially deep, since both the +round count and the message lengths are polynomially bounded. + +## Progress + +The quantifier over prover strategies is now known to be finite. A strategy is a function on +*all* transcripts, of which there are infinitely many, so the supremum `IP` quantifies is a +priori a supremum over an infinite set — nothing a machine can search. `Protocol.transcript_congr` +and `Protocol.acceptEvent_congr` show that a run of `rounds n` rounds consults the strategy only +on transcripts of length at most `2 · rounds n`; together with the message-length bound carried +by `ProverStrategy.Bounded`, that cuts the search to a finite game tree of polynomial depth. + +## What the proof still needs + +- The optimal-prover value as a recursion over `Protocol.transcript` on that finite tree, and the + fact that deterministic strategies suffice to attain it. +- Rational arithmetic in polynomial space for the averaging step. + +## Main results + +- `Protocol.transcript_length` — a run of `n` rounds produces `2 n` messages +- `Protocol.transcript_congr` — strategy extensionality for the transcript +- `Protocol.accepts_congr`, `Protocol.acceptEvent_congr` — and for acceptance + +## TODO + +- Evaluate the game tree; with `PSPACESubsetIP` this gives Shamir's theorem. +-/ + +@[expose] public section + +namespace Complexity + +/-- **`IP ⊆ PSPACE`**: the optimal prover's acceptance probability is the value of a +polynomially deep game tree, evaluated depth-first in polynomial space. -/ +def IPSubsetPSPACE : Prop := IP ⊆ PSPACE + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BlockAccept.lean b/Complexitylib/Classes/Containments/Internal/BlockAccept.lean new file mode 100644 index 00000000..91929e48 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BlockAccept.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.CodeAccept +public import Complexitylib.Classes.Containments.Internal.BlockMember + +/-! +# Scanning the visited string for an accepting record + +⚠️ Unreviewed by Bolton + +The last step of the search is a scan of the visited string that ORs the +accepting-record test of +`Complexitylib.Classes.Containments.Internal.CodeAccept` over its records. It is +the scan of `Complexitylib.Classes.Containments.Internal.BlockMember` with a +different test, so its correctness comes straight from `anyStepPair`. + +Two rulers travel in the state: the block ruler, which the test slices a record +with, and the rewind ruler, which says how long to drive the output head left. +The record width is `2(k+2)+1` block rulers, so it need not be carried. + +## Main definitions + +- `Complexity.acceptPack`, `Complexity.acceptStep` — the packed scan +- `Complexity.acceptScan` — its verdict + +## Main results + +- `Complexity.acceptStep_pack`, `Complexity.acceptStep_iterate` — packed is + unpacked +- `Complexity.acceptScan_eq_true_iff` — what the scan decides +- `Complexity.acceptStep_mem_FP`, `Complexity.acceptScanFn_mem_FP` — both are + polynomial-time +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The packed scan -/ + +/-- The packed accept-scan state: the two rulers, then the flag and the rest. -/ +def acceptPack (R ruler flag rest : List Bool) : List Bool := + pair (pair R ruler) (pair flag rest) + +@[simp] theorem acceptPack_length (R ruler flag rest : List Bool) : + (acceptPack R ruler flag rest).length + = 2 * (2 * R.length + ruler.length + 2) + 2 * flag.length + rest.length + 4 := by + rw [acceptPack, pair_length, pair_length, pair_length] + omega + +/-- One step of the accept scan. -/ +noncomputable def acceptStep (k : ℕ) (qcode z : List Bool) : List Bool := + pair (fstBlock z) + (selectHead + (lenLeFlag (sndBlock (sndBlock z)) + (wideRuler (codeBlocks k) (fstBlock (fstBlock z)))) + (pair + (orBit (fstBlock (sndBlock z)) + (acceptFlag qcode (fstBlock (fstBlock z)) (sndBlock (fstBlock z)) + ((sndBlock (sndBlock z)).take + (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length))) + ((sndBlock (sndBlock z)).drop + (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length)) + (sndBlock z)) + +/-- The unpacked step the packed one performs. -/ +noncomputable def acceptPairStep (k : ℕ) (qcode R ruler : List Bool) : + List Bool × List Bool → List Bool × List Bool := + anyStepPair (wideRuler (codeBlocks k) R) (acceptFlag qcode R ruler) + +/-- **The packed step is the unpacked step.** -/ +theorem acceptStep_pack (k : ℕ) (qcode R ruler flag rest : List Bool) : + acceptStep k qcode (acceptPack R ruler flag rest) + = acceptPack R ruler (acceptPairStep k qcode R ruler (flag, rest)).1 + (acceptPairStep k qcode R ruler (flag, rest)).2 := by + rw [acceptStep, acceptPack] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + by_cases hle : (wideRuler (codeBlocks k) R).length ≤ rest.length + · rw [acceptPairStep, anyStepPair_pos _ (acceptFlag qcode R ruler) (flag, rest) hle, + Cobham.selectHead, + if_pos (by + rw [(Cobham.lenLeFlag_eq_true_iff rest (wideRuler (codeBlocks k) R)).mpr hle] + rfl)] + rfl + · rw [acceptPairStep, anyStepPair_neg _ (acceptFlag qcode R ruler) (flag, rest) hle, + Cobham.selectHead] + have hflag : Cobham.lenLeFlag rest (wideRuler (codeBlocks k) R) = [false] := by + rcases Cobham.lenLeFlag_flag rest (wideRuler (codeBlocks k) R) with h | h + · rw [Cobham.lenLeFlag_eq_true_iff] at h + omega + · exact h + rw [if_neg (by rw [hflag]; simp), if_pos (by rw [hflag]; rfl)] + rfl + +/-- **The packed iteration is the unpacked one.** -/ +theorem acceptStep_iterate (k : ℕ) (qcode R ruler : List Bool) + (s : List Bool × List Bool) (n : ℕ) : + (acceptStep k qcode)^[n] (acceptPack R ruler s.1 s.2) + = acceptPack R ruler ((acceptPairStep k qcode R ruler)^[n] s).1 + ((acceptPairStep k qcode R ruler)^[n] s).2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, acceptStep_pack, + ih (acceptPairStep k qcode R ruler s), Function.iterate_succ_apply] + +/-! ## The verdict -/ + +/-- Does any record of `V` pass the accepting test? -/ +noncomputable def acceptScan (k : ℕ) (qcode R ruler V : List Bool) : List Bool := + fstBlock (sndBlock ((acceptStep k qcode)^[V.length] (acceptPack R ruler [false] V))) + +theorem acceptScan_flag (k : ℕ) (qcode R ruler V : List Bool) : + acceptScan k qcode R ruler V = [true] ∨ acceptScan k qcode R ruler V = [false] := by + rw [acceptScan, show V = ((([false] : List Bool), V)).2 from rfl, + show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, + acceptStep_iterate, acceptPack] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + exact anyStepPair_flag _ (fun z => acceptFlag_flag qcode R ruler z) (Or.inr rfl) _ + +/-- **The scan finds an accepting record exactly when there is one.** -/ +theorem acceptScan_eq_true_iff (k : ℕ) (qcode R ruler V : List Bool) + (hR : 0 < R.length) : + acceptScan k qcode R ruler V = [true] ↔ + ∃ i, i * (wideRuler (codeBlocks k) R).length + + (wideRuler (codeBlocks k) R).length ≤ V.length ∧ + acceptFlag qcode R ruler (blockAt (wideRuler (codeBlocks k) R) V i) = [true] := by + have hw : 0 < (wideRuler (codeBlocks k) R).length := by + rw [wideRuler_length, codeBlocks] + positivity + rw [acceptScan, show V = ((([false] : List Bool), V)).2 from rfl, + show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, + acceptStep_iterate, acceptPack] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [acceptPairStep, + anyStepPair_flag_eq_true_iff _ (fun z => acceptFlag_flag qcode R ruler z) _ (Or.inr rfl)] + constructor + · rintro (h | ⟨i, -, hlen, hblk⟩) + · simp at h + · exact ⟨i, hlen, hblk⟩ + · rintro ⟨i, hlen, hblk⟩ + refine Or.inr ⟨i, ?_, hlen, hblk⟩ + calc i ≤ i * (wideRuler (codeBlocks k) R).length := + Nat.le_mul_of_pos_right _ hw + _ < V.length := by omega + +/-! ## The scan is polynomial-time -/ + +theorem acceptStep_mem_FP (k : ℕ) (qcode : List Bool) : acceptStep k qcode ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hhead := hfst hid + have hR := hfst hhead + have hruler := hsnd hhead + have htail := hsnd hid + have hflag := hfst htail + have hrest := hsnd htail + have hwide := wideRulerFn_mem_FP hR (codeBlocks k) + have htake : (fun z => (sndBlock (sndBlock z)).take + (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length) ∈ FP := + Cobham.takeLenFn_mem_FP hwide hrest + have hdrop : (fun z => (sndBlock (sndBlock z)).drop + (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length) ∈ FP := + dropLenFn_mem_FP hwide hrest + exact Cobham.pairFn_mem_FP hhead + (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hrest hwide) + (Cobham.pairFn_mem_FP + (orBitFn_mem_FP hflag (acceptFlagFn_mem_FP qcode hR hruler htake)) hdrop) + htail) + +/-- The scan's state never grows. -/ +theorem acceptStep_iterate_length_le (k : ℕ) (qcode R ruler : List Bool) + (s : List Bool × List Bool) (hf : s.1 = [true] ∨ s.1 = [false]) (n : ℕ) : + ((acceptStep k qcode)^[n] (acceptPack R ruler s.1 s.2)).length + ≤ (acceptPack R ruler s.1 s.2).length := by + rw [acceptStep_iterate, acceptPack_length, acceptPack_length] + have hflen : ((acceptPairStep k qcode R ruler)^[n] s).1.length = s.1.length := by + have hcase := anyStepPair_flag (wideRuler (codeBlocks k) R) + (fun z => acceptFlag_flag qcode R ruler z) (s := s) hf n + rw [acceptPairStep] at * + rcases hcase with h | h <;> rw [h] <;> rcases hf with h' | h' <;> rw [h'] <;> rfl + have hrest : ((acceptPairStep k qcode R ruler)^[n] s).2.length ≤ s.2.length := by + rw [acceptPairStep] + exact anyStepPair_rest_length _ _ s n + omega + +/-- **The accept scan is polynomial-time.** -/ +theorem acceptScanFn_mem_FP (k : ℕ) (qcode : List Bool) + {Rf rulerf Vf : List Bool → List Bool} (hR : Rf ∈ FP) (hruler : rulerf ∈ FP) + (hV : Vf ∈ FP) : + (fun w => acceptScan k qcode (Rf w) (rulerf w) (Vf w)) ∈ FP := by + have hinit : (fun w => acceptPack (Rf w) (rulerf w) [false] (Vf w)) ∈ FP := + Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hR hruler) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) hV) + have hbound : ∀ w, ∀ n ≤ (Vf w).length, + ((acceptStep k qcode)^[n] (acceptPack (Rf w) (rulerf w) [false] (Vf w))).length + ≤ (acceptPack (Rf w) (rulerf w) [false] (Vf w)).length := + fun w n _ => acceptStep_iterate_length_le k qcode (Rf w) (rulerf w) + ([false], Vf w) (Or.inr rfl) n + have h := Cobham.iterate_mem_FP (acceptStep_mem_FP k qcode) hinit hV hinit hbound + have h1 := mem_FP_comp h Cobham.sndBlock_mem_FP + have h2 := mem_FP_comp h1 Cobham.fstBlock_mem_FP + refine mem_FP_of_eq h2 fun w => ?_ + rw [Function.comp_apply, Function.comp_apply, acceptScan] + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BlockMember.lean b/Complexitylib/Classes/Containments/Internal/BlockMember.lean new file mode 100644 index 00000000..d5004e95 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BlockMember.lean @@ -0,0 +1,331 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.FPBridge + +/-! +# Searching a block-aligned string for a block + +⚠️ Unreviewed by Bolton + +A search that keeps its visited set as a run of fixed-width records must be able +to ask whether a record is already there. This file supplies that test as a +polynomial-time function: one scan, one block per step, accumulating a flag. + +The scan is written as an iteration rather than a recursion, because that is the +shape `Cobham.iterate_mem_FP` consumes — the state is a packed +`pair (pair u f) rest`, and one step compares `u` against the leading block of +`rest` and drops it. + +## Main definitions + +- `Complexity.scanStep` — one step of the scan, on the unpacked state +- `Complexity.memStep` — the same on the packed state +- `Complexity.memFlag` — the verdict of a full scan + +## Main results + +- `Complexity.memStep_iterate` — the packed iteration tracks the unpacked one +- `Complexity.memFlag_eq_true_iff` — what the scan decides +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-! ## The scan, on the unpacked state -/ + +/-- One step of a scan that folds a per-record test into a flag. A remainder +shorter than one record is a dead end, so the state stands still. -/ +def anyStepPair (R : List Bool) (f : List Bool → List Bool) + (s : List Bool × List Bool) : List Bool × List Bool := + if R.length ≤ s.2.length then (orBit s.1 (f (s.2.take R.length)), s.2.drop R.length) + else s + +theorem anyStepPair_pos (R : List Bool) (f : List Bool → List Bool) + (s : List Bool × List Bool) (h : R.length ≤ s.2.length) : + anyStepPair R f s = (orBit s.1 (f (s.2.take R.length)), s.2.drop R.length) := + if_pos h + +theorem anyStepPair_neg (R : List Bool) (f : List Bool → List Bool) + (s : List Bool × List Bool) (h : ¬ R.length ≤ s.2.length) : anyStepPair R f s = s := + if_neg h + +/-- The flag component of a scan is a flag. -/ +theorem anyStepPair_flag (R : List Bool) {f : List Bool → List Bool} + (hf : ∀ z, f z = [true] ∨ f z = [false]) {s : List Bool × List Bool} + (hs : s.1 = [true] ∨ s.1 = [false]) (n : ℕ) : + ((anyStepPair R f)^[n] s).1 = [true] ∨ ((anyStepPair R f)^[n] s).1 = [false] := by + induction n generalizing s with + | zero => exact hs + | succ n ih => + rw [Function.iterate_succ_apply] + refine ih ?_ + rw [anyStepPair] + split + · exact orBit_flag hs (hf _) + · exact hs + +/-- The remainder never grows. -/ +theorem anyStepPair_rest_length (R : List Bool) (f : List Bool → List Bool) + (s : List Bool × List Bool) (n : ℕ) : + ((anyStepPair R f)^[n] s).2.length ≤ s.2.length := by + induction n generalizing s with + | zero => simp + | succ n ih => + refine le_trans (ih (anyStepPair R f s)) ?_ + rw [anyStepPair] + split + · simp + · exact le_rfl + +/-- Dropping one record shifts the record index. -/ +theorem blockAt_drop (R z : List Bool) (i : ℕ) : + blockAt R (z.drop R.length) i = blockAt R z (i + 1) := by + rw [blockAt, blockAt, List.drop_drop] + congr 2 + ring + +/-- **A scan fires exactly when the test fires on one of the records.** -/ +theorem anyStepPair_flag_eq_true_iff (R : List Bool) {f : List Bool → List Bool} + (hf : ∀ z, f z = [true] ∨ f z = [false]) (s : List Bool × List Bool) + (hs : s.1 = [true] ∨ s.1 = [false]) (n : ℕ) : + ((anyStepPair R f)^[n] s).1 = [true] ↔ + s.1 = [true] ∨ ∃ i < n, i * R.length + R.length ≤ s.2.length ∧ + f (blockAt R s.2 i) = [true] := by + induction n generalizing s with + | zero => simp + | succ n ih => + have hstep : (anyStepPair R f s).1 = [true] ∨ (anyStepPair R f s).1 = [false] := by + rw [anyStepPair] + split + · exact orBit_flag hs (hf _) + · exact hs + rw [Function.iterate_succ_apply, ih (anyStepPair R f s) hstep] + by_cases hle : R.length ≤ s.2.length + · have hfst : (anyStepPair R f s).1 = orBit s.1 (f (s.2.take R.length)) := by + rw [anyStepPair, if_pos hle] + have hsnd : (anyStepPair R f s).2 = s.2.drop R.length := by + rw [anyStepPair, if_pos hle] + rw [hfst, hsnd, orBit_eq_true_iff hs (hf _)] + constructor + · rintro ((h | h) | ⟨i, hi, hlen, hblk⟩) + · exact Or.inl h + · refine Or.inr ⟨0, by omega, by omega, ?_⟩ + rw [blockAt, Nat.zero_mul, List.drop_zero] + exact h + · have hmul : (i + 1) * R.length = i * R.length + R.length := by ring + rw [List.length_drop] at hlen + refine Or.inr ⟨i + 1, by omega, by omega, ?_⟩ + rw [← blockAt_drop] + exact hblk + · rintro (h | ⟨i, hi, hlen, hblk⟩) + · exact Or.inl (Or.inl h) + · rcases Nat.eq_zero_or_pos i with rfl | hipos + · refine Or.inl (Or.inr ?_) + rw [blockAt, Nat.zero_mul, List.drop_zero] at hblk + exact hblk + · obtain ⟨j, rfl⟩ : ∃ j, i = j + 1 := ⟨i - 1, by omega⟩ + have hmul : (j + 1) * R.length = j * R.length + R.length := by ring + refine Or.inr ⟨j, by omega, ?_, ?_⟩ + · rw [List.length_drop] + omega + · rw [blockAt_drop] + exact hblk + · have hfix : anyStepPair R f s = s := by rw [anyStepPair, if_neg hle] + rw [hfix] + constructor + · rintro (h | ⟨i, hi, hlen, hblk⟩) + · exact Or.inl h + · exact Or.inr ⟨i, by omega, hlen, hblk⟩ + · rintro (h | ⟨i, hi, hlen, hblk⟩) + · exact Or.inl h + · have : R.length ≤ s.2.length := le_trans (by omega) hlen + omega + +/-- One step of the membership scan: compare `u` against the leading record. -/ +def scanStep (R u : List Bool) : List Bool × List Bool → List Bool × List Bool := + anyStepPair R (eqFlag u) + +theorem scanStep_flag (R u : List Bool) {s : List Bool × List Bool} + (hs : s.1 = [true] ∨ s.1 = [false]) (n : ℕ) : + ((scanStep R u)^[n] s).1 = [true] ∨ ((scanStep R u)^[n] s).1 = [false] := + anyStepPair_flag R (fun z => eqFlag_flag u z) hs n + +theorem scanStep_rest_length (R u : List Bool) (s : List Bool × List Bool) (n : ℕ) : + ((scanStep R u)^[n] s).2.length ≤ s.2.length := + anyStepPair_rest_length R _ s n + +/-- **The scan finds a record exactly when one matches.** -/ +theorem scanStep_flag_eq_true_iff (R u : List Bool) (s : List Bool × List Bool) + (hs : s.1 = [true] ∨ s.1 = [false]) (n : ℕ) : + ((scanStep R u)^[n] s).1 = [true] ↔ + s.1 = [true] ∨ ∃ i < n, i * R.length + R.length ≤ s.2.length ∧ + blockAt R s.2 i = u := by + rw [scanStep, anyStepPair_flag_eq_true_iff R (fun z => eqFlag_flag u z) s hs n] + constructor + · rintro (h | ⟨i, hi, hlen, hblk⟩) + · exact Or.inl h + · exact Or.inr ⟨i, hi, hlen, ((eqFlag_eq_true_iff _ _).mp hblk).symm⟩ + · rintro (h | ⟨i, hi, hlen, hblk⟩) + · exact Or.inl h + · exact Or.inr ⟨i, hi, hlen, (eqFlag_eq_true_iff _ _).mpr hblk.symm⟩ + +/-! ## The scan, packed -/ + +/-- The packed scan state: the ruler, then the sought block, the flag and the +remaining string. Everything the step needs travels inside the state, which is +what `Cobham.iterate_mem_FP` iterates. -/ +def memPack (R u f rest : List Bool) : List Bool := pair R (pair (pair u f) rest) + +@[simp] theorem memPack_length (R u f rest : List Bool) : + (memPack R u f rest).length + = 2 * R.length + 2 * (2 * u.length + f.length + 2) + rest.length + 4 := by + rw [memPack, pair_length, pair_length, pair_length] + omega + +/-- One step of the scan on the packed state. -/ +def memStep (z : List Bool) : List Bool := + pair (Cobham.fstBlock z) + (Cobham.selectHead + (Cobham.lenLeFlag (Cobham.sndBlock (Cobham.sndBlock z)) (Cobham.fstBlock z)) + (pair + (pair (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) + (orBit (Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock z))) + (Cobham.eqFlag (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) + ((Cobham.sndBlock (Cobham.sndBlock z)).take (Cobham.fstBlock z).length)))) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop (Cobham.fstBlock z).length)) + (Cobham.sndBlock z)) + +/-- **The packed step is the unpacked step.** -/ +theorem memStep_pack (R u f rest : List Bool) : + memStep (memPack R u f rest) + = memPack R u (scanStep R u (f, rest)).1 (scanStep R u (f, rest)).2 := by + rw [memStep, memPack] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + by_cases hle : R.length ≤ rest.length + · rw [scanStep, anyStepPair_pos R (eqFlag u) (f, rest) hle, Cobham.selectHead, + if_pos (by rw [(Cobham.lenLeFlag_eq_true_iff rest R).mpr hle]; rfl)] + rfl + · rw [scanStep, anyStepPair_neg R (eqFlag u) (f, rest) hle, Cobham.selectHead] + have hflag : Cobham.lenLeFlag rest R = [false] := by + rcases Cobham.lenLeFlag_flag rest R with h | h + · rw [Cobham.lenLeFlag_eq_true_iff rest R] at h + omega + · exact h + rw [if_neg (by rw [hflag]; simp), if_pos (by rw [hflag]; rfl)] + rfl + +/-- **The packed iteration is the unpacked one.** -/ +theorem memStep_iterate (R u : List Bool) (s : List Bool × List Bool) (n : ℕ) : + memStep^[n] (memPack R u s.1 s.2) + = memPack R u ((scanStep R u)^[n] s).1 ((scanStep R u)^[n] s).2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, memStep_pack, ih (scanStep R u s), + Function.iterate_succ_apply] + +/-! ## The verdict -/ + +/-- Does the block `u` occur in the block-aligned string `V`? -/ +def memFlag (R u V : List Bool) : List Bool := + Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock (memStep^[V.length] + (memPack R u [false] V)))) + +theorem memFlag_flag (R u V : List Bool) : + memFlag R u V = [true] ∨ memFlag R u V = [false] := by + rw [memFlag, show V = ((([false] : List Bool), V)).2 from rfl, + show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, + memStep_iterate, memPack] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + exact scanStep_flag R u (Or.inr rfl) _ + +/-- **The scan decides membership.** -/ +theorem memFlag_eq_true_iff (R u V : List Bool) (hR : 0 < R.length) : + memFlag R u V = [true] ↔ + ∃ i, i * R.length + R.length ≤ V.length ∧ blockAt R V i = u := by + rw [memFlag, show V = ((([false] : List Bool), V)).2 from rfl, + show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, + memStep_iterate, memPack] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [scanStep_flag_eq_true_iff R u _ (Or.inr rfl)] + constructor + · rintro (h | ⟨i, -, hlen, hblk⟩) + · simp at h + · exact ⟨i, hlen, hblk⟩ + · rintro ⟨i, hlen, hblk⟩ + refine Or.inr ⟨i, ?_, hlen, hblk⟩ + calc i ≤ i * R.length := Nat.le_mul_of_pos_right _ hR + _ < V.length := by omega + +/-! ## The scan is polynomial-time -/ + +theorem memStep_mem_FP : memStep ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => Cobham.fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => Cobham.sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hR := hfst hid + have hw := hsnd hid + have hrest := hsnd hw + have hu := hfst (hfst hw) + have hf := hsnd (hfst hw) + have htake : (fun z => (Cobham.sndBlock (Cobham.sndBlock z)).take + (Cobham.fstBlock z).length) ∈ FP := Cobham.takeLenFn_mem_FP hR hrest + have hdrop : (fun z => (Cobham.sndBlock (Cobham.sndBlock z)).drop + (Cobham.fstBlock z).length) ∈ FP := dropLenFn_mem_FP hR hrest + have hthen : (fun z => pair (pair (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) + (orBit (Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock z))) + (Cobham.eqFlag (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) + ((Cobham.sndBlock (Cobham.sndBlock z)).take (Cobham.fstBlock z).length)))) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop (Cobham.fstBlock z).length)) ∈ FP := + Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP hu (orBitFn_mem_FP hf (eqFlagFn_mem_FP hu htake))) hdrop + exact Cobham.pairFn_mem_FP hR + (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hrest hR) hthen hw) + +/-- The scan's state never grows. -/ +theorem memStep_iterate_length_le (R u : List Bool) (s : List Bool × List Bool) + (hf : s.1 = [true] ∨ s.1 = [false]) (n : ℕ) : + (memStep^[n] (memPack R u s.1 s.2)).length ≤ (memPack R u s.1 s.2).length := by + rw [memStep_iterate, memPack_length, memPack_length] + have hflen : ((scanStep R u)^[n] s).1.length = s.1.length := by + rcases scanStep_flag R u hf n with h | h <;> rw [h] <;> + rcases hf with h' | h' <;> rw [h'] <;> rfl + have hrest := scanStep_rest_length R u s n + omega + +/-- **The membership scan is polynomial-time.** -/ +theorem memFlagFn_mem_FP {Rf uf Vf : List Bool → List Bool} + (hR : Rf ∈ FP) (hu : uf ∈ FP) (hV : Vf ∈ FP) : + (fun z => memFlag (Rf z) (uf z) (Vf z)) ∈ FP := by + have hinit : (fun z => memPack (Rf z) (uf z) [false] (Vf z)) ∈ FP := + Cobham.pairFn_mem_FP hR + (Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hu (constFn_mem_FP [false])) hV) + have hbound : ∀ z, ∀ n ≤ (Vf z).length, + (memStep^[n] (memPack (Rf z) (uf z) [false] (Vf z))).length + ≤ (memPack (Rf z) (uf z) [false] (Vf z)).length := + fun z n _ => memStep_iterate_length_le (Rf z) (uf z) ([false], Vf z) (Or.inr rfl) n + have h := Cobham.iterate_mem_FP memStep_mem_FP hinit hV hinit hbound + have hcomp : (fun z => Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock + (memStep^[(Vf z).length] (memPack (Rf z) (uf z) [false] (Vf z)))))) ∈ FP := by + have h1 := mem_FP_comp h Cobham.sndBlock_mem_FP + have h2 := mem_FP_comp h1 Cobham.fstBlock_mem_FP + have h3 := mem_FP_comp h2 Cobham.sndBlock_mem_FP + simpa [Function.comp] using h3 + exact hcomp + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BlockSearch.lean b/Complexitylib/Classes/Containments/Internal/BlockSearch.lean new file mode 100644 index 00000000..897b2b0b --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BlockSearch.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BlockMember +public import Complexitylib.Models.TuringMachine.Branch + +/-! +# The worklist search over encoded configurations + +⚠️ Unreviewed by Bolton + +The configuration graph of a space-bounded machine is searched by a worklist: a +visited string holds the codes found so far, one fixed-width record each, and a +counter says which record is expanded next. One step expands one record — it +appends each of its two successors that is not already there — and advances the +counter. Running the loop for as many steps as there are configurations expands +everything, since the counter passes every record the search will ever hold. + +The encoding is the one Cobham's theorem already uses: `Cobham.cfgCode` packs a +configuration into `2(k+2)+1` fixed-width blocks and `Cobham.stepFn` is the +encoded step of a deterministic machine, so `NTM.branchTM` supplies the two +successors. + +## Main definitions + +- `Complexity.nstepFn` — the encoded successor along one branch +- `Complexity.addBlock` — append a record unless it is already there +- `Complexity.searchStepPair` — one worklist step, on the unpacked state +- `Complexity.searchStep` — the same on the packed state + +## Main results + +- `Complexity.searchStep_pack` — the packed step is the unpacked step +- `Complexity.searchStep_mem_FP` — one step is polynomial-time +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## Rulers for a whole code -/ + +/-- A code's width, as a ruler: `m` copies of the block ruler. -/ +def wideRuler (m : ℕ) (R : List Bool) : List Bool := (List.replicate m R).flatten + +@[simp] theorem wideRuler_length (m : ℕ) (R : List Bool) : + (wideRuler m R).length = m * R.length := by + rw [wideRuler, List.length_flatten] + simp [List.sum_replicate] + +/-- Every constant number of copies of a polynomial-time value is +polynomial-time. -/ +theorem wideRulerFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) (m : ℕ) : + (fun z => wideRuler m (a z)) ∈ FP := by + induction m with + | zero => exact mem_FP_of_eq (constFn_mem_FP []) (fun _ => rfl) + | succ m ih => + refine mem_FP_of_eq (Cobham.appendFn_mem_FP ha ih) fun z => ?_ + simp only [wideRuler, List.replicate_succ, List.flatten_cons] + +/-- Normalise a would-be code to exactly the code width. -/ +def fitCode (m : ℕ) (R b : List Bool) : List Bool := padTo (wideRuler m R) b + +@[simp] theorem fitCode_length (m : ℕ) (R b : List Bool) : + (fitCode m R b).length = m * R.length := by + rw [fitCode, padTo_length, wideRuler_length] + +/-- A value already of the code width is unchanged. -/ +theorem fitCode_of_length (m : ℕ) (R b : List Bool) (h : b.length = m * R.length) : + fitCode m R b = b := by + rw [fitCode, padTo_eq_append _ _ (by rw [wideRuler_length]; omega), wideRuler_length, h] + simp + +theorem fitCodeFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (m : ℕ) : (fun z => fitCode m (a z) (b z)) ∈ FP := + padToFn_mem_FP (wideRulerFn_mem_FP ha m) hb + +/-! ## The encoded successors -/ + +/-- The encoded successor of a configuration along branch `b`. -/ +noncomputable def nstepFn (tm : NTM k) (b : Bool) (R z : List Bool) : List Bool := + stepFn (tm.branchTM b) R z + +theorem nstepFnFn_mem_FP (tm : NTM k) (b : Bool) {a c : List Bool → List Bool} + (ha : a ∈ FP) (hc : c ∈ FP) : (fun z => nstepFn tm b (a z) (c z)) ∈ FP := + binFn_mem_FP (g := nstepFn tm b) + (Cobham.stepFn_mem (tm.branchTM b) (Cobham.proj 0) (Cobham.proj 1)) ha hc + +/-! ## One step of the search -/ + +/-- Append a record to the visited string unless it is already there. -/ +def addBlock (R b V : List Bool) : List Bool := selectHead (memFlag R b V) V (V ++ b) + +theorem addBlock_eq_self (R b V : List Bool) (h : memFlag R b V = [true]) : + addBlock R b V = V := by + rw [addBlock, selectHead, if_pos (by rw [h]; rfl)] + +theorem addBlock_eq_append (R b V : List Bool) (h : memFlag R b V = [false]) : + addBlock R b V = V ++ b := by + rw [addBlock, selectHead, if_neg (by rw [h]; simp), if_pos (by rw [h]; rfl)] + +theorem addBlockFn_mem_FP {a b c : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (hc : c ∈ FP) : (fun z => addBlock (a z) (b z) (c z)) ∈ FP := + Cobham.selectHeadFn_mem_FP (memFlagFn_mem_FP ha hb hc) hc + (Cobham.appendFn_mem_FP hc hb) + +/-- The record the counter points at. -/ +def curBlock (m : ℕ) (R r V : List Bool) : List Bool := + blockAt (wideRuler m R) V r.length + +theorem curBlockFn_mem_FP {a b c : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (hc : c ∈ FP) (m : ℕ) : (fun z => curBlock m (a z) (b z) (c z)) ∈ FP := by + refine mem_FP_of_eq (Cobham.takeLenFn_mem_FP (wideRulerFn_mem_FP ha m) + (dropLenFn_mem_FP (Cobham.mulLenFn_mem_FP hb (wideRulerFn_mem_FP ha m)) hc)) + fun z => ?_ + rw [curBlock, blockAt] + simp + +/-- The visited string must be at least this long for the record to exist. -/ +def guardRuler (m : ℕ) (R r : List Bool) : List Bool := + List.replicate ((false :: r).length * (wideRuler m R).length) false + +theorem guardRulerFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (m : ℕ) : (fun z => guardRuler m (a z) (b z)) ∈ FP := by + have hcons : (fun z => false :: b z) ∈ FP := by + have := mem_FP_comp hb (Cobham.cons_mem_FP false) + simpa [Function.comp] using this + exact Cobham.mulLenFn_mem_FP hcons (wideRulerFn_mem_FP ha m) + +@[simp] theorem guardRuler_length (m : ℕ) (R r : List Bool) : + (guardRuler m R r).length = (r.length + 1) * (m * R.length) := by + rw [guardRuler, List.length_replicate, wideRuler_length, List.length_cons] + +/-- Expanding one record: append each successor that is not already there. -/ +noncomputable def searchBody (tm : NTM k) (m : ℕ) (R r V : List Bool) : List Bool := + addBlock (wideRuler m R) (fitCode m R (nstepFn tm true R (curBlock m R r V))) + (addBlock (wideRuler m R) (fitCode m R (nstepFn tm false R (curBlock m R r V))) V) + +theorem searchBodyFn_mem_FP (tm : NTM k) (m : ℕ) {a b c : List Bool → List Bool} + (ha : a ∈ FP) (hb : b ∈ FP) (hc : c ∈ FP) : + (fun z => searchBody tm m (a z) (b z) (c z)) ∈ FP := by + have hcur := curBlockFn_mem_FP ha hb hc m + have hstep : ∀ β : Bool, (fun z => fitCode m (a z) + (nstepFn tm β (a z) (curBlock m (a z) (b z) (c z)))) ∈ FP := + fun β => fitCodeFn_mem_FP ha (nstepFnFn_mem_FP tm β ha hcur) m + exact addBlockFn_mem_FP (wideRulerFn_mem_FP ha m) (hstep true) + (addBlockFn_mem_FP (wideRulerFn_mem_FP ha m) (hstep false) hc) + +/-- One step of the worklist search, on the unpacked state `(counter, visited)`. +The counter is a ruler whose length is the index of the record to expand. -/ +noncomputable def searchStepPair (tm : NTM k) (m : ℕ) (R : List Bool) + (s : List Bool × List Bool) : List Bool × List Bool := + if (guardRuler m R s.1).length ≤ s.2.length then + (false :: s.1, searchBody tm m R s.1 s.2) + else (false :: s.1, s.2) + +/-- The packed search state: the ruler, the counter and the visited string. -/ +def searchPack (R r V : List Bool) : List Bool := pair R (pair r V) + +@[simp] theorem searchPack_length (R r V : List Bool) : + (searchPack R r V).length = 2 * R.length + 2 * r.length + V.length + 4 := by + rw [searchPack, pair_length, pair_length] + omega + +/-- One step of the worklist search, on the packed state. -/ +noncomputable def searchStep (tm : NTM k) (m : ℕ) (z : List Bool) : List Bool := + pair (fstBlock z) + (pair (false :: fstBlock (sndBlock z)) + (selectHead + (lenLeFlag (sndBlock (sndBlock z)) + (guardRuler m (fstBlock z) (fstBlock (sndBlock z)))) + (searchBody tm m (fstBlock z) (fstBlock (sndBlock z)) (sndBlock (sndBlock z))) + (sndBlock (sndBlock z)))) + +/-- **The packed step is the unpacked step.** -/ +theorem searchStep_pack (tm : NTM k) (m : ℕ) (R r V : List Bool) : + searchStep tm m (searchPack R r V) + = searchPack R (searchStepPair tm m R (r, V)).1 (searchStepPair tm m R (r, V)).2 := by + rw [searchStep, searchPack, searchStepPair] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + by_cases hle : (guardRuler m R r).length ≤ V.length + · rw [if_pos hle, selectHead, + if_pos (by rw [(Cobham.lenLeFlag_eq_true_iff V (guardRuler m R r)).mpr hle]; rfl)] + rfl + · have hflag : lenLeFlag V (guardRuler m R r) = [false] := by + rcases Cobham.lenLeFlag_flag V (guardRuler m R r) with h | h + · rw [Cobham.lenLeFlag_eq_true_iff V (guardRuler m R r)] at h + omega + · exact h + rw [if_neg hle, selectHead, if_neg (by rw [hflag]; simp), if_pos (by rw [hflag]; rfl)] + rfl + +/-- **The packed iteration is the unpacked one.** -/ +theorem searchStep_iterate (tm : NTM k) (m : ℕ) (R : List Bool) + (s : List Bool × List Bool) (n : ℕ) : + (searchStep tm m)^[n] (searchPack R s.1 s.2) + = searchPack R ((searchStepPair tm m R)^[n] s).1 ((searchStepPair tm m R)^[n] s).2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, searchStep_pack, ih (searchStepPair tm m R s), + Function.iterate_succ_apply] + +/-- **One search step is polynomial-time.** -/ +theorem searchStep_mem_FP (tm : NTM k) (m : ℕ) : searchStep tm m ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hR := hfst hid + have hw := hsnd hid + have hr := hfst hw + have hV := hsnd hw + have hcons : (fun z => false :: fstBlock (sndBlock z)) ∈ FP := by + have := mem_FP_comp hr (Cobham.cons_mem_FP false) + simpa [Function.comp] using this + exact Cobham.pairFn_mem_FP hR (Cobham.pairFn_mem_FP hcons + (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hV (guardRulerFn_mem_FP hR hr m)) + (searchBodyFn_mem_FP tm m hR hr hV) hV)) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BlockSearchCorrect.lean b/Complexitylib/Classes/Containments/Internal/BlockSearchCorrect.lean new file mode 100644 index 00000000..e70cee47 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BlockSearchCorrect.lean @@ -0,0 +1,377 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.CodeStep + +/-! +# What the worklist search finds + +⚠️ Unreviewed by Bolton + +The invariant of the search: the visited string is a list of distinct records, +each the code of a configuration reachable from the initial one; the initial +code is among them; and every record the counter has passed has both of its +successors recorded. + +Once the counter has passed every record — which it has after as many steps as +there are configurations, since the records are distinct — the recorded codes +are closed under the graph's steps, so every reachable configuration's code is +there. + +## Main definitions + +- `Complexity.recordWidth` — the width of one record +- `Complexity.SearchOk` — the invariant + +## Main results + +- `Complexity.memFlag_records` — the scan decides membership in the record list +- `Complexity.searchStepPair_ok` — one step preserves the invariant +- `Complexity.SearchOk.mem_of_reachesCfg` — a saturated search has found + everything +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## Records -/ + +/-- The width of one record: a whole code. -/ +def recordWidth (k W : ℕ) : ℕ := codeBlocks k * (blockRuler W).length + +theorem recordWidth_pos (k W : ℕ) : 0 < recordWidth k W := by + rw [recordWidth, blockRuler_length, blockWidth, codeBlocks] + positivity + +theorem wideRuler_blockRuler_length (k W : ℕ) : + (wideRuler (codeBlocks k) (blockRuler W)).length = recordWidth k W := by + rw [wideRuler_length, recordWidth] + +/-- The records of a concatenation are its blocks. -/ +theorem blockAt_records (k W : ℕ) (bs : List (List Bool)) + (hbs : ∀ b ∈ bs, b.length = recordWidth k W) (i : ℕ) (hi : i < bs.length) : + blockAt (wideRuler (codeBlocks k) (blockRuler W)) bs.flatten i = bs[i] := + blockAt_flatten _ _ (fun b hb => by + rw [hbs b hb, wideRuler_blockRuler_length]) i hi + +theorem length_flatten_records (k W : ℕ) (bs : List (List Bool)) + (hbs : ∀ b ∈ bs, b.length = recordWidth k W) : + bs.flatten.length = bs.length * recordWidth k W := by + induction bs with + | nil => simp + | cons b bs ih => + rw [List.flatten_cons, List.length_append, hbs b List.mem_cons_self, + ih (fun c hc => hbs c (List.mem_cons_of_mem _ hc)), List.length_cons, Nat.succ_mul] + omega + +/-- **The scan decides membership in the record list.** -/ +theorem memFlag_records (k W : ℕ) (bs : List (List Bool)) + (hbs : ∀ b ∈ bs, b.length = recordWidth k W) (u : List Bool) : + memFlag (wideRuler (codeBlocks k) (blockRuler W)) u bs.flatten = [true] ↔ u ∈ bs := by + have hw : 0 < (wideRuler (codeBlocks k) (blockRuler W)).length := by + rw [wideRuler_blockRuler_length] + exact recordWidth_pos k W + rw [memFlag_eq_true_iff _ _ _ hw, wideRuler_blockRuler_length, + length_flatten_records k W bs hbs] + constructor + · rintro ⟨i, hlen, hblk⟩ + have hi : i < bs.length := by + by_contra hcon + have : bs.length * recordWidth k W ≤ i * recordWidth k W := + Nat.mul_le_mul_right _ (by omega) + have := recordWidth_pos k W + omega + rw [blockAt_records k W bs hbs i hi] at hblk + exact hblk ▸ List.getElem_mem hi + · intro hu + obtain ⟨i, hi, hbi⟩ := List.getElem_of_mem hu + refine ⟨i, ?_, ?_⟩ + · have : (i + 1) * recordWidth k W ≤ bs.length * recordWidth k W := + Nat.mul_le_mul_right _ (by omega) + rw [Nat.succ_mul] at this + omega + · rw [blockAt_records k W bs hbs i hi] + exact hbi + +/-! ## Appending a record -/ + +/-- The appended record was not there before. -/ +theorem addBlock_nodup (k W : ℕ) (bs : List (List Bool)) + (hbs : ∀ b ∈ bs, b.length = recordWidth k W) (b : List Bool) (hnd : bs.Nodup) + (hm : memFlag (wideRuler (codeBlocks k) (blockRuler W)) b bs.flatten = [false]) : + (bs ++ [b]).Nodup := by + have hnb : b ∉ bs := by + intro hmem + have := (memFlag_records k W bs hbs b).mpr hmem + rw [hm] at this + simp at this + rw [List.nodup_append] + exact ⟨hnd, List.nodup_singleton b, by + intro a ha c hc + rw [List.mem_singleton] at hc + rintro rfl + exact hnb (hc ▸ ha)⟩ + +/-! ## The invariant -/ + +/-- The records of a list of configurations. -/ +noncomputable def codesOf {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (cs : List (Cfg k Q)) : List (List Bool) := + cs.map (Cobham.cfgCode W) + +theorem codesOf_recordWidth {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (cs : List (Cfg k Q)) : ∀ b ∈ codesOf W cs, b.length = recordWidth k W := by + intro b hb + obtain ⟨c, -, rfl⟩ := List.mem_map.mp hb + rw [cfgCode_length, recordWidth] + +@[simp] theorem codesOf_length {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (cs : List (Cfg k Q)) : (codesOf W cs).length = cs.length := by + rw [codesOf, List.length_map] + +theorem codesOf_getElem {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (cs : List (Cfg k Q)) (i : ℕ) (hi : i < cs.length) : + (codesOf W cs)[i]'(by rwa [codesOf_length]) = Cobham.cfgCode W cs[i] := + List.getElem_map _ + +@[simp] theorem codesOf_append {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (cs : List (Cfg k Q)) (c : Cfg k Q) : + codesOf W (cs ++ [c]) = codesOf W cs ++ [Cobham.cfgCode W c] := by + rw [codesOf, codesOf, List.map_append, List.map_singleton] + +/-- The search state is sound: the visited string is the concatenation of the codes +of finitely many reachable configurations, no two of them coded alike; the initial +code is there; and every record the counter has passed has both successors +recorded. -/ +def SearchOk (tm : NTM k) (x : List Bool) (W : ℕ) (r V : List Bool) : Prop := + ∃ cs : List (Cfg k tm.Q), + V = (codesOf W cs).flatten ∧ (codesOf W cs).Nodup ∧ + (∀ c ∈ cs, tm.ReachesCfg (tm.initCfg x) c) ∧ + Cobham.cfgCode W (tm.initCfg x) ∈ codesOf W cs ∧ + ∀ i, i < r.length → ∀ hi : i < cs.length, ∀ β : Bool, + nstepFn tm β (blockRuler W) (Cobham.cfgCode W cs[i]) ∈ codesOf W cs + +/-- The initial state is sound. -/ +theorem searchOk_init (tm : NTM k) (x : List Bool) (W : ℕ) : + SearchOk tm x W [] (Cobham.cfgCode W (tm.initCfg x)) := by + refine ⟨[tm.initCfg x], by simp [codesOf], by simp [codesOf], ?_, by simp [codesOf], ?_⟩ + · intro c hc + rw [List.mem_singleton] at hc + rw [hc] + exact NTM.reachesCfg_refl tm _ + · intro i hi + simp at hi + +/-! ## One step preserves the invariant -/ + +/-- The two encoded successors of a reachable configuration are codes of +reachable configurations. -/ +theorem exists_succ_code (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) + {c : Cfg k tm.Q} (hc : tm.ReachesCfg (tm.initCfg x) c) (β : Bool) : + ∃ c', tm.ReachesCfg (tm.initCfg x) c' ∧ + nstepFn tm β (blockRuler W) (Cobham.cfgCode W c) = Cobham.cfgCode W c' := by + have hinv := codeInv_of_reachesCfg tm hdec x hc W hW + by_cases hh : c.state = tm.qhalt + · exact ⟨c, hc, nstepFn_code_halted tm β W c hq hinv hh⟩ + · exact ⟨tm.stepCfg β c, hc.tail ⟨hh, β, rfl⟩, nstepFn_code tm β W c hq hinv hh⟩ + +/-- Adding one successor keeps every part of the invariant. -/ +theorem searchOk_add (tm : NTM k) (x : List Bool) (W : ℕ) (cs : List (Cfg k tm.Q)) + (hnd : (codesOf W cs).Nodup) (hreach : ∀ d ∈ cs, tm.ReachesCfg (tm.initCfg x) d) + {c : Cfg k tm.Q} (hc : tm.ReachesCfg (tm.initCfg x) c) : + ∃ cs' : List (Cfg k tm.Q), + addBlock (wideRuler (codeBlocks k) (blockRuler W)) (Cobham.cfgCode W c) + (codesOf W cs).flatten = (codesOf W cs').flatten ∧ + (codesOf W cs').Nodup ∧ (∀ d ∈ cs', tm.ReachesCfg (tm.initCfg x) d) ∧ + (cs' = cs ∨ cs' = cs ++ [c]) ∧ Cobham.cfgCode W c ∈ codesOf W cs' := by + rcases memFlag_flag (wideRuler (codeBlocks k) (blockRuler W)) (Cobham.cfgCode W c) + (codesOf W cs).flatten with hm | hm + · exact ⟨cs, by rw [addBlock_eq_self _ _ _ hm], hnd, hreach, Or.inl rfl, + (memFlag_records k W _ (codesOf_recordWidth W cs) _).mp hm⟩ + · refine ⟨cs ++ [c], ?_, ?_, ?_, Or.inr rfl, by simp⟩ + · rw [addBlock_eq_append _ _ _ hm, codesOf_append, List.flatten_append] + simp + · rw [codesOf_append] + exact addBlock_nodup k W _ (codesOf_recordWidth W cs) _ hnd hm + · intro d hd + rw [List.mem_append, List.mem_singleton] at hd + rcases hd with hd | rfl + · exact hreach d hd + · exact hc + +/-- A list only grows at the end. -/ +theorem append_cases_prefix {α : Type} {cs cs' : List α} {c : α} + (h : cs' = cs ∨ cs' = cs ++ [c]) : + (∀ y ∈ cs, y ∈ cs') ∧ cs.length ≤ cs'.length ∧ + ∀ i, ∀ hi : i < cs.length, ∀ hi' : i < cs'.length, cs'[i] = cs[i] := by + rcases h with rfl | rfl + · exact ⟨fun _ hy => hy, le_rfl, fun _ _ _ => rfl⟩ + · exact ⟨fun y hy => List.mem_append_left _ hy, by simp, + fun i hi _ => List.getElem_append_left hi⟩ + +/-- **One step of the search preserves the invariant.** -/ +theorem searchStepPair_ok (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) + (r V : List Bool) (h : SearchOk tm x W r V) : + SearchOk tm x W (searchStepPair tm (codeBlocks k) (blockRuler W) (r, V)).1 + (searchStepPair tm (codeBlocks k) (blockRuler W) (r, V)).2 := by + obtain ⟨cs, rfl, hnd, hreach, hinit, hclos⟩ := h + have hbs := codesOf_recordWidth W cs + have hlen : (codesOf W cs).flatten.length = cs.length * recordWidth k W := by + rw [length_flatten_records k W _ hbs, codesOf_length] + have hpos := recordWidth_pos k W + have hguard : (guardRuler (codeBlocks k) (blockRuler W) r).length + = (r.length + 1) * recordWidth k W := by + rw [guardRuler_length, recordWidth] + rw [searchStepPair] + by_cases hg : (guardRuler (codeBlocks k) (blockRuler W) r).length + ≤ (codesOf W cs).flatten.length + · rw [if_pos hg] + have hj : r.length < cs.length := by + rw [hguard, hlen] at hg + by_contra hcon + have : cs.length * recordWidth k W ≤ r.length * recordWidth k W := + Nat.mul_le_mul_right _ (by omega) + have hexp : (r.length + 1) * recordWidth k W + = r.length * recordWidth k W + recordWidth k W := by ring + omega + have hj' : r.length < (codesOf W cs).length := by rwa [codesOf_length] + have hcur : curBlock (codeBlocks k) (blockRuler W) r (codesOf W cs).flatten + = Cobham.cfgCode W cs[r.length] := by + rw [curBlock, blockAt_records k W _ hbs r.length hj', codesOf_getElem] + have hc : tm.ReachesCfg (tm.initCfg x) cs[r.length] := + hreach _ (List.getElem_mem hj) + obtain ⟨c₀, hc₀, hstep₀⟩ := exists_succ_code tm hdec x W hq hW hc false + obtain ⟨c₁, hc₁, hstep₁⟩ := exists_succ_code tm hdec x W hq hW hc true + have hfit : ∀ (β : Bool) (d : Cfg k tm.Q), + nstepFn tm β (blockRuler W) (Cobham.cfgCode W cs[r.length]) = Cobham.cfgCode W d → + fitCode (codeBlocks k) (blockRuler W) + (nstepFn tm β (blockRuler W) + (curBlock (codeBlocks k) (blockRuler W) r (codesOf W cs).flatten)) + = Cobham.cfgCode W d := by + intro β d hd + rw [hcur, hd, fitCode_cfgCode] + obtain ⟨cs₁, hadd₁, hnd₁, hreach₁, hcases₁, hmem₁⟩ := + searchOk_add tm x W cs hnd hreach hc₀ + obtain ⟨cs₂, hadd₂, hnd₂, hreach₂, hcases₂, hmem₂⟩ := + searchOk_add tm x W cs₁ hnd₁ hreach₁ hc₁ + obtain ⟨hsub₁, hle₁, hget₁⟩ := append_cases_prefix hcases₁ + obtain ⟨hsub₂, hle₂, hget₂⟩ := append_cases_prefix hcases₂ + have hcsub : ∀ b ∈ codesOf W cs, b ∈ codesOf W cs₂ := by + intro b hb + obtain ⟨d, hd, rfl⟩ := List.mem_map.mp hb + exact List.mem_map_of_mem (hsub₂ _ (hsub₁ _ hd)) + have hcsub₁ : ∀ b ∈ codesOf W cs₁, b ∈ codesOf W cs₂ := by + intro b hb + obtain ⟨d, hd, rfl⟩ := List.mem_map.mp hb + exact List.mem_map_of_mem (hsub₂ _ hd) + refine ⟨cs₂, ?_, hnd₂, hreach₂, hcsub _ hinit, ?_⟩ + · show searchBody tm (codeBlocks k) (blockRuler W) r (codesOf W cs).flatten + = (codesOf W cs₂).flatten + rw [searchBody, hfit false c₀ hstep₀, hadd₁, hfit true c₁ hstep₁, hadd₂] + · intro i hi hi' β + have hi2 : i < r.length + 1 := hi + have hlt : i < cs.length := by omega + have hlt₁ : i < cs₁.length := by omega + have hbi : cs₂[i] = cs[i] := by + rw [hget₂ i hlt₁ hi', hget₁ i hlt hlt₁] + rw [hbi] + rcases Nat.lt_or_ge i r.length with hir | hir + · exact hcsub _ (hclos i hir hlt β) + · have hieq : i = r.length := by omega + subst hieq + cases β + · rw [hstep₀] + exact hcsub₁ _ hmem₁ + · rw [hstep₁] + exact hmem₂ + · rw [if_neg hg] + refine ⟨cs, rfl, hnd, hreach, hinit, ?_⟩ + intro i hi hi' β + have hi2 : i < r.length + 1 := hi + have hlt : i < r.length := by + rw [hguard, hlen] at hg + by_contra hcon + have hle : (r.length + 1) * recordWidth k W ≤ cs.length * recordWidth k W := + Nat.mul_le_mul_right _ (by omega) + omega + exact hclos i hlt hi' β + +/-! ## A saturated search has found everything -/ + +/-- **Once the counter has passed every record, the search is complete.** -/ +theorem searchOk_complete (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) + (r V : List Bool) (h : SearchOk tm x W r V) + (hsat : V.length ≤ r.length * recordWidth k W) {c : Cfg k tm.Q} + (hc : tm.ReachesCfg (tm.initCfg x) c) : + memFlag (wideRuler (codeBlocks k) (blockRuler W)) (Cobham.cfgCode W c) V = [true] := by + obtain ⟨cs, rfl, hnd, hreach, hinit, hclos⟩ := h + have hbs := codesOf_recordWidth W cs + have hlen : (codesOf W cs).flatten.length = cs.length * recordWidth k W := by + rw [length_flatten_records k W _ hbs, codesOf_length] + have hpos := recordWidth_pos k W + have hbr : cs.length ≤ r.length := by + rw [hlen] at hsat + by_contra hcon + have : (r.length + 1) * recordWidth k W ≤ cs.length * recordWidth k W := + Nat.mul_le_mul_right _ (by omega) + have hexp : (r.length + 1) * recordWidth k W + = r.length * recordWidth k W + recordWidth k W := by ring + omega + refine (memFlag_records k W _ hbs _).mpr ?_ + induction hc with + | refl => exact hinit + | tail hbefore hstep ih => + rename_i c' c'' + obtain ⟨d, hd, hdeq⟩ := List.mem_map.mp ih + obtain ⟨i, hi, hieq⟩ := List.getElem_of_mem hd + obtain ⟨hne, β, rfl⟩ := hstep + have hkey := hclos i (by omega) hi β + rw [hieq, hdeq, nstepFn_code tm β W _ hq + (codeInv_of_reachesCfg tm hdec x hbefore W hW) hne] at hkey + exact hkey + +/-! ## How long the visited string can get -/ + +/-- **The visited string is bounded by the configuration count.** The records are +distinct and each is the code of a reachable configuration, and distinct +configurations of the graph have distinct codes in the finite type of +`Complexitylib.Classes.Containments.Internal.ConfigCount`. -/ +theorem searchOk_length_le (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) (r V : List Bool) + (h : SearchOk tm x W r V) : + V.length ≤ Fintype.card (Code tm.Q k x.length (S x.length)) * recordWidth k W := by + obtain ⟨cs, rfl, hnd, hreach, -, -⟩ := h + rw [length_flatten_records k W _ (codesOf_recordWidth W cs), codesOf_length] + refine Nat.mul_le_mul_right _ ?_ + have hspace : ∀ c', tm.ReachesCfg (tm.initCfg x) c' → + c'.WithinDecisionSpace x.length (S x.length) := + fun c' hc' => NTM.withinDecisionSpace_of_reachesCfg hdec x hc' + have hwin : ∀ c ∈ cs, Windowed x (S x.length) c := fun c hc => + windowed_of_reachesCfg hspace (windowed_init tm.qstart x (S x.length)) (hreach c hc) + have hcsnd : cs.Nodup := List.Nodup.of_map _ hnd + have hinj : ∀ c ∈ cs, ∀ d ∈ cs, + cfgCode x.length (S x.length) c = cfgCode x.length (S x.length) d → c = d := by + intro c hc d hd heq + exact cfgCode_inj (hwin c hc) (hspace c (hreach c hc)) (hwin d hd) + (hspace d (hreach d hd)) heq + have hmapnd : (cs.map (cfgCode x.length (S x.length))).Nodup := + List.Nodup.map_on hinj hcsnd + calc cs.length = (cs.map (cfgCode x.length (S x.length))).length := by + rw [List.length_map] + _ ≤ Fintype.card (Code tm.Q k x.length (S x.length)) := List.Nodup.length_le_card hmapnd + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BoundedReach.lean b/Complexitylib/Classes/Containments/Internal/BoundedReach.lean new file mode 100644 index 00000000..184b4c65 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BoundedReach.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.ReachSet +public import Complexitylib.Classes.Containments.Internal.LogSpaceBound +public import Complexitylib.Classes.L +public import Complexitylib.Classes.Containments.Internal.PolyWindow + +/-! +# Acceptance is a bounded search in the configuration graph + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.ConfigGraph` turns acceptance into reachability, and +`Complexitylib.Classes.Containments.Internal.ReachSet` turns reachability into a fixpoint whose +round count is the number of configuration codes. This file joins the two for a space-bounded +machine: the codes of `Complexitylib.Classes.Containments.Internal.ConfigCount` separate the +reachable configurations, so the search terminates after `Fintype.card (Code …)` rounds — and for +a log-space machine that count is polynomial. + +The result is the specification `NL ⊆ P` has to implement: a language in `NL` is exactly a +polynomially bounded breadth-first search in the configuration graph, with no residual reference +to nondeterminism, traces, or time. + +## Main results + +- `NTM.DecidesInSpace.mono` — deciding in space is monotone in the bound +- `NTM.withinDecisionSpace_of_reachesCfg` — the space bound holds along the whole graph +- `NTM.cfgCode_inj_of_reachesCfg` — codes separate the reachable configurations +- `NTM.mem_iff_exists_mem_reachSet` — membership is a search of enough rounds +- `NL_bounded_reachability_internal` — for `NL` the round count is polynomially bounded +- `NL_subset_P_of_search_internal` — the containment, modulo one machine +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} {tm : NTM k} + +/-- Deciding in space `S` is deciding in any larger space bound. -/ +theorem DecidesInSpace.mono {L : Language} {S S' : ℕ → ℕ} (hle : ∀ n, S n ≤ S' n) + (h : tm.DecidesInSpace L S) : tm.DecidesInSpace L S' := by + obtain ⟨T, hdt, hsp⟩ := h + exact ⟨T, hdt, fun x choices t' ht => (hsp x choices t' ht).mono (hle x.length)⟩ + +/-- **The space bound holds at every configuration of the graph.** `DecidesInSpace` states the +bound along traces no longer than the halting time; past that time a trace is frozen, so the +bound propagates to every reachable configuration. -/ +theorem withinDecisionSpace_of_reachesCfg {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {c : Cfg k tm.Q} + (h : tm.ReachesCfg (tm.initCfg x) c) : + c.WithinDecisionSpace x.length (S x.length) := by + obtain ⟨T, hdt, hsp⟩ := hdec + obtain ⟨t, choices, rfl⟩ := exists_trace_of_reachesCfg h + rcases Nat.lt_or_ge (T x.length) t with hlt | hge + · -- beyond the halting time the trace is its own length-`T` prefix + have hfrozen := tm.trace_mono (T := T x.length) (T' := t) hlt.le + (choices := fun j => choices ⟨j.val, by omega⟩) (choices' := choices) + (fun _ => rfl) (hdt.1 x _) + rw [hfrozen] + exact hsp x (fun j => choices ⟨j.val, by omega⟩) (T x.length) le_rfl + · -- within the halting time, pad the choice sequence out to length `T` + have hpad := hsp x (fun j => if hj : j.val < t then choices ⟨j.val, hj⟩ else false) t hge + have heq : (fun j : Fin t => if hj : j.val < t then choices ⟨j.val, hj⟩ else false) + = choices := by + funext j + simp [j.isLt] + rw [heq] at hpad + exact hpad + +/-- The initial configuration and everything reachable from it stays inside the window. -/ +theorem windowed_of_reachesCfg_init {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {c : Cfg k tm.Q} + (h : tm.ReachesCfg (tm.initCfg x) c) : + Windowed x (S x.length) c := + windowed_of_reachesCfg (fun _ hc' => withinDecisionSpace_of_reachesCfg hdec x hc') + (windowed_init tm.qstart x _) h + +/-- **Codes separate the reachable configurations.** This is what bounds the search: distinct +reachable configurations have distinct codes, of which there are only finitely many. -/ +theorem cfgCode_inj_of_reachesCfg {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {c c' : Cfg k tm.Q} + (hc : tm.ReachesCfg (tm.initCfg x) c) (hc' : tm.ReachesCfg (tm.initCfg x) c') + (heq : cfgCode x.length (S x.length) c = cfgCode x.length (S x.length) c') : + c = c' := + cfgCode_inj (windowed_of_reachesCfg_init hdec x hc) + (withinDecisionSpace_of_reachesCfg hdec x hc) + (windowed_of_reachesCfg_init hdec x hc') + (withinDecisionSpace_of_reachesCfg hdec x hc') heq + +/-- **Membership is a bounded breadth-first search.** An input is in the language exactly when +an accepting configuration shows up within any number of rounds of successor-closure from the +initial configuration that reaches the number of codes. Nothing here mentions traces, choices, +or time. -/ +theorem mem_iff_exists_mem_reachSet {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {N : ℕ} + (hN : Fintype.card (Code tm.Q k x.length (S x.length)) ≤ N) : + x ∈ L ↔ ∃ c ∈ reachSet tm (tm.initCfg x) N, + tm.halted c ∧ c.output.cells 1 = Γ.one := by + rw [mem_iff_exists_accepting_reachable hdec x] + constructor + · rintro ⟨c, hreach, hhalt, hout⟩ + exact ⟨c, (reachesCfg_iff_mem_reachSet tm _ (cfgCode x.length (S x.length)) + (fun hc hc' => cfgCode_inj_of_reachesCfg hdec x hc hc') (N := N) hN c).mp hreach, hhalt, hout⟩ + · rintro ⟨c, hmem, hhalt, hout⟩ + exact ⟨c, reachesCfg_of_mem_reachSet tm _ _ hmem, hhalt, hout⟩ + +end NTM + +/-- **A language in `NL` is a polynomially bounded reachability search.** This is the +specification a polynomial-time decision procedure has to implement: run the successor-closure +for `A · (|x| + 1) ^ B` rounds and look for an accepting configuration. -/ +theorem NL_bounded_reachability_internal {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (A B : ℕ), + ∀ x : List Bool, x ∈ L ↔ + ∃ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + tm.halted c ∧ c.output.cells 1 = Γ.one := by + obtain ⟨k, tm, S, _, hdec, hS⟩ := hL + obtain ⟨A, B, hAB⟩ := exists_config_bound (k := k) tm.Q hS + exact ⟨k, tm, A, B, fun x => NTM.mem_iff_exists_mem_reachSet hdec x (hAB x.length)⟩ + + +/-- **`NL ⊆ P`, reduced to the existence of one machine.** The hypothesis carries the log-space +witness for `tm`: without it the search language is not decidable at all, let alone in polynomial +time, since the configuration graph would be unbounded. -/ +theorem NL_subset_P_of_search_internal + (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (A B : ℕ), + tm.DecidesInSpace L₀ S → S =O (fun n => Nat.log 2 n) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + M.DecidesInTime + {x : List Bool | ∃ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + tm.halted c ∧ c.output.cells 1 = Γ.one} + (fun n => q.eval n)) : + NL ⊆ P := by + intro L hL + obtain ⟨k, tm, S, -, hdec, hS⟩ := hL + obtain ⟨A, B, hAB⟩ := exists_config_bound (k := k) tm.Q hS + obtain ⟨k', M, q, hM⟩ := h k tm S L A B hdec hS + refine mem_P_of_polyTime M q ?_ + have hLeq : L = {x : List Bool | + ∃ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + tm.halted c ∧ c.output.cells 1 = Γ.one} := by + ext x + exact NTM.mem_iff_exists_mem_reachSet hdec x (hAB x.length) + rw [hLeq] + exact hM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/CodeAccept.lean b/Complexitylib/Classes/Containments/Internal/CodeAccept.lean new file mode 100644 index 00000000..f5cc2784 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/CodeAccept.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.CodeRewind + +/-! +# Deciding whether a record is accepting + +⚠️ Unreviewed by Bolton + +A record is accepting when its state field is the halting state and its output +tape holds `1` in cell `1`. The state field is block `0` truncated to the state +code's width, and the verdict cell is read after the rewind of +`Complexitylib.Classes.Containments.Internal.CodeRewind`. + +## Main definitions + +- `Complexity.verdictSym` — the symbol in cell `1` of a rewound output code +- `Complexity.acceptFlag` — the accepting-record test + +## Main results + +- `Complexity.verdictSym_rewound` — what the verdict cell reads +- `Complexity.acceptFlag_cfgCode` — the test decides acceptance +- `Complexity.acceptFlagFn_mem_FP` — the test is polynomial-time +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The verdict cell -/ + +/-- The symbol in cell `1` of a rewound output code. -/ +def verdictSym (R z : List Bool) : List Bool := ((z.drop R.length).drop 2).take 2 + +/-- **The verdict cell of a rewound output code is cell `1` of the tape.** -/ +theorem verdictSym_rewound (W : ℕ) (t : Tape) (hW : 1 ≤ W) : + verdictSym (blockRuler W) (pairCode W { head := 0, cells := t.cells }) + = symCode (t.cells 1) := by + rw [verdictSym, drop_pairCode_rewound W t, + show W + 1 = 1 + 1 + (W - 1) from by omega, cellsCode_add, cellsCode_add] + simp only [cellsCode_one, List.append_assoc] + rw [List.drop_left' (by rw [symCode_length]), List.take_left' (by rw [symCode_length])] + +/-! ## The test -/ + +/-- Is the record an accepting halting configuration? -/ +def acceptFlag (qcode R ruler u : List Bool) : List Bool := + andBit (eqFlag ((blockAt R u 0).take qcode.length) qcode) + (eqFlag (verdictSym R (rewindCode R ruler (outPair R u))) (symCode Γ.one)) + +theorem acceptFlag_flag (qcode R ruler u : List Bool) : + acceptFlag qcode R ruler u = [true] ∨ acceptFlag qcode R ruler u = [false] := by + rw [acceptFlag] + rcases eqFlag_flag ((blockAt R u 0).take qcode.length) qcode with h | h <;> + rcases eqFlag_flag (verdictSym R (rewindCode R ruler (outPair R u))) + (symCode Γ.one) with h' | h' <;> rw [h, h'] <;> simp [andBit] + +/-- **The test decides acceptance.** -/ +theorem acceptFlag_cfgCode (tm : NTM k) (W : ℕ) (c : Cfg k tm.Q) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hinv : CodeInv W c) (hW : 1 ≤ W) + (ruler : List Bool) (hruler : W ≤ ruler.length) : + acceptFlag (stateCode tm.qhalt) (blockRuler W) ruler (Cobham.cfgCode W c) = [true] ↔ + c.state = tm.qhalt ∧ c.output.cells 1 = Γ.one := by + have hout : c.output.StartInvariant := + hinv.start _ (by simp [cfgTapes]) + have houth : c.output.head ≤ W := hinv.head _ (by simp [cfgTapes]) + have hstate : (blockAt (blockRuler W) (Cobham.cfgCode W c) 0).take + (stateCode tm.qhalt).length = stateCode c.state := by + rw [stateCode_length] + exact state_of_cfgCode W c hq + have hverdict : verdictSym (blockRuler W) + (rewindCode (blockRuler W) ruler (outPair (blockRuler W) (Cobham.cfgCode W c))) + = symCode (c.output.cells 1) := by + rw [outPair_cfgCode, rewindCode_pairCode W c.output hout houth ruler hruler, + verdictSym_rewound W c.output hW] + rw [acceptFlag, andBit_eq_true_iff (eqFlag_flag _ _) (eqFlag_flag _ _), + eqFlag_eq_true_iff, eqFlag_eq_true_iff, hstate, hverdict] + constructor + · rintro ⟨h1, h2⟩ + exact ⟨stateCode_injective h1, symCode_injective h2⟩ + · rintro ⟨h1, h2⟩ + exact ⟨by rw [h1], by rw [h2]⟩ + +/-! ## The test is polynomial-time -/ + +theorem acceptFlagFn_mem_FP (qcode : List Bool) {Rf rulerf uf : List Bool → List Bool} + (hR : Rf ∈ FP) (hruler : rulerf ∈ FP) (hu : uf ∈ FP) : + (fun w => acceptFlag qcode (Rf w) (rulerf w) (uf w)) ∈ FP := by + have hqc : (fun _ : List Bool => qcode) ∈ FP := constFn_mem_FP qcode + have hstate : (fun w => (blockAt (Rf w) (uf w) 0).take qcode.length) ∈ FP := by + refine mem_FP_of_eq (Cobham.takeLenFn_mem_FP hqc (blockAtFn_mem_FP hR hu 0)) fun w => rfl + have hout : (fun w => outPair (Rf w) (uf w)) ∈ FP := outPairFn_mem_FP hR hu + have hlen : ∀ w, (outPair (Rf w) (uf w)).length ≤ 2 * (Rf w).length := by + intro w + rw [outPair, List.length_append, blockAt, blockAt] + have h1 := List.length_take_le (Rf w).length ((uf w).drop (3 * (Rf w).length)) + have h2 := List.length_take_le (Rf w).length ((uf w).drop (4 * (Rf w).length)) + omega + have hrew : (fun w => rewindCode (Rf w) (rulerf w) (outPair (Rf w) (uf w))) ∈ FP := + rewindCodeFn_mem_FP hR hruler hout hlen + have hverd : (fun w => verdictSym (Rf w) + (rewindCode (Rf w) (rulerf w) (outPair (Rf w) (uf w)))) ∈ FP := by + refine mem_FP_of_eq (Cobham.takeLenFn_mem_FP (constFn_mem_FP [false, false]) + (dropLenFn_mem_FP (constFn_mem_FP [false, false]) (dropLenFn_mem_FP hR hrew))) + fun w => rfl + exact andBitFn_mem_FP (eqFlagFn_mem_FP hstate hqc) + (eqFlagFn_mem_FP hverd (constFn_mem_FP (symCode Γ.one))) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/CodeRewind.lean b/Complexitylib/Classes/Containments/Internal/CodeRewind.lean new file mode 100644 index 00000000..dbc2a938 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/CodeRewind.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.CodeStep + +/-! +# Reading the verdict cell out of a record + +⚠️ Unreviewed by Bolton + +Acceptance is a property of cell `1` of the output tape, but a code stores each +tape split at its head, so where cell `1` sits depends on the head. Driving the +head back to cell `0` first puts it in a fixed place: the encoding's right +half-block is then the whole tape in order, two bits per cell, so cell `1` is +bits `2` and `3`. + +That is the same rewind the completeness direction of Cobham's theorem uses to +read a simulated machine's output, `Cobham.rewindFn`, run here as a loop of its +own. + +## Main definitions + +- `Complexity.outPair` — the output tape's two blocks, read out of a record +- `Complexity.rewindStepP` — one rewind step, on the packed state +- `Complexity.rewindCode` — a whole rewind + +## Main results + +- `Complexity.outPair_cfgCode` — the two blocks are the output tape's code +- `Complexity.rewindCode_pairCode` — a long enough rewind parks the head +- `Complexity.rewindStepP_mem_FP`, `Complexity.rewindCodeFn_mem_FP` — both are + polynomial-time +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The output tape inside a record -/ + +/-- Block `3` is the output tape's left half. -/ +theorem blockAt_cfgCode_outputLeft {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (c : Cfg k Q) : + blockAt (blockRuler W) (Cobham.cfgCode W c) 3 + = padTo (blockRuler W) (leftCode c.output) := by + rw [blockAt_cfgCode W c 3 (by rw [cfgBlocks_length]; omega)] + rfl + +/-- Block `4` is the output tape's right half. -/ +theorem blockAt_cfgCode_outputRight {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (c : Cfg k Q) : + blockAt (blockRuler W) (Cobham.cfgCode W c) 4 + = padTo (blockRuler W) (rightCode c.output W) := by + rw [blockAt_cfgCode W c 4 (by rw [cfgBlocks_length]; omega)] + rfl + +/-- The output tape's code, read out of a record. -/ +def outPair (R u : List Bool) : List Bool := blockAt R u 3 ++ blockAt R u 4 + +theorem outPairFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => outPair (a z) (b z)) ∈ FP := + Cobham.appendFn_mem_FP (blockAtFn_mem_FP ha hb 3) (blockAtFn_mem_FP ha hb 4) + +/-- **The two blocks are the output tape's code.** -/ +theorem outPair_cfgCode {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) (c : Cfg k Q) : + outPair (blockRuler W) (Cobham.cfgCode W c) = pairCode W c.output := by + rw [outPair, blockAt_cfgCode_outputLeft, blockAt_cfgCode_outputRight, pairCode] + +/-! ## The rewind loop -/ + +/-- One rewind step, on the packed state `pair R z`. -/ +def rewindStepP (z : List Bool) : List Bool := + pair (fstBlock z) (rewindFn (fstBlock z) (sndBlock z)) + +theorem rewindStepP_pack (R z : List Bool) : + rewindStepP (pair R z) = pair R (rewindFn R z) := by + rw [rewindStepP, fstBlock_pair, sndBlock_pair] + +theorem rewindStepP_iterate (R z : List Bool) (n : ℕ) : + rewindStepP^[n] (pair R z) = pair R ((rewindFn R)^[n] z) := by + induction n generalizing z with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, rewindStepP_pack, ih, Function.iterate_succ_apply] + +/-- A whole rewind: one step per bit of the ruler. -/ +def rewindCode (R ruler z : List Bool) : List Bool := + sndBlock (rewindStepP^[ruler.length] (pair R z)) + +theorem rewindCode_eq (R ruler z : List Bool) : + rewindCode R ruler z = (rewindFn R)^[ruler.length] z := by + rw [rewindCode, rewindStepP_iterate, sndBlock_pair] + +/-- **A long enough rewind parks the head at cell `0`.** -/ +theorem rewindCode_pairCode (W : ℕ) (t : Tape) (hinv : t.StartInvariant) + (hW : t.head ≤ W) (ruler : List Bool) (hlen : W ≤ ruler.length) : + rewindCode (blockRuler W) ruler (pairCode W t) + = pairCode W { head := 0, cells := t.cells } := by + rw [rewindCode_eq, iterate_rewindFn t hinv hW ruler.length, + rewound t (le_trans hW hlen)] + +/-! ## Both are polynomial-time -/ + +theorem rewindFnFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => rewindFn (a z) (b z)) ∈ FP := + binFn_mem_FP (g := rewindFn) (Cobham.rewindFn_mem (Cobham.proj 0) (Cobham.proj 1)) ha hb + +theorem rewindStepP_mem_FP : rewindStepP ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : (fun z => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + exact Cobham.pairFn_mem_FP hfst (rewindFnFn_mem_FP hfst hsnd) + +/-- **The rewind is polynomial-time.** -/ +theorem rewindCodeFn_mem_FP {Rf rulerf zf : List Bool → List Bool} (hR : Rf ∈ FP) + (hruler : rulerf ∈ FP) (hz : zf ∈ FP) + (hlen : ∀ w, (zf w).length ≤ 2 * (Rf w).length) : + (fun w => rewindCode (Rf w) (rulerf w) (zf w)) ∈ FP := by + have hinit : (fun w => pair (Rf w) (zf w)) ∈ FP := Cobham.pairFn_mem_FP hR hz + have hwidth : (fun w => pair (Rf w) (wideRuler 2 (Rf w))) ∈ FP := + Cobham.pairFn_mem_FP hR (wideRulerFn_mem_FP hR 2) + have hbound : ∀ w, ∀ n ≤ (rulerf w).length, + (rewindStepP^[n] (pair (Rf w) (zf w))).length + ≤ (pair (Rf w) (wideRuler 2 (Rf w))).length := by + intro w n _ + rw [rewindStepP_iterate, pair_length, pair_length, wideRuler_length] + have := Cobham.iterate_rewindFn_length_le (Rf w) (zf w) (hlen w) n + omega + have h := Cobham.iterate_mem_FP rewindStepP_mem_FP hinit hruler hwidth hbound + have h2 := mem_FP_comp h Cobham.sndBlock_mem_FP + refine mem_FP_of_eq h2 fun w => ?_ + rw [Function.comp_apply, rewindCode] + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/CodeSearch.lean b/Complexitylib/Classes/Containments/Internal/CodeSearch.lean new file mode 100644 index 00000000..a65b51e8 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/CodeSearch.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BoundedReach + +/-! +# The reachability search as a finite computation on codes + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.BoundedReach` reduces membership to a bounded +breadth-first search in the configuration graph, but the rounds there are `Set (Cfg k tm.Q)` — +a specification, not a computation. This file replays the same search on the *codes* of +`Complexitylib.Classes.Containments.Internal.ConfigCount`: a round is a `Finset` operation on a +finite type, so the whole search is a finite, decidable iteration. + +The bridge is a decoder. `cfgCode` forgets nothing about a configuration that respects the space +window, so it has a left inverse there, and the successor of a code is simply the code of the +successor of the configuration it denotes. + +For a log-space machine the code type has polynomially many elements, so a round set is a +polynomially sized object and the search runs for polynomially many rounds — this is the data +structure a polynomial-time implementation manipulates. + +## Main definitions + +- `decodeCfg` — rebuild a configuration from its code +- `NTM.codeSucc`, `NTM.codeRound`, `NTM.reachCodes` — the search, on `Finset`s of codes + +## Main results + +- `decodeCfg_cfgCode` — decoding inverts coding inside the window +- `NTM.mem_reachCodes_iff` — the code search computes exactly the specified rounds +- `NTM.mem_iff_exists_mem_reachCodes` — membership as a finite search +- `logWindow_bigO` — the concrete window is still `O(log n)` +- `NL_finite_search` — for `NL`, a finite search whose window, round count, and accept test are + all explicit arithmetic in the input length +-/ + +@[expose] public section + +namespace Complexity + +variable {k : ℕ} {Q : Type} + +/-- Rebuild a configuration from its code. The input tape is restored from the input itself — +it is read-only — and each work and output cell beyond the window is restored to the blank that +the window invariant guarantees is there. -/ +def decodeCfg (x : List Bool) (S : ℕ) (a : Code Q k x.length S) : Cfg k Q where + state := a.1 + input := { head := a.2.1.val, cells := (Tape.init (x.map Γ.ofBool)).cells } + work := fun i => + { head := (a.2.2.1 i).1.val + cells := fun p => if h : p < S + 1 then (a.2.2.1 i).2 ⟨p, h⟩ else Γ.blank } + output := + { head := a.2.2.2.1.val + cells := fun p => if h : p < S + 2 then a.2.2.2.2 ⟨p, h⟩ else Γ.blank } + +/-- **Decoding inverts coding on the configurations the search meets.** Inside the space window +the clamps in `cfgCode` are inert and the cells it drops are the ones `Windowed` pins down, so +nothing is lost. -/ +theorem decodeCfg_cfgCode {x : List Bool} {S : ℕ} {c : Cfg k Q} + (hw : Windowed x S c) (hs : c.WithinDecisionSpace x.length S) : + decodeCfg x S (cfgCode x.length S c) = c := by + refine Cfg.ext rfl ?_ ?_ ?_ + · refine Tape.ext ?_ hw.input.symm + have : c.input.head ≤ x.length + S + 1 := hs.1.2 + simpa [decodeCfg, cfgCode] using by omega + · funext i + have hh : (c.work i).head ≤ S := hs.1.1 i + refine Tape.ext ?_ ?_ + · simpa [decodeCfg, cfgCode] using by omega + · funext p + by_cases hp : p < S + 1 + · simp only [decodeCfg, cfgCode, dif_pos hp] + · simp only [decodeCfg, cfgCode, dif_neg hp] + exact (hw.work i p (by omega)).symm + · have hh : c.output.head ≤ S + 1 := hs.2 + refine Tape.ext ?_ ?_ + · simpa [decodeCfg, cfgCode] using by omega + · funext p + by_cases hp : p < S + 2 + · simp only [decodeCfg, cfgCode, dif_pos hp] + · simp only [decodeCfg, cfgCode, dif_neg hp] + exact (hw.output p (by omega)).symm + +namespace NTM + +variable {tm : NTM k} + +/-- The codes of the successors of the configuration a code denotes. -/ +def codeSucc (tm : NTM k) (x : List Bool) (S : ℕ) (a : Code tm.Q k x.length S) : + Finset (Code tm.Q k x.length S) := + if (decodeCfg x S a).state = tm.qhalt then ∅ + else {cfgCode x.length S (tm.stepCfg false (decodeCfg x S a)), + cfgCode x.length S (tm.stepCfg true (decodeCfg x S a))} + +/-- One round of the search: keep what is known and add every successor code. -/ +def codeRound (tm : NTM k) (x : List Bool) (S : ℕ) + (F : Finset (Code tm.Q k x.length S)) : Finset (Code tm.Q k x.length S) := + F ∪ F.biUnion (codeSucc tm x S) + +/-- The search: `t` rounds of successor-closure starting from a single code. -/ +def reachCodes (tm : NTM k) (x : List Bool) (S : ℕ) (a₀ : Code tm.Q k x.length S) : + ℕ → Finset (Code tm.Q k x.length S) + | 0 => {a₀} + | t + 1 => codeRound tm x S (reachCodes tm x S a₀ t) + +/-- **The code search computes exactly the specified rounds.** Every code in round `t` is the +code of a configuration in round `t`, and conversely. -/ +theorem mem_reachCodes_iff {x : List Bool} {S : ℕ} {c₀ : Cfg k tm.Q} + (hs : ∀ c, tm.ReachesCfg c₀ c → c.WithinDecisionSpace x.length S) + (hw : ∀ c, tm.ReachesCfg c₀ c → Windowed x S c) : + ∀ (t : ℕ) (a : Code tm.Q k x.length S), + a ∈ reachCodes tm x S (cfgCode x.length S c₀) t ↔ + ∃ c ∈ reachSet tm c₀ t, cfgCode x.length S c = a := by + intro t + induction t with + | zero => + intro a + simp only [reachCodes, Finset.mem_singleton, reachSet, Set.mem_singleton_iff] + exact ⟨fun h => ⟨c₀, rfl, h.symm⟩, fun ⟨c, hc, hca⟩ => by rw [hc] at hca; exact hca.symm⟩ + | succ t ih => + intro a + simp only [reachCodes, codeRound, Finset.mem_union, Finset.mem_biUnion, reachSet_succ, + Set.mem_union, Set.mem_setOf_eq] + constructor + · rintro (h | ⟨b, hb, hab⟩) + · obtain ⟨c, hc, hca⟩ := (ih a).mp h + exact ⟨c, Or.inl hc, hca⟩ + · obtain ⟨c, hc, rfl⟩ := (ih b).mp hb + have hreach := reachesCfg_of_mem_reachSet tm c₀ t hc + rw [codeSucc, decodeCfg_cfgCode (hw c hreach) (hs c hreach)] at hab + by_cases hhalt : c.state = tm.qhalt + · rw [if_pos hhalt] at hab; exact absurd hab (Finset.notMem_empty a) + · rw [if_neg hhalt, Finset.mem_insert, Finset.mem_singleton] at hab + rcases hab with rfl | rfl + · exact ⟨tm.stepCfg false c, Or.inr ⟨c, hc, hhalt, false, rfl⟩, rfl⟩ + · exact ⟨tm.stepCfg true c, Or.inr ⟨c, hc, hhalt, true, rfl⟩, rfl⟩ + · rintro ⟨c, hc | ⟨c', hc', hhalt, b, rfl⟩, rfl⟩ + · exact Or.inl ((ih _).mpr ⟨c, hc, rfl⟩) + · refine Or.inr ⟨cfgCode x.length S c', (ih _).mpr ⟨c', hc', rfl⟩, ?_⟩ + have hreach := reachesCfg_of_mem_reachSet tm c₀ t hc' + rw [codeSucc, decodeCfg_cfgCode (hw c' hreach) (hs c' hreach), if_neg hhalt] + cases b + · exact Finset.mem_insert_self _ _ + · exact Finset.mem_insert_of_mem (Finset.mem_singleton_self _) + +/-- **Membership is a finite search over codes.** Every quantifier is over a finite type and +every operation is a `Finset` operation, so this is an algorithm — what remains for `NL ⊆ P` is +to bound its cost. -/ +theorem mem_iff_exists_mem_reachCodes {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {N : ℕ} + (hN : Fintype.card (Code tm.Q k x.length (S x.length)) ≤ N) : + x ∈ L ↔ ∃ a ∈ reachCodes tm x (S x.length) + (cfgCode x.length (S x.length) (tm.initCfg x)) N, + (decodeCfg x (S x.length) a).state = tm.qhalt ∧ + (decodeCfg x (S x.length) a).output.cells 1 = Γ.one := by + have hs : ∀ c, tm.ReachesCfg (tm.initCfg x) c → c.WithinDecisionSpace x.length (S x.length) := + fun _ h => withinDecisionSpace_of_reachesCfg hdec x h + have hw : ∀ c, tm.ReachesCfg (tm.initCfg x) c → Windowed x (S x.length) c := + fun _ h => windowed_of_reachesCfg_init hdec x h + rw [mem_iff_exists_mem_reachSet hdec x hN] + constructor + · rintro ⟨c, hmem, hhalt, hout⟩ + refine ⟨cfgCode x.length (S x.length) c, (mem_reachCodes_iff hs hw _ _).mpr ⟨c, hmem, rfl⟩, ?_⟩ + have hreach := reachesCfg_of_mem_reachSet tm _ _ hmem + rw [decodeCfg_cfgCode (hw c hreach) (hs c hreach)] + exact ⟨hhalt, hout⟩ + · rintro ⟨a, hmem, hhalt, hout⟩ + obtain ⟨c, hc, rfl⟩ := (mem_reachCodes_iff hs hw _ _).mp hmem + have hreach := reachesCfg_of_mem_reachSet tm _ _ hc + rw [decodeCfg_cfgCode (hw c hreach) (hs c hreach)] at hhalt hout + exact ⟨c, hc, hhalt, hout⟩ + +end NTM + +/-- The concrete window is still a logarithmic bound, so the code count over it stays +polynomial. -/ +theorem logWindow_bigO (C D : ℕ) : logWindow C D =O (fun n => Nat.log 2 n) := + BigO.add (BigO.const_mul_left C (BigO.refl _)) (BigO.const_le_logTwo D) + +/-- **A language in `NL` is a finite search of polynomially many rounds.** Every quantity in +this statement is an explicit arithmetic function of the input length and finitely many machine +constants: the window is `logWindow C D |x|`, the round count is `A · (|x| + 1) ^ B`, the rounds +are `Finset`s of codes over that window, and the accept test is a decidable property of a single +code. No trace, choice sequence, machine time bound, or asymptotic quantifier survives. This is +the specification a polynomial-time implementation has to run; what remains for `NL ⊆ P` is to +account for its cost. -/ +theorem NL_finite_search {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (C D A B : ℕ), + ∀ x : List Bool, x ∈ L ↔ + ∃ a ∈ NTM.reachCodes tm x (logWindow C D x.length) + (cfgCode x.length (logWindow C D x.length) (tm.initCfg x)) + (A * (x.length + 1) ^ B), + (decodeCfg x (logWindow C D x.length) a).state = tm.qhalt ∧ + (decodeCfg x (logWindow C D x.length) a).output.cells 1 = Γ.one := by + obtain ⟨k, tm, S, _, hdec, hS⟩ := hL + obtain ⟨C, D, hCD⟩ := exists_log_bound hS + have hdec' : tm.DecidesInSpace L (logWindow C D) := + NTM.DecidesInSpace.mono (fun n => hCD n) hdec + obtain ⟨A, B, hAB⟩ := exists_config_bound (k := k) tm.Q (logWindow_bigO C D) + exact ⟨k, tm, C, D, A, B, fun x => NTM.mem_iff_exists_mem_reachCodes hdec' x (hAB x.length)⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/CodeStep.lean b/Complexitylib/Classes/Containments/Internal/CodeStep.lean new file mode 100644 index 00000000..ed2953e6 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/CodeStep.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BlockSearch +public import Complexitylib.Classes.Containments.Internal.BoundedReach + +/-! +# What the encoded step does to a reachable configuration + +⚠️ Unreviewed by Bolton + +`Cobham.stepFn` tracks a machine's step only on configurations that respect the +encoding's window: every head inside it, every tape carrying its left-end +marker. This file collects those side conditions into `Complexity.CodeInv`, +shows that every configuration of a space-bounded machine's configuration graph +satisfies it, and reads off what `Complexity.nstepFn` computes there. + +## Main definitions + +- `Complexity.CodeInv` — the encoding's side conditions on a configuration + +## Main results + +- `Complexity.cfgCode_length` — a code is exactly `2(k+2)+1` blocks wide +- `Complexity.nstepFn_code`, `Complexity.nstepFn_code_halted` — the encoded + successor is the code of the successor +- `Complexity.codeInv_of_reachesCfg` — the graph stays inside the window +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The width of a code -/ + +/-- The number of blocks in a code: one for the state and two per tape. -/ +def codeBlocks (k : ℕ) : ℕ := 2 * (k + 2) + 1 + +private theorem length_flatten_const {α : Type} (bs : List (List α)) (w : ℕ) + (h : ∀ b ∈ bs, b.length = w) : bs.flatten.length = bs.length * w := by + induction bs with + | nil => simp + | cons b bs ih => + rw [List.flatten_cons, List.length_append, h b (List.mem_cons_self), + ih (fun c hc => h c (List.mem_cons_of_mem _ hc)), List.length_cons, Nat.succ_mul] + omega + +/-- **A code is exactly `2(k+2)+1` blocks wide.** -/ +@[simp] theorem cfgCode_length {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) + (c : Cfg k Q) : + (Cobham.cfgCode W c).length = codeBlocks k * (blockRuler W).length := by + rw [Cobham.cfgCode, length_flatten_const _ _ (cfgBlocks_width W c), cfgBlocks_length, codeBlocks] + +/-- A code is unchanged by the width normalisation. -/ +theorem fitCode_cfgCode {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) (c : Cfg k Q) : + fitCode (codeBlocks k) (blockRuler W) (Cobham.cfgCode W c) = Cobham.cfgCode W c := + fitCode_of_length _ _ _ (cfgCode_length W c) + +/-! ## The window conditions -/ + +/-- The side conditions under which the encoded step tracks the real one. -/ +structure CodeInv {Q : Type} (W : ℕ) (c : Cfg k Q) : Prop where + /-- Every tape carries its left-end marker. -/ + start : ∀ t ∈ cfgTapes c, t.StartInvariant + /-- Every head is inside the encoded window. -/ + head : ∀ t ∈ cfgTapes c, t.head ≤ W + +/-- **The encoded successor is the code of the successor.** -/ +theorem nstepFn_code (tm : NTM k) (b : Bool) (W : ℕ) (c : Cfg k tm.Q) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hinv : CodeInv W c) + (hne : c.state ≠ tm.qhalt) : + nstepFn tm b (blockRuler W) (Cobham.cfgCode W c) = Cobham.cfgCode W (tm.stepCfg b c) := by + rw [nstepFn] + refine stepFn_eq (tm.branchTM b) (c := c) (NTM.branchTM_step tm b hne) hq hinv.head + (hinv.start _ (by simp [cfgTapes])) (fun i => hinv.start _ ?_) + (stepActs_forall₂ (tm.branchTM b) c hinv.start hinv.head) + rw [cfgTapes] + exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ (List.mem_ofFn.mpr ⟨i, rfl⟩)) + +/-- A halted configuration is a fixed point of the encoded step. -/ +theorem nstepFn_code_halted (tm : NTM k) (b : Bool) (W : ℕ) (c : Cfg k tm.Q) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hinv : CodeInv W c) + (hhalt : c.state = tm.qhalt) : + nstepFn tm b (blockRuler W) (Cobham.cfgCode W c) = Cobham.cfgCode W c := by + rw [nstepFn] + exact stepFn_halted (tm.branchTM b) (c := c) hhalt hq hinv.head + +/-! ## The graph stays inside the window -/ + +/-- Every configuration of the graph carries its left-end markers. -/ +theorem startInvariant_of_reachesCfg (tm : NTM k) (x : List Bool) {c : Cfg k tm.Q} + (h : tm.ReachesCfg (tm.initCfg x) c) : + c.input.StartInvariant ∧ (∀ i, (c.work i).StartInvariant) ∧ + c.output.StartInvariant := by + induction h with + | refl => + exact ⟨Tape.StartInvariant.init_ofBool x, fun _ => Tape.StartInvariant.init_nil, + Tape.StartInvariant.init_nil⟩ + | tail _ hstep ih => + obtain ⟨b, hb⟩ := (NTM.succ_iff tm _ _).mp hstep + exact TM.step_startInvariant (tm.branchTM b) hb ih.1 ih.2.1 ih.2.2 + +/-- **The graph stays inside the encoded window.** -/ +theorem codeInv_of_reachesCfg (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {c : Cfg k tm.Q} + (h : tm.ReachesCfg (tm.initCfg x) c) (W : ℕ) + (hW : x.length + S x.length + 1 ≤ W) : CodeInv W c := by + obtain ⟨hin, hwork, hout⟩ := startInvariant_of_reachesCfg tm x h + have hsp := NTM.withinDecisionSpace_of_reachesCfg hdec x h + refine ⟨fun t ht => ?_, fun t ht => ?_⟩ <;> + · rw [cfgTapes, List.mem_cons, List.mem_cons, List.mem_ofFn] at ht + rcases ht with rfl | rfl | ⟨i, rfl⟩ + · first + | exact hin + | (have := hsp.1.2; omega) + · first + | exact hout + | (have := hsp.2; omega) + · first + | exact hwork i + | (have := hsp.1.1 i; omega) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/ComplementSpace.lean b/Complexitylib/Classes/Containments/Internal/ComplementSpace.lean new file mode 100644 index 00000000..2c437eda --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/ComplementSpace.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Complement +public import Complexitylib.Models.TuringMachine.Combinators.Internal.IdleHeads +public import Complexitylib.Models.TuringMachine.Frame +public import Complexitylib.Classes.P.Defs + +/-! +# `PSPACE` is closed under complement + +⚠️ Unreviewed by Bolton + +`TM.complementTM` already flips a decider's verdict, and `TM.complementTM_decidesInTime` accounts +for its time. The space account is what `PH ⊆ PSPACE` needs, and it is not immediate: the space +predicate constrains *every reachable configuration*, so it is not enough to know where the +machine ends up — one has to know that no configuration along the way strays outside the window. + +The complement machine has three phases. In the first it simulates the source machine, so every +configuration it meets is an embedded reachable configuration of that machine and inherits its +bound. In the other two it idles every tape except the output, whose head it walks left to the +marker and then one cell right. The one lemma that makes the accounting work is that an *idle* +move on a tape carrying its left marker sends the head to `max head 1` — it bounces off cell `0` +and otherwise stands still — so no head can drift outward however long the rewind takes. One +extra cell therefore covers the whole construction. + +The head-bounce lemmas it uses are shared with the loop combinator and live in +`Complexitylib.Models.TuringMachine.Combinators.Internal.IdleHeads`. + +## Main definitions + +- `TM.CompInv` — the invariant carried along a run of the complement machine + +## Main results + +- `TM.complement_head_bound` — after the simulation, no head passes `max head 1` +- `TM.complementTM_withinDecisionSpace` — every reachable configuration stays in the window +- `TM.complementTM_decidesInSpace` — the complement is decided in space `S + 1` +- `DSPACE_compl` — a space class with room for one more cell is closed under complement +- `PSPACE_compl` — **`PSPACE` is closed under complement** +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **After the simulation, the complement machine never grows a head beyond `max head 1`.** +Every phase idles the input and work tapes, and moves the output head right only when it is +sitting on the left marker. -/ +theorem complement_head_bound (tm : TM n) {c c' : Cfg n tm.complementTM.Q} + (hnotsim : ∀ q, c.state = Sum.inl q → q = tm.qhalt) + (hstep : tm.complementTM.step c = some c') + (hinp : c.input.StartInvariant) (hwork : ∀ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.head ≤ max c.input.head 1 ∧ + (∀ i, (c'.work i).head ≤ max (c.work i).head 1) ∧ + c'.output.head ≤ max c.output.head 1 := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + rcases hstate : c.state with q | ph + · have hq : q = tm.qhalt := hnotsim q hstate + subst hq + refine ⟨?_, fun i => ?_, ?_⟩ <;> + simp only [complementTM, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + · cases ph with + | rewind => + refine ⟨?_, fun i => ?_, ?_⟩ <;> + simp only [complementTM] + · split <;> exact head_move_idleDir_le_max hinp + · split <;> exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · split + · rename_i hread + refine head_writeAndMove_le_max _ _ _ fun _ => ?_ + by_contra hh + exact (hout.2 c.output.head (by omega)) hread + · exact head_writeAndMove_le_max _ _ _ (by nofun) + | flip => + refine ⟨?_, fun i => ?_, ?_⟩ <;> + simp only [complementTM] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + | done => exact absurd hstate hne + +/-- After the simulation phase the machine never returns to it. -/ +theorem complement_state_of_step (tm : TM n) {c c' : Cfg n tm.complementTM.Q} + (hnotsim : ∀ q, c.state = Sum.inl q → q = tm.qhalt) + (hstep : tm.complementTM.step c = some c') : + ∃ ph, c'.state = Sum.inr ph := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + rcases hstate : c.state with q | ph + · have hq : q = tm.qhalt := hnotsim q hstate + subst hq + exact ⟨ComplementPhase.rewind, by simp only [complementTM, ↓reduceIte]⟩ + · cases ph with + | rewind => + by_cases hread : c.output.read = Γ.start + · exact ⟨ComplementPhase.flip, by simp only [complementTM, hread, ↓reduceIte]⟩ + · exact ⟨ComplementPhase.rewind, by simp only [complementTM, hread, ↓reduceIte]⟩ + | flip => exact ⟨ComplementPhase.done, by simp only [complementTM]⟩ + | done => exact absurd hstate hne + +/-- The invariant carried along a run of the complement machine: every tape keeps its left +marker, the simulation phase only ever holds an embedded reachable configuration of the source +machine, and every later phase respects the space bound with one cell to spare. -/ +def CompInv (tm : TM n) (x : List Bool) (s : ℕ) (c : Cfg n tm.complementTM.Q) : Prop := + c.input.StartInvariant ∧ (∀ i, (c.work i).StartInvariant) ∧ c.output.StartInvariant ∧ + (∀ q, c.state = Sum.inl q → ∃ c₀, tm.reaches (tm.initCfg x) c₀ ∧ c = complementCfg tm c₀) ∧ + (∀ ph, c.state = Sum.inr ph → c.WithinDecisionSpace x.length (s + 1)) + +/-- **The invariant is preserved by a step.** -/ +theorem CompInv.step {tm : TM n} {L : Language} {S : ℕ → ℕ} (hdec : tm.DecidesInSpace L S) + (x : List Bool) {c c' : Cfg n tm.complementTM.Q} + (hinv : CompInv tm x (S x.length) c) + (hstep : tm.complementTM.step c = some c') : + CompInv tm x (S x.length) c' := by + obtain ⟨hinp, hwork, hout, hsim, hspace⟩ := hinv + obtain ⟨hinp', hwork', hout'⟩ := Tape.StartInvariant.step tm.complementTM hstep hinp hwork hout + by_cases hnotsim : ∀ q, c.state = Sum.inl q → q = tm.qhalt + · obtain ⟨hi, hw, ho⟩ := complement_head_bound tm hnotsim hstep hinp hwork hout + obtain ⟨ph', hph'⟩ := complement_state_of_step tm hnotsim hstep + have hc : c.WithinDecisionSpace x.length (S x.length + 1) := by + rcases hstate : c.state with q | ph + · obtain ⟨c₀, hreach, rfl⟩ := hsim q hstate + have h := hdec.1 x c₀ hreach + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · show (c₀.work i).head ≤ _ + have := h.1.1 i + omega + · show c₀.input.head ≤ _ + have := h.1.2 + omega + · show c₀.output.head ≤ _ + have := h.2 + omega + · exact hspace ph hstate + refine ⟨hinp', hwork', hout', ?_, ?_⟩ + · intro q hq + rw [hph'] at hq + exact absurd hq (by nofun) + · intro _ _ + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have h₁ := hw i + have h₂ := hc.1.1 i + omega + · have h₂ := hc.1.2 + omega + · have h₂ := hc.2 + omega + · push Not at hnotsim + obtain ⟨q, hstate, hq⟩ := hnotsim + obtain ⟨c₀, hreach, rfl⟩ := hsim q hstate + have hqc : q = c₀.state := (Sum.inl.injEq _ _ ▸ hstate).symm + have hq0 : c₀.state ≠ tm.qhalt := by rw [← hqc]; exact hq + obtain ⟨c₀', hstep0⟩ : ∃ c₀', tm.step c₀ = some c₀' := by + rw [TM.step, if_neg hq0]; exact ⟨_, rfl⟩ + have hsimstep : tm.complementTM.step (complementCfg tm c₀) = some (complementCfg tm c₀') := by + have h := complementTM_simulation tm (TM.reachesIn.step hstep0 TM.reachesIn.zero) + cases h with + | step h₁ h₂ => cases h₂; exact h₁ + have hc'eq : c' = complementCfg tm c₀' := + Option.some_inj.mp (hstep.symm.trans hsimstep) + subst hc'eq + refine ⟨hinp', hwork', hout', ?_, ?_⟩ + · intro _ _ + exact ⟨c₀', Relation.ReflTransGen.tail hreach hstep0, rfl⟩ + · intro ph hph + exact absurd hph (by nofun) + +/-- The invariant holds at the start of the run. -/ +theorem CompInv.init (tm : TM n) (x : List Bool) (s : ℕ) : + CompInv tm x s (tm.complementTM.initCfg x) := by + refine ⟨startInvariant_initOfBool x, fun _ => startInvariant_initNil, + startInvariant_initNil, ?_, ?_⟩ + · intro _ _ + exact ⟨tm.initCfg x, Relation.ReflTransGen.refl, (compCfg_initCfg tm x).symm⟩ + · intro _ hph + exact absurd hph (by nofun) + +/-- The invariant holds at every reachable configuration. -/ +theorem CompInv.reaches {tm : TM n} {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {c : Cfg n tm.complementTM.Q} + (h : tm.complementTM.reaches (tm.complementTM.initCfg x) c) : + CompInv tm x (S x.length) c := by + induction h with + | refl => exact CompInv.init tm x (S x.length) + | tail _ hstep ih => exact ih.step hdec x hstep + +/-- **The complement machine respects the space bound with one cell to spare.** -/ +theorem complementTM_withinDecisionSpace {tm : TM n} {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) {c : Cfg n tm.complementTM.Q} + (h : tm.complementTM.reaches (tm.complementTM.initCfg x) c) : + c.WithinDecisionSpace x.length (S x.length + 1) := by + obtain ⟨-, -, -, hsim, hspace⟩ := CompInv.reaches hdec x h + rcases hstate : c.state with q | ph + · obtain ⟨c₀, hreach, rfl⟩ := hsim q hstate + have hb := hdec.1 x c₀ hreach + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · show (c₀.work i).head ≤ _ + have := hb.1.1 i + omega + · show c₀.input.head ≤ _ + have := hb.1.2 + omega + · show c₀.output.head ≤ _ + have := hb.2 + omega + · exact hspace ph hstate + +/-- **The complement machine decides the complement, in one more cell of space.** -/ +theorem complementTM_decidesInSpace {tm : TM n} {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) : + tm.complementTM.DecidesInSpace Lᶜ (fun m => S m + 1) := by + refine ⟨fun x c' h => complementTM_withinDecisionSpace hdec x h, fun x => ?_⟩ + obtain ⟨c', hreach, hhalt, hyes, hno⟩ := hdec.2 x + obtain ⟨t, hreachIn⟩ := TM.reaches_to_reachesIn tm hreach + have hsim := complementTM_simulation tm hreachIn + rw [compCfg_initCfg] at hsim + have hcell0 := output_cells_zero_eq_start_of_reachesIn hreachIn (by simp [Tape.init]) + have hnostart := output_cells_ne_start_of_reachesIn hreachIn (by + intro i hi; simp [Tape.init]; omega) + obtain ⟨c_done, t_rw, hreach_rw, hhalt_done, hflip, -⟩ := + complementTM_rewind_and_flip tm c' hhalt hcell0 hnostart + have htotal := reachesIn_trans tm.complementTM hsim hreach_rw + refine ⟨c_done, ?_, hhalt_done, ?_, ?_⟩ + · exact TM.reachesIn.rec Relation.ReflTransGen.refl + (fun hs _ ih => Relation.ReflTransGen.head hs ih) htotal + · intro hxc + rw [hflip, hno hxc] + simp [flipBit] + · intro hxc + simp only [Set.mem_compl_iff, not_not] at hxc + rw [hflip, hyes hxc] + simp [flipBit] + +end TM + +/-- **A space class with room for one more cell is closed under complement.** The one extra cell +is what the rewind to the verdict cell costs. -/ +theorem DSPACE_compl {L : Language} {S : ℕ → ℕ} (hone : (fun _ => 1) =O S) + (h : L ∈ DSPACE S) : Lᶜ ∈ DSPACE S := by + obtain ⟨m, tm, f, hdec, hf⟩ := h + exact ⟨m, tm.complementTM, fun j => f j + 1, + TM.complementTM_decidesInSpace hdec, BigO.add hf hone⟩ + +/-- **`PSPACE` is closed under complement.** The same machine runs, then rewinds its output head +to the verdict cell and flips the bit; the rewind only moves heads leftward or off the left +marker, so it costs one extra cell of space and no more. -/ +theorem PSPACE_compl {L : Language} (h : L ∈ PSPACE) : Lᶜ ∈ PSPACE := by + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp h + exact Set.mem_iUnion.mpr ⟨k, DSPACE_compl (BigO.const_le_pow 1 k) hk⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/ConfigCount.lean b/Complexitylib/Classes/Containments/Internal/ConfigCount.lean new file mode 100644 index 00000000..0ef49ed1 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/ConfigCount.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.SpaceTime.Defs +public import Mathlib.Tactic.Ring + +/-! +# Counting the configurations inside a space bound + +⚠️ Unreviewed by Bolton + +`Cfg.WithinDecisionSpace` bounds head *positions*, but counting configurations also needs to know +the tape *contents* are pinned down. A head that never leaves its window can never write outside +it, so every cell beyond still holds what it started with — that is `Windowed`, and it is what +makes the configuration space finite. + +Nothing here mentions a machine: the counting is the same for deterministic and nondeterministic +configurations, and both `PSPACE ⊆ EXP` and the log-space graph arguments use it. + +## Main definitions + +- `Windowed` — the tapes agree with their initial contents outside the window +- `cfgCode` — a total code for configurations, injective inside the space bound +- `instDecidableEqCode` — codes have decidable equality + +## Main results + +- `Windowed.mono`, `Cfg.WithinDecisionSpace.mono` — enlarging the window is harmless +- `cfgCode_inj` — two windowed configurations inside the bound with the same code are equal +- `card_Code` — the number of codes +- `card_Code_le_two_pow` — the count is at most `2` to a linear-in-`S` exponent +-/ + +@[expose] public section + +namespace Complexity + +variable {k : ℕ} {Q : Type} + +/-- Outside the space window every tape still holds what it started with: the input tape is +read-only, and the work and output tapes are blank beyond the reach of their heads. -/ +structure Windowed (x : List Bool) (S : ℕ) (c : Cfg k Q) : Prop where + /-- The input tape is never written. -/ + input : c.input.cells = (Tape.init (x.map Γ.ofBool)).cells + /-- Work cells beyond the window are blank. -/ + work : ∀ (i : Fin k) (p : ℕ), S < p → (c.work i).cells p = Γ.blank + /-- Output cells beyond the window are blank. -/ + output : ∀ p : ℕ, S + 1 < p → c.output.cells p = Γ.blank + +/-- The initial configuration is windowed. -/ +theorem windowed_init (q : Q) (x : List Bool) (S : ℕ) : + Windowed (k := k) x S (Cfg.init q x) where + input := rfl + work := by + intro i p hp + show (Tape.init ([] : List Γ)).cells p = Γ.blank + obtain ⟨r, rfl⟩ : ∃ r, p = r + 1 := ⟨p - 1, by omega⟩ + simp + output := by + intro p hp + show (Tape.init ([] : List Γ)).cells p = Γ.blank + obtain ⟨r, rfl⟩ : ∃ r, p = r + 1 := ⟨p - 1, by omega⟩ + simp + +/-- Enlarging the window preserves the invariant: what is blank beyond `S` is blank beyond any +larger `S'` too. -/ +theorem Windowed.mono {x : List Bool} {S S' : ℕ} {c : Cfg k Q} + (h : Windowed x S c) (hS : S ≤ S') : Windowed x S' c where + input := h.input + work := fun i p hp => h.work i p (by omega) + output := fun p hp => h.output p (by omega) + +/-- Enlarging the space budget preserves a decision-space bound. -/ +theorem Cfg.WithinDecisionSpace.mono {n S S' : ℕ} {c : Cfg k Q} + (h : c.WithinDecisionSpace n S) (hS : S ≤ S') : c.WithinDecisionSpace n S' := + ⟨⟨fun i => (h.1.1 i).trans hS, by have := h.1.2; omega⟩, by have := h.2; omega⟩ + +/-- Writing at the head leaves every other cell alone. -/ +theorem cells_writeAndMove_of_ne (t : Tape) (s : Γ) (d : Dir3) {p : ℕ} (hp : p ≠ t.head) : + (t.writeAndMove s d).cells p = t.cells p := by + show ((t.write s).move d).cells p = t.cells p + have : (t.write s).cells p = t.cells p := by + rw [Tape.write] + split + · rfl + · exact Function.update_of_ne hp _ _ + cases d <;> exact this + +/-- A finite code for configurations inside the space window: the state, the three head +positions clamped into range, and the tape contents restricted to the window. -/ +abbrev Code (Q : Type) (k nn S : ℕ) : Type := + Q × Fin (nn + S + 2) × (Fin k → Fin (S + 1) × (Fin (S + 1) → Γ)) × + (Fin (S + 2) × (Fin (S + 2) → Γ)) + +/-- Codes have decidable equality: the search of +`Complexitylib.Classes.Containments.Internal.CodeSearch` stores them in a `Finset`. The instance +is spelled out because the default synthesis size limit stops short of this nesting depth. -/ +instance instDecidableEqCode (Q : Type) [DecidableEq Q] (k nn S : ℕ) : + DecidableEq (Code Q k nn S) := by + set_option synthInstance.maxSize 400 in infer_instance + +/-- The code of a configuration. Clamping keeps this total; on configurations that respect the +space bound the clamps are inert. -/ +def cfgCode (nn S : ℕ) (c : Cfg k Q) : Code Q k nn S := + (c.state, + ⟨min c.input.head (nn + S + 1), by omega⟩, + fun i => (⟨min (c.work i).head S, by omega⟩, fun p => (c.work i).cells p.val), + (⟨min c.output.head (S + 1), by omega⟩, fun p => c.output.cells p.val)) + +/-- Two windowed configurations inside the space bound with the same code are equal. -/ +theorem cfgCode_inj {x : List Bool} {S : ℕ} {c₁ c₂ : Cfg k Q} + (h₁ : Windowed x S c₁) (hs₁ : c₁.WithinDecisionSpace x.length S) + (h₂ : Windowed x S c₂) (hs₂ : c₂.WithinDecisionSpace x.length S) + (h : cfgCode x.length S c₁ = cfgCode x.length S c₂) : c₁ = c₂ := by + simp only [cfgCode, Prod.mk.injEq] at h + obtain ⟨hst, hin, hwk, hout⟩ := h + refine Cfg.ext hst ?_ ?_ ?_ + · refine Tape.ext ?_ (h₁.input.trans h₂.input.symm) + have b₁ : c₁.input.head ≤ x.length + S + 1 := hs₁.1.2 + have b₂ : c₂.input.head ≤ x.length + S + 1 := hs₂.1.2 + have := congrArg Fin.val hin + simp only [] at this + omega + · funext i + have hi := congrFun hwk i + rw [Prod.mk.injEq] at hi + have bh₁ : (c₁.work i).head ≤ S := hs₁.1.1 i + have bh₂ : (c₂.work i).head ≤ S := hs₂.1.1 i + refine Tape.ext ?_ ?_ + · have := congrArg Fin.val hi.1 + simp only [] at this + omega + · funext p + rcases Nat.lt_or_ge S p with hp | hp + · rw [h₁.work i p hp, h₂.work i p hp] + · exact congrFun hi.2 ⟨p, by omega⟩ + · have bh₁ : c₁.output.head ≤ S + 1 := hs₁.2 + have bh₂ : c₂.output.head ≤ S + 1 := hs₂.2 + refine Tape.ext ?_ ?_ + · have := congrArg Fin.val hout.1 + simp only [] at this + omega + · funext p + rcases Nat.lt_or_ge (S + 1) p with hp | hp + · rw [h₁.output p hp, h₂.output p hp] + · exact congrFun hout.2 ⟨p, by omega⟩ + +/-- The number of codes. -/ +theorem card_Code (Q : Type) [Fintype Q] (k nn S : ℕ) : + Fintype.card (Code Q k nn S) + = Fintype.card Q * + ((nn + S + 2) * (((S + 1) * 4 ^ (S + 1)) ^ k * ((S + 2) * 4 ^ (S + 2)))) := by + simp [Code, Fintype.card_prod, Γ.card] + +/-- **The configuration count is at most exponential in the space bound.** Both `PSPACE ⊆ EXP` +and Savitch's theorem read the count this way: as `2` to something linear in the space bound. -/ +theorem card_Code_le_two_pow (Q : Type) [Fintype Q] (k nn S : ℕ) : + Fintype.card (Code Q k nn S) + ≤ 2 ^ (Fintype.card Q + (nn + S + 2) + 3 * k * (S + 1) + 3 * (S + 2)) := by + have key : ∀ m : ℕ, (m + 1) * 4 ^ (m + 1) ≤ 2 ^ (3 * (m + 1)) := by + intro m + calc (m + 1) * 4 ^ (m + 1) + ≤ 2 ^ (m + 1) * 4 ^ (m + 1) := Nat.mul_le_mul_right _ (Nat.lt_two_pow_self).le + _ = 2 ^ (m + 1) * 2 ^ (2 * (m + 1)) := by + rw [show (4 : ℕ) = 2 ^ 2 from rfl, ← pow_mul, Nat.mul_comm 2 (m + 1)] + _ = 2 ^ (3 * (m + 1)) := by rw [← pow_add]; ring_nf + have e1 : Fintype.card Q ≤ 2 ^ Fintype.card Q := (Nat.lt_two_pow_self).le + have e2 : nn + S + 2 ≤ 2 ^ (nn + S + 2) := (Nat.lt_two_pow_self).le + have e3 : ((S + 1) * 4 ^ (S + 1)) ^ k ≤ 2 ^ (3 * k * (S + 1)) := by + calc ((S + 1) * 4 ^ (S + 1)) ^ k + ≤ (2 ^ (3 * (S + 1))) ^ k := Nat.pow_le_pow_left (key S) k + _ = 2 ^ (3 * k * (S + 1)) := by rw [← pow_mul]; ring_nf + have e4 : (S + 2) * 4 ^ (S + 2) ≤ 2 ^ (3 * (S + 2)) := by + have := key (S + 1) + rw [show S + 1 + 1 = S + 2 from rfl] at this + exact this + rw [card_Code] + calc Fintype.card Q * ((nn + S + 2) * (((S + 1) * 4 ^ (S + 1)) ^ k * ((S + 2) * 4 ^ (S + 2)))) + ≤ 2 ^ Fintype.card Q * + (2 ^ (nn + S + 2) * (2 ^ (3 * k * (S + 1)) * 2 ^ (3 * (S + 2)))) := + Nat.mul_le_mul e1 (Nat.mul_le_mul e2 (Nat.mul_le_mul e3 e4)) + _ = 2 ^ (Fintype.card Q + (nn + S + 2) + 3 * k * (S + 1) + 3 * (S + 2)) := by + rw [← pow_add, ← pow_add, ← pow_add] + ring_nf + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/ConfigGraph.lean b/Complexitylib/Classes/Containments/Internal/ConfigGraph.lean new file mode 100644 index 00000000..9671e83d --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/ConfigGraph.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.ConfigCount +public import Complexitylib.Classes.Containments.Defs +public import Complexitylib.Models.TuringMachine.Branch + +/-! +# The configuration graph of a nondeterministic machine + +⚠️ Unreviewed by Bolton + +Space-bounded computation is graph reachability: a nondeterministic machine accepts exactly when +some accepting configuration is reachable from the initial one along the two-successor relation. +This file sets up that translation, which `NL ⊆ P`, `NL ⊆ coNL` and Savitch's theorem all rest +on — each then differs only in how it searches the graph. + +The definitions themselves live in `Complexitylib.Classes.Containments.Defs`. + +## Main results + +- `NTM.reachesCfg_trace` — every configuration a trace passes through is reachable +- `NTM.exists_trace_of_reachesCfg` — every reachable configuration is the end of some trace +- `NTM.succ_iff` — an edge of the graph is a step of one of the two `NTM.branchTM`s +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} {tm : NTM k} + +/-- **The configuration graph is the union of the two deterministic steps.** Its edges are the +steps of `NTM.branchTM`, so the deterministic machinery for a single step applies to them. -/ +theorem succ_iff (tm : NTM k) (c c' : Cfg k tm.Q) : + tm.Succ c c' ↔ ∃ b, (tm.branchTM b).step c = some c' := by + constructor + · rintro ⟨hne, b, rfl⟩ + exact ⟨b, branchTM_step tm b hne⟩ + · rintro ⟨b, hb⟩ + have hne : c.state ≠ tm.qhalt := by + intro h + rw [branchTM_step_of_halted tm b h] at hb + exact absurd hb.symm (Option.some_ne_none c') + refine ⟨hne, b, ?_⟩ + rw [branchTM_step tm b hne] at hb + exact (Option.some_injective _ hb).symm + +theorem reachesCfg_refl (tm : NTM k) (c : Cfg k tm.Q) : tm.ReachesCfg c c := + Relation.ReflTransGen.refl + +theorem reachesCfg_head {c c' c'' : Cfg k tm.Q} (h : tm.Succ c c'') (h' : tm.ReachesCfg c'' c') : + tm.ReachesCfg c c' := + Relation.ReflTransGen.head h h' + +/-- **A trace stays inside the configuration graph.** -/ +theorem reachesCfg_trace (tm : NTM k) : + ∀ (T : ℕ) (choices : Fin T → Bool) (c : Cfg k tm.Q), + tm.ReachesCfg c (tm.trace T choices c) + | 0, _, c => reachesCfg_refl tm c + | T + 1, choices, c => by + rw [NTM.trace] + by_cases h : c.state = tm.qhalt + · simp only [h, if_pos] + exact reachesCfg_refl tm c + · simp only [h, if_neg, not_false_iff] + refine reachesCfg_head ⟨h, choices ⟨0, Nat.zero_lt_succ T⟩, rfl⟩ ?_ + exact reachesCfg_trace tm T _ _ + +/-- **Every reachable configuration ends some trace.** -/ +theorem exists_trace_of_reachesCfg {c c' : Cfg k tm.Q} (h : tm.ReachesCfg c c') : + ∃ (t : ℕ) (choices : Fin t → Bool), tm.trace t choices c = c' := by + induction h using Relation.ReflTransGen.head_induction_on with + | refl => exact ⟨0, fun i => i.elim0, rfl⟩ + | head hstep _ ih => + obtain ⟨hne, b, rfl⟩ := hstep + obtain ⟨t, choices, hchoices⟩ := ih + refine ⟨t + 1, Fin.cons b choices, ?_⟩ + rw [NTM.trace, if_neg hne] + simpa using hchoices + +end NTM + +variable {k : ℕ} {tm : NTM k} + +/-! ## The window invariant along the graph -/ + +/-- A nondeterministic step of a machine whose heads stay inside the window preserves the +window invariant. -/ +theorem Windowed.stepCfg {x : List Bool} {S : ℕ} {c : Cfg k tm.Q} (b : Bool) + (hw : Windowed x S c) (hspace : c.WithinDecisionSpace x.length S) : + Windowed x S (tm.stepCfg b c) := by + refine ⟨?_, ?_, ?_⟩ + · show (c.input.move _).cells = _ + cases (tm.δ b c.state c.input.read (fun i => (c.work i).read) c.output.read).2.2.2.1 <;> + exact hw.input + · intro i p hp + have hhead : (c.work i).head ≤ S := hspace.1.1 i + show ((c.work i).writeAndMove _ _).cells p = Γ.blank + rw [cells_writeAndMove_of_ne _ _ _ (by omega)] + exact hw.work i p hp + · intro p hp + have hhead : c.output.head ≤ S + 1 := hspace.2 + show (c.output.writeAndMove _ _).cells p = Γ.blank + rw [cells_writeAndMove_of_ne _ _ _ (by omega)] + exact hw.output p hp + +/-- Along the configuration graph, the window invariant is inherited as long as every +configuration met respects the space bound. -/ +theorem windowed_of_reachesCfg {x : List Bool} {S : ℕ} {c₀ c : Cfg k tm.Q} + (hspace : ∀ c', tm.ReachesCfg c₀ c' → c'.WithinDecisionSpace x.length S) + (hw : Windowed x S c₀) (h : tm.ReachesCfg c₀ c) : Windowed x S c := by + induction h with + | refl => exact hw + | tail hreach hstep ih => + obtain ⟨_, b, rfl⟩ := hstep + exact ih.stepCfg b (hspace _ hreach) + +/-! ## Acceptance is reachability -/ + +/-- **A space-bounded machine accepts exactly when an accepting configuration is reachable.** +This is the bridge every log-space graph argument starts from: membership in the language is a +property of the configuration graph alone, with no reference to time or choice sequences. -/ +theorem mem_iff_exists_accepting_reachable {k : ℕ} {tm : NTM k} {L : Language} {f : ℕ → ℕ} + (hdec : tm.DecidesInSpace L f) (x : List Bool) : + x ∈ L ↔ ∃ c, tm.ReachesCfg (tm.initCfg x) c ∧ tm.halted c ∧ c.output.cells 1 = Γ.one := by + obtain ⟨T, hdt, _⟩ := hdec + constructor + · intro hx + obtain ⟨choices, hhalt, hout⟩ := (hdt.2 x).mp hx + exact ⟨_, NTM.reachesCfg_trace tm _ choices _, hhalt, hout⟩ + · rintro ⟨c, hreach, hhalt, hout⟩ + obtain ⟨t, choices, rfl⟩ := NTM.exists_trace_of_reachesCfg hreach + refine (hdt.2 x).mpr ?_ + rcases Nat.lt_or_ge (T x.length) t with hlt | hge + · -- the run already halted by `T`, so the longer trace adds nothing + refine ⟨fun j => choices ⟨j.val, by omega⟩, ?_⟩ + have hfrozen := + tm.trace_mono (T := T x.length) (T' := t) hlt.le + (choices := fun j => choices ⟨j.val, by omega⟩) (choices' := choices) + (fun i => rfl) (hdt.1 x _) + rw [hfrozen] at hhalt hout + exact ⟨hhalt, hout⟩ + · -- pad the choice sequence out to `T` + refine ⟨fun j => if h : j.val < t then choices ⟨j.val, h⟩ else false, ?_⟩ + have hfrozen := + tm.trace_mono (T := t) (T' := T x.length) hge + (choices := choices) + (choices' := fun j => if h : j.val < t then choices ⟨j.val, h⟩ else false) + (fun i => by simp [i.isLt]) hhalt + rw [hfrozen] + exact ⟨hhalt, hout⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/FPBridge.lean b/Complexitylib/Classes/Containments/Internal/FPBridge.lean new file mode 100644 index 00000000..2a3471bf --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/FPBridge.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.P.Cobham.Internal +public import Complexitylib.Classes.P.Cobham.Internal.StringOps + +/-! +# Programming with polynomial-time string functions + +⚠️ Unreviewed by Bolton + +Cobham's theorem makes `FP` a *programming language*: a function is +polynomial-time exactly when it belongs to the algebra, so a construction can be +written as a composition of small pieces instead of assembled as a machine. This +file collects the glue that makes the two levels interoperate. + +The algebra is stated at every arity, over vectors of arguments, while `FP` is +unary; the bridge is the pairing. `binFn_mem_FP` turns a two-argument member of +the algebra into an `FP` closure rule, and the rest of the file is that rule +applied to the toolkit of +`Complexitylib.Classes.P.Cobham.Internal.StringOps` and +`Complexitylib.Classes.P.Cobham.Internal.Algebra`. + +## Main results + +- `Cobham.fstBlockFn`, `Cobham.sndBlockFn` — the pair decoders, in the algebra +- `unFn_mem_FP`, `binFn_mem_FP` — algebra members become `FP` closure rules +- `dropLenFn_mem_FP`, `orBitFn_mem_FP`, `lenLeFlagFn_mem_FP`, `eqFlagFn_mem_FP` — + the rules this gives +- `constFn_mem_FP` — every constant is polynomial-time +- `mem_FP_of_eq` — `FP` respects pointwise equality +-/ + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- The first pair decoder is in the algebra, being polynomial-time. -/ +theorem fstBlockFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => fstBlock (g v) := + (Cobham.comp (FP_subset_CobhamFP fstBlock_mem_FP) fun _ : Fin 1 => hg).of_eq fun _ => rfl + +/-- The second pair decoder is in the algebra. -/ +theorem sndBlockFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => sndBlock (g v) := + (Cobham.comp (FP_subset_CobhamFP sndBlock_mem_FP) fun _ : Fin 1 => hg).of_eq fun _ => rfl + +end Cobham + +/-- `FP` respects pointwise equality of functions — the counterpart of +`Cobham.of_eq`, needed because these closure rules produce syntactically +specific lambda terms. -/ +theorem mem_FP_of_eq {f g : List Bool → List Bool} (hf : f ∈ FP) (h : ∀ z, f z = g z) : + g ∈ FP := by + have hfg : f = g := funext h + rwa [hfg] at hf + +/-! ## From the algebra to `FP` closure rules -/ + +/-- **A one-argument member of the algebra is an `FP` closure rule.** -/ +theorem unFn_mem_FP {g : List Bool → List Bool} + (hg : Cobham fun v : Fin 1 → List Bool => g (v 0)) + {a : List Bool → List Bool} (ha : a ∈ FP) : (fun z => g (a z)) ∈ FP := by + have hg' : g ∈ FP := CobhamFP_subset_FP hg + have h := mem_FP_comp ha hg' + simpa [Function.comp] using h + +/-- **A two-argument member of the algebra is an `FP` closure rule.** The two +levels differ only in how arguments are presented: the algebra takes a vector, +`FP` takes the pairing of the two values. -/ +theorem binFn_mem_FP {g : List Bool → List Bool → List Bool} + (hg : Cobham fun v : Fin 2 → List Bool => g (v 0) (v 1)) + {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => g (a z) (b z)) ∈ FP := by + have hpacked : Cobham fun v : Fin 1 → List Bool => + g (Cobham.fstBlock (v 0)) (Cobham.sndBlock (v 0)) := + (Cobham.comp₂ hg (Cobham.fstBlockFn (Cobham.proj 0)) + (Cobham.sndBlockFn (Cobham.proj 0))).of_eq fun _ => rfl + have hfp : (fun w => g (Cobham.fstBlock w) (Cobham.sndBlock w)) ∈ FP := + CobhamFP_subset_FP hpacked + have h := mem_FP_comp (Cobham.pairFn_mem_FP ha hb) hfp + have heq : ((fun w => g (Cobham.fstBlock w) (Cobham.sndBlock w)) ∘ fun z => pair (a z) (b z)) + = fun z => g (a z) (b z) := by + funext z + simp [Function.comp] + rwa [heq] at h + +/-! ## The rules -/ + +/-- Every constant function is polynomial-time. -/ +theorem constFn_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := + CobhamFP_subset_FP (Cobham.const c) + +/-- Dropping a prefix at another value's width is polynomial-time. -/ +theorem dropLenFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => (b z).drop (a z).length) ∈ FP := + binFn_mem_FP (g := fun p q => q.drop p.length) + (Cobham.dropFn (Cobham.proj 0) (Cobham.proj 1)) ha hb + +/-- Disjunction of flags is polynomial-time. -/ +theorem orBitFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => orBit (a z) (b z)) ∈ FP := + binFn_mem_FP (g := orBit) (Cobham.orFn (Cobham.proj 0) (Cobham.proj 1)) ha hb + +/-- Conjunction of flags is polynomial-time. -/ +theorem andBitFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => andBit (a z) (b z)) ∈ FP := + binFn_mem_FP (g := andBit) (Cobham.andFn (Cobham.proj 0) (Cobham.proj 1)) ha hb + +/-- Negation of a flag is polynomial-time. -/ +theorem notBitFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => notBit (a z)) ∈ FP := + unFn_mem_FP (g := notBit) (Cobham.notFn (Cobham.proj 0)) ha + +/-- The length comparison is polynomial-time. -/ +theorem lenLeFlagFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => Cobham.lenLeFlag (a z) (b z)) ∈ FP := + binFn_mem_FP (g := Cobham.lenLeFlag) + (Cobham.lenLeFlag_mem (Cobham.proj 0) (Cobham.proj 1)) ha hb + +/-- The equality test is polynomial-time. -/ +theorem eqFlagFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => Cobham.eqFlag (a z) (b z)) ∈ FP := + binFn_mem_FP (g := Cobham.eqFlag) + (Cobham.eqFlag_mem (Cobham.proj 0) (Cobham.proj 1)) ha hb + +/-- Reading a fixed field of a block-aligned string is polynomial-time. -/ +theorem blockAtFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (i : ℕ) : (fun z => blockAt (a z) (b z) i) ∈ FP := + binFn_mem_FP (g := fun p q => blockAt p q i) + (Cobham.blockFn (Cobham.proj 0) (Cobham.proj 1) i) ha hb + +/-- Padding to a ruler's width is polynomial-time. -/ +theorem padToFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => padTo (a z) (b z)) ∈ FP := + binFn_mem_FP (g := padTo) (Cobham.padFn (Cobham.proj 0) (Cobham.proj 1)) ha hb + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPSubsetPSPACE.lean b/Complexitylib/Classes/Containments/Internal/IPSubsetPSPACE.lean new file mode 100644 index 00000000..74aec526 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPSubsetPSPACE.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Interactive + +/-! +# `IP ⊆ PSPACE` — the strategy space is finite + +⚠️ Unreviewed by Bolton + +A prover strategy is a function on *all* transcripts, of which there are infinitely many, so the +supremum over strategies that `IP` quantifies is a supremum over an infinite set. A machine +cannot search that. The first thing to establish is therefore that the quantifier is really +finite: a run of `prot.rounds n` rounds only ever consults the strategy on transcripts of length +below `2 · rounds n`, so two strategies agreeing there are indistinguishable. + +That is what these lemmas say. Together with the message-length bound carried by +`ProverStrategy.Bounded`, they cut the search down to a finite game tree of polynomial depth, +which is the object a depth-first polynomial-space evaluation walks. + +## Main results + +- `Protocol.transcript_length` — a run of `n` rounds produces `2 n` messages +- `Protocol.transcript_congr` — **strategy extensionality** for the transcript +- `Protocol.accepts_congr`, `Protocol.acceptEvent_congr` — and for acceptance +-/ + +@[expose] public section + +namespace Complexity + +namespace Protocol + +/-- A run of `n` rounds appends two messages per round. -/ +theorem transcript_length (prot : Protocol) (S : ProverStrategy) (x r : List Bool) : + ∀ n, (prot.transcript S x r n).length = 2 * n + | 0 => rfl + | n + 1 => by + rw [transcript] + simp only [List.length_append, List.length_cons, List.length_nil] + rw [transcript_length prot S x r n] + omega + +/-- **Strategy extensionality.** The run consults the strategy only on the transcripts it +actually produces, all of which have length below `2 n`; two strategies agreeing there yield the +same transcript. -/ +theorem transcript_congr (prot : Protocol) {S S' : ProverStrategy} (x r : List Bool) : + ∀ n, (∀ τ : Transcript, τ.length ≤ 2 * n → S τ = S' τ) → + prot.transcript S x r n = prot.transcript S' x r n + | 0, _ => rfl + | n + 1, h => by + have ih := transcript_congr prot x r n (fun τ hτ => h τ (by omega)) + rw [transcript, transcript, ih] + have hlen : (prot.transcript S' x r n).length = 2 * n := + transcript_length prot S' x r n + rw [h _ (by rw [List.length_append, hlen]; simp)] + +/-- Acceptance depends on the strategy only through its values on the transcripts the run +produces. -/ +theorem accepts_congr (prot : Protocol) {S S' : ProverStrategy} (x r : List Bool) + (h : ∀ τ : Transcript, τ.length ≤ 2 * prot.rounds x.length → S τ = S' τ) : + prot.Accepts S x r ↔ prot.Accepts S' x r := by + rw [Accepts, Accepts, transcript_congr prot x r (prot.rounds x.length) h] + +/-- The accepting coin set — and hence the acceptance probability — depends on the strategy only +through those values. -/ +theorem acceptEvent_congr (prot : Protocol) {S S' : ProverStrategy} (x : List Bool) + (h : ∀ τ : Transcript, τ.length ≤ 2 * prot.rounds x.length → S τ = S' τ) : + prot.acceptEvent S x = prot.acceptEvent S' x := by + classical + refine Finset.filter_congr fun r _ => ?_ + simpa using accepts_congr prot x (BitString.toList r) h + +end Protocol + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/InductiveCounting.lean b/Complexitylib/Classes/Containments/Internal/InductiveCounting.lean new file mode 100644 index 00000000..1ebbf99b --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/InductiveCounting.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.CodeSearch + +/-! +# The counting principle behind inductive counting + +⚠️ Unreviewed by Bolton + +Immerman–Szelepcsényi's machine cannot store a round of the breadth-first search — that would +take polynomially many bits, not logarithmically many. It stores only the round's *size*, and +recovers everything else by guessing. The reason that is sound is a counting principle: a subset +of a round that is at least as large as the round is the whole round. So a machine that has +verified `r_i` distinct members of round `i`, and has not seen `c` among them, may conclude that +`c` is *not* in round `i` — which is a negative fact, certified positively. + +This file isolates that principle and the round recursion it is applied to. Neither mentions a +machine: what remains for `NL ⊆ coNL` is the guessing procedure and its space accounting. + +## Main results + +- `NTM.reachCodes_mono` — the rounds only grow +- `NTM.eq_reachCodes_of_card_le` — **the counting certificate** +- `NTM.not_mem_reachCodes_of_card_le` — non-membership certified by a count +- `NTM.mem_reachCodes_succ_iff` — the round recursion the count is carried along +- `NTM.not_mem_iff_forall_not_accepting` — the complement characterization `coNL` needs +- `NTM.reachSet_eq_of_ncard_le` — the counting certificate for the specification-level rounds +- `NL_complement_characterization_internal` — the complement of an `NL` language, as a + universally quantified statement over the rounds of the search +- `mem_NL_of_logWindow` — an explicit logarithmic window suffices for `NL` +- `NL_subset_coNL_of_counting_internal` — the containment, modulo one machine +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} {tm : NTM k} {x : List Bool} {S : ℕ} + +/-! ## The rounds as growing finite sets -/ + +/-- The round recursion, as a membership statement: a code is in the next round exactly when it +is already present or is a successor of something present. -/ +theorem mem_reachCodes_succ_iff (a₀ : Code tm.Q k x.length S) (i : ℕ) + (a : Code tm.Q k x.length S) : + a ∈ reachCodes tm x S a₀ (i + 1) ↔ + a ∈ reachCodes tm x S a₀ i ∨ ∃ b ∈ reachCodes tm x S a₀ i, a ∈ codeSucc tm x S b := by + simp [reachCodes, codeRound] + +/-- Each round contains the previous one. -/ +theorem reachCodes_subset_succ (a₀ : Code tm.Q k x.length S) (i : ℕ) : + reachCodes tm x S a₀ i ⊆ reachCodes tm x S a₀ (i + 1) := + fun _ h => (mem_reachCodes_succ_iff a₀ i _).mpr (Or.inl h) + +/-- The rounds only grow. -/ +theorem reachCodes_mono (a₀ : Code tm.Q k x.length S) {i j : ℕ} (hij : i ≤ j) : + reachCodes tm x S a₀ i ⊆ reachCodes tm x S a₀ j := by + induction j with + | zero => rw [Nat.le_zero.mp hij] + | succ j ih => + rcases Nat.lt_or_ge i (j + 1) with hlt | hge + · exact (ih (by omega)).trans (reachCodes_subset_succ a₀ j) + · rw [show i = j + 1 from by omega] + +/-! ## The counting certificate -/ + +/-- **The counting certificate.** A subset of a round that is at least as large as the round is +the whole round. This is what lets a machine that knows only the round's size conclude a +negative fact from a successful count. -/ +theorem eq_reachCodes_of_card_le {a₀ : Code tm.Q k x.length S} {i : ℕ} + {T : Finset (Code tm.Q k x.length S)} (hsub : T ⊆ reachCodes tm x S a₀ i) + (hcard : (reachCodes tm x S a₀ i).card ≤ T.card) : + T = reachCodes tm x S a₀ i := + Finset.eq_of_subset_of_card_le hsub hcard + +/-- **Non-membership certified by a count.** Having verified as many members of round `i` as the +round has, a code not among them is not in the round at all. -/ +theorem not_mem_reachCodes_of_card_le {a₀ : Code tm.Q k x.length S} {i : ℕ} + {T : Finset (Code tm.Q k x.length S)} (hsub : T ⊆ reachCodes tm x S a₀ i) + (hcard : (reachCodes tm x S a₀ i).card ≤ T.card) {a : Code tm.Q k x.length S} + (ha : a ∉ T) : a ∉ reachCodes tm x S a₀ i := by + rwa [eq_reachCodes_of_card_le hsub hcard] at ha + +/-- Conversely, a verified subset can never exceed the round it sits inside, so the count a +machine accumulates is bounded by the true one. -/ +theorem card_le_card_reachCodes {a₀ : Code tm.Q k x.length S} {i : ℕ} + {T : Finset (Code tm.Q k x.length S)} (hsub : T ⊆ reachCodes tm x S a₀ i) : + T.card ≤ (reachCodes tm x S a₀ i).card := + Finset.card_le_card hsub + +/-- The counting certificate at the level of the specification rounds: a subset of a round that +is at least as large is the whole round. -/ +theorem reachSet_eq_of_ncard_le (tm : NTM k) (c₀ : Cfg k tm.Q) (i : ℕ) + {T : Set (Cfg k tm.Q)} (hsub : T ⊆ reachSet tm c₀ i) + (hcard : (reachSet tm c₀ i).ncard ≤ T.ncard) : T = reachSet tm c₀ i := + Set.eq_of_subset_of_ncard_le hsub hcard (reachSet_finite tm c₀ i) + +/-! ## The complement characterization -/ + +/-- **What `coNL` has to certify.** An input is *outside* the language exactly when no reachable +configuration of the search is an accepting halted one — a universally quantified statement over +a finite set, which is what inductive counting turns into a nondeterministic verification. -/ +theorem not_mem_iff_forall_not_accepting {L : Language} {Sf : ℕ → ℕ} + (hdec : tm.DecidesInSpace L Sf) (x : List Bool) {N : ℕ} + (hN : Fintype.card (Code tm.Q k x.length (Sf x.length)) ≤ N) : + x ∉ L ↔ ∀ a ∈ reachCodes tm x (Sf x.length) + (cfgCode x.length (Sf x.length) (tm.initCfg x)) N, + ¬ ((decodeCfg x (Sf x.length) a).state = tm.qhalt ∧ + (decodeCfg x (Sf x.length) a).output.cells 1 = Γ.one) := by + rw [mem_iff_exists_mem_reachCodes hdec x hN] + simp + +end NTM + +/-- **The complement of an `NL` language, spelled out.** An input is outside the language exactly +when *every* configuration the bounded search reaches fails to be accepting. This is the +universally quantified statement inductive counting has to certify nondeterministically. -/ +theorem NL_complement_characterization_internal {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (A B : ℕ), + ∀ x : List Bool, x ∉ L ↔ + ∀ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + ¬ (tm.halted c ∧ c.output.cells 1 = Γ.one) := by + obtain ⟨k, tm, A, B, hsearch⟩ := NL_bounded_reachability_internal hL + refine ⟨k, tm, A, B, fun x => ?_⟩ + rw [hsearch x] + simp + + +/-- A nondeterministic transducer respecting an explicit logarithmic window decides an `NL` +language: the `O(log n)` side is discharged once, here. -/ +theorem mem_NL_of_logWindow {L : Language} {k : ℕ} (tm : NTM k) (C D : ℕ) + (htrans : tm.IsTransducer) (hdec : tm.DecidesInSpace L (logWindow C D)) : L ∈ NL := + ⟨k, tm, logWindow C D, htrans, hdec, logWindow_bigO C D⟩ + +/-- **`NL ⊆ coNL`, reduced to the existence of one machine.** The hypothesis carries the +log-space witness for `tm`, without which the search language is not in `NL` at all. -/ +theorem NL_subset_coNL_of_counting_internal + (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (A B : ℕ), + tm.DecidesInSpace L₀ S → S =O (fun n => Nat.log 2 n) → + ∃ (k' : ℕ) (M : NTM k') (C D : ℕ), M.IsTransducer ∧ + M.DecidesInSpace + {x : List Bool | ∀ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + ¬ (tm.halted c ∧ c.output.cells 1 = Γ.one)} + (logWindow C D)) : + NL ⊆ coNL := by + intro L hL + obtain ⟨k, tm, S, -, hdec, hS⟩ := hL + obtain ⟨A, B, hAB⟩ := exists_config_bound (k := k) tm.Q hS + obtain ⟨k', M, C, D, htrans, hdecM⟩ := h k tm S L A B hdec hS + show Lᶜ ∈ NL + have hLeq : Lᶜ = {x : List Bool | + ∀ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + ¬ (tm.halted c ∧ c.output.cells 1 = Γ.one)} := by + ext x + rw [Set.mem_compl_iff, NTM.mem_iff_exists_mem_reachSet hdec x (hAB x.length)] + simp + rw [hLeq] + exact mem_NL_of_logWindow M C D htrans hdecM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/LogSpaceBound.lean b/Complexitylib/Classes/Containments/Internal/LogSpaceBound.lean new file mode 100644 index 00000000..240fccf7 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/LogSpaceBound.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.ConfigCount +public import Complexitylib.Asymptotics + +/-! +# The configuration graph of a log-space machine is polynomially sized + +⚠️ Unreviewed by Bolton + +A machine using `O(log n)` space has only polynomially many configurations: each of the +`4 ^ O(log n)` tape contents is `n ^ O(1)`, and the head positions contribute a further +polynomial factor. This is what turns the graph reachability of +`Complexitylib.Classes.Containments.Internal.ConfigGraph` into a polynomial-time search. + +## Main results + +- `exists_log_bound` — an `O(log n)` bound holds everywhere after adding a constant +- `four_pow_log_le` — `4 ^ (C · log₂ n + D)` is polynomially bounded +- `exists_config_bound` — the configuration count is `A · (n + 1) ^ B` +-/ + +@[expose] public section + +namespace Complexity + +/-- An asymptotic logarithmic bound becomes an everywhere bound after adding a constant: the +finitely many exceptional inputs are absorbed into it. -/ +theorem exists_log_bound {f : ℕ → ℕ} (hf : f =O (fun n => Nat.log 2 n)) : + ∃ C D : ℕ, ∀ n, f n ≤ C * Nat.log 2 n + D := by + rw [BigO, Asymptotics.isBigO_iff] at hf + obtain ⟨c, hc⟩ := hf + rw [Filter.eventually_atTop] at hc + obtain ⟨N, hN⟩ := hc + refine ⟨⌈c⌉₊, (Finset.range N).sup f, fun n => ?_⟩ + by_cases hn : n < N + · have : f n ≤ (Finset.range N).sup f := Finset.le_sup (Finset.mem_range.mpr hn) + omega + · have hb := hN n (by omega) + simp only [Real.norm_natCast] at hb + have hcle : c ≤ (⌈c⌉₊ : ℝ) := Nat.le_ceil c + have hlog : (0 : ℝ) ≤ ((Nat.log 2 n : ℕ) : ℝ) := by positivity + have : (f n : ℝ) ≤ (⌈c⌉₊ : ℝ) * ((Nat.log 2 n : ℕ) : ℝ) := + le_trans hb (mul_le_mul_of_nonneg_right hcle hlog) + have hnat : f n ≤ ⌈c⌉₊ * Nat.log 2 n := by exact_mod_cast this + omega + +/-- Four to a logarithmic power is polynomial. -/ +theorem four_pow_log_le (C D n : ℕ) : + 4 ^ (C * Nat.log 2 n + D) ≤ 4 ^ D * (n + 1) ^ (2 * C) := by + rw [pow_add, Nat.mul_comm (4 ^ (C * Nat.log 2 n)) (4 ^ D)] + refine Nat.mul_le_mul_left _ ?_ + have hbase : (4 : ℕ) ^ (C * Nat.log 2 n) = (2 ^ Nat.log 2 n) ^ (2 * C) := by + rw [show (4 : ℕ) = 2 ^ 2 from rfl, ← pow_mul, ← pow_mul] + ring_nf + rw [hbase] + refine Nat.pow_le_pow_left ?_ _ + rcases Nat.eq_zero_or_pos n with rfl | hn + · simp + · exact le_trans (Nat.pow_log_le_self 2 (by omega)) (by omega) + +/-- Bounded by a constant times a power of `n + 1`. -/ +def PolyBounded (g : ℕ → ℕ) : Prop := ∃ A B : ℕ, ∀ n, g n ≤ A * (n + 1) ^ B + +theorem PolyBounded.const (c : ℕ) : PolyBounded fun _ => c := ⟨c, 0, fun _ => by simp⟩ + +/-- Transfer along a pointwise bound. -/ +theorem PolyBounded.mono {g h : ℕ → ℕ} (hg : PolyBounded g) (hle : ∀ n, h n ≤ g n) : + PolyBounded h := by + obtain ⟨A, B, hA⟩ := hg + exact ⟨A, B, fun n => le_trans (hle n) (hA n)⟩ + +theorem PolyBounded.mul {g h : ℕ → ℕ} (hg : PolyBounded g) + (hh : PolyBounded h) : PolyBounded fun n => g n * h n := by + obtain ⟨A₁, B₁, h₁⟩ := hg + obtain ⟨A₂, B₂, h₂⟩ := hh + refine ⟨A₁ * A₂, B₁ + B₂, fun n => ?_⟩ + calc g n * h n ≤ (A₁ * (n + 1) ^ B₁) * (A₂ * (n + 1) ^ B₂) := + Nat.mul_le_mul (h₁ n) (h₂ n) + _ = A₁ * A₂ * (n + 1) ^ (B₁ + B₂) := by rw [pow_add]; ring + +theorem PolyBounded.add {g h : ℕ → ℕ} (hg : PolyBounded g) + (hh : PolyBounded h) : PolyBounded fun n => g n + h n := by + obtain ⟨A₁, B₁, h₁⟩ := hg + obtain ⟨A₂, B₂, h₂⟩ := hh + refine ⟨A₁ + A₂, max B₁ B₂, fun n => ?_⟩ + have e₁ : (n + 1) ^ B₁ ≤ (n + 1) ^ max B₁ B₂ := + Nat.pow_le_pow_right (by omega) (le_max_left _ _) + have e₂ : (n + 1) ^ B₂ ≤ (n + 1) ^ max B₁ B₂ := + Nat.pow_le_pow_right (by omega) (le_max_right _ _) + calc g n + h n ≤ A₁ * (n + 1) ^ B₁ + A₂ * (n + 1) ^ B₂ := Nat.add_le_add (h₁ n) (h₂ n) + _ ≤ A₁ * (n + 1) ^ max B₁ B₂ + A₂ * (n + 1) ^ max B₁ B₂ := + Nat.add_le_add (Nat.mul_le_mul_left _ e₁) (Nat.mul_le_mul_left _ e₂) + _ = (A₁ + A₂) * (n + 1) ^ max B₁ B₂ := by ring + +theorem PolyBounded.pow {g : ℕ → ℕ} (hg : PolyBounded g) (m : ℕ) : + PolyBounded fun n => g n ^ m := by + induction m with + | zero => exact (PolyBounded.const 1).mono fun n => by simp + | succ m ih => exact (ih.mul hg).mono fun n => by rw [pow_succ] + +theorem PolyBounded.id : PolyBounded fun n => n := ⟨1, 1, fun n => by simp⟩ + +/-- A log-space bound is polynomially bounded, as is four to its power. -/ +theorem PolyBounded.of_log {f : ℕ → ℕ} (hf : f =O (fun n => Nat.log 2 n)) : PolyBounded f := by + obtain ⟨C, D, hCD⟩ := exists_log_bound hf + refine ⟨C + D, 1, fun n => ?_⟩ + have h1 : Nat.log 2 n ≤ n := Nat.log_le_self 2 n + have := hCD n + nlinarith [Nat.zero_le C, Nat.zero_le D] + +theorem PolyBounded.four_pow {f : ℕ → ℕ} (hf : f =O (fun n => Nat.log 2 n)) (m : ℕ) : + PolyBounded fun n => 4 ^ (f n + m) := by + obtain ⟨C, D, hCD⟩ := exists_log_bound hf + refine ⟨4 ^ (D + m), 2 * C, fun n => ?_⟩ + calc 4 ^ (f n + m) ≤ 4 ^ (C * Nat.log 2 n + (D + m)) := by + refine Nat.pow_le_pow_right (by norm_num) ?_ + have := hCD n + omega + _ ≤ 4 ^ (D + m) * (n + 1) ^ (2 * C) := four_pow_log_le C (D + m) n + +/-- **The configuration count of a log-space machine is polynomial.** -/ +theorem exists_config_bound {k : ℕ} (Q : Type) [Fintype Q] {f : ℕ → ℕ} + (hf : f =O (fun n => Nat.log 2 n)) : + PolyBounded fun n => Fintype.card (Code Q k n (f n)) := by + have hf' := PolyBounded.of_log hf + have key : PolyBounded fun n => + Fintype.card Q * + ((n + f n + 2) * (((f n + 1) * 4 ^ (f n + 1)) ^ k * ((f n + 2) * 4 ^ (f n + 2)))) := by + refine (PolyBounded.const _).mul (((PolyBounded.id.add hf').add (PolyBounded.const 2)).mul ?_) + refine PolyBounded.mul ?_ ?_ + · exact ((hf'.add (PolyBounded.const 1)).mul (PolyBounded.four_pow hf 1)).pow k + · exact (hf'.add (PolyBounded.const 2)).mul (PolyBounded.four_pow hf 2) + exact key.mono fun n => by rw [card_Code] + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean b/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean new file mode 100644 index 00000000..dda47da7 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BlockSearchCorrect +public import Complexitylib.Classes.Containments.Internal.BlockAccept +public import Complexitylib.Classes.P.DecisionFn +public import Complexitylib.Classes.L + +/-! +# Running the search to saturation + +⚠️ Unreviewed by Bolton + +The search is run for as many steps as there are configurations. Each step +advances the counter by one, so after that many steps the counter has passed +every record — there are at most as many records as configurations — and the +search is complete. + +## Main definitions + +- `Complexity.polyRuler` — a ruler of polynomial length +- `Complexity.searchState` — the unpacked search state after `n` steps + +## Main results + +- `Complexity.searchState_counter` — the counter counts the steps +- `Complexity.searchState_ok` — the invariant holds throughout +- `Complexity.searchState_complete` — a long enough run finds every reachable + configuration +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## Rulers of polynomial length -/ + +/-- A ruler whose length is a polynomial in the input length. -/ +def polyRuler (q : Polynomial ℕ) (x : List Bool) : List Bool := + List.replicate (q.eval x.length) false + +@[simp] theorem polyRuler_length (q : Polynomial ℕ) (x : List Bool) : + (polyRuler q x).length = q.eval x.length := by + rw [polyRuler, List.length_replicate] + +theorem polyRulerFn_mem_FP (q : Polynomial ℕ) {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => polyRuler q (a z)) ∈ FP := by + have h : Cobham fun v : Fin 1 → List Bool => + List.replicate (Cobham.polyLen q (v 0)).length false := + Cobham.zeroBlockFn (Cobham.polyLen_mem q (Cobham.proj 0)) + refine unFn_mem_FP (g := polyRuler q) ?_ ha + refine h.of_eq fun v => ?_ + rw [polyRuler, Cobham.polyLen_length] + +/-- The block ruler of a polynomial window. -/ +theorem blockRuler_eq_polyRuler (q : Polynomial ℕ) (x : List Bool) : + blockRuler (q.eval x.length) = polyRuler (2 * q + 2) x := by + rw [blockRuler, polyRuler, blockWidth] + congr 1 + simp [Polynomial.eval_add, Polynomial.eval_mul] + omega + +/-! ## The state after `n` steps -/ + +/-- The unpacked search state after `n` steps. -/ +noncomputable def searchState (tm : NTM k) (R V₀ : List Bool) (n : ℕ) : + List Bool × List Bool := + (searchStepPair tm (codeBlocks k) R)^[n] ([], V₀) + +/-- **The counter counts the steps.** -/ +theorem searchState_counter (tm : NTM k) (R V₀ : List Bool) (n : ℕ) : + (searchState tm R V₀ n).1.length = n := by + have key : ∀ (m : ℕ) (s : List Bool × List Bool), + ((searchStepPair tm (codeBlocks k) R)^[m] s).1.length = s.1.length + m := by + intro m + induction m with + | zero => intro s; simp + | succ m ih => + intro s + rw [Function.iterate_succ_apply, ih (searchStepPair tm (codeBlocks k) R s), + searchStepPair] + split <;> · show (false :: s.1).length + m = s.1.length + (m + 1) + rw [List.length_cons] + omega + rw [searchState, key] + simp + +/-- **The invariant holds throughout the run.** -/ +theorem searchState_ok (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) (n : ℕ) : + SearchOk tm x W (searchState tm (blockRuler W) (Cobham.cfgCode W (tm.initCfg x)) n).1 + (searchState tm (blockRuler W) (Cobham.cfgCode W (tm.initCfg x)) n).2 := by + induction n with + | zero => exact searchOk_init tm x W + | succ n ih => + have := searchStepPair_ok tm hdec x W hq hW _ _ ih + rw [searchState, Function.iterate_succ_apply'] + exact this + +/-- **A long enough run finds every reachable configuration.** -/ +theorem searchState_complete (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) (n : ℕ) + (hn : Fintype.card (Code tm.Q k x.length (S x.length)) ≤ n) {c : Cfg k tm.Q} + (hc : tm.ReachesCfg (tm.initCfg x) c) : + memFlag (wideRuler (codeBlocks k) (blockRuler W)) (Cobham.cfgCode W c) + (searchState tm (blockRuler W) (Cobham.cfgCode W (tm.initCfg x)) n).2 = [true] := by + have hok := searchState_ok tm hdec x W hq hW n + refine searchOk_complete tm hdec x W hq hW _ _ hok ?_ hc + rw [searchState_counter] + exact le_trans (searchOk_length_le tm hdec x W _ _ hok) (Nat.mul_le_mul_right _ hn) + +/-! ## What the accept scan on the finished search decides -/ + +/-- **The scan fires only on a genuinely accepting configuration.** -/ +theorem acceptScan_sound (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) + (hW1 : 1 ≤ W) (n : ℕ) (ruler : List Bool) (hruler : W ≤ ruler.length) + (h : acceptScan k (stateCode tm.qhalt) (blockRuler W) ruler + (searchState tm (blockRuler W) (Cobham.cfgCode W (tm.initCfg x)) n).2 = [true]) : + ∃ c, tm.ReachesCfg (tm.initCfg x) c ∧ tm.halted c ∧ c.output.cells 1 = Γ.one := by + have hRpos : 0 < (blockRuler W).length := by + rw [blockRuler_length, blockWidth] + omega + obtain ⟨i, hlen, hflag⟩ := + (acceptScan_eq_true_iff k _ _ _ _ hRpos).mp h + obtain ⟨cs, hV, -, hreach, -, -⟩ := searchState_ok tm hdec x W hq hW n + have hbs := codesOf_recordWidth W cs + have hflatten : (codesOf W cs).flatten.length = cs.length * recordWidth k W := by + rw [length_flatten_records k W _ hbs, codesOf_length] + have hwlen : (wideRuler (codeBlocks k) (blockRuler W)).length = recordWidth k W := + wideRuler_blockRuler_length k W + rw [hV, hwlen, hflatten] at hlen + have hpos := recordWidth_pos k W + have hi : i < cs.length := by + by_contra hcon + have : cs.length * recordWidth k W ≤ i * recordWidth k W := + Nat.mul_le_mul_right _ (by omega) + omega + have hi' : i < (codesOf W cs).length := by rwa [codesOf_length] + have hblk : blockAt (wideRuler (codeBlocks k) (blockRuler W)) + (searchState tm (blockRuler W) (Cobham.cfgCode W (tm.initCfg x)) n).2 i + = Cobham.cfgCode W cs[i] := by + rw [hV, blockAt_records k W _ hbs i hi', codesOf_getElem] + rw [hblk] at hflag + have hc : tm.ReachesCfg (tm.initCfg x) cs[i] := hreach _ (List.getElem_mem hi) + have := (acceptFlag_cfgCode tm W cs[i] hq (codeInv_of_reachesCfg tm hdec x hc W hW) + hW1 ruler hruler).mp hflag + exact ⟨cs[i], hc, this.1, this.2⟩ + +/-- **The scan fires whenever an accepting configuration is reachable.** -/ +theorem acceptScan_complete (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (x : List Bool) (W : ℕ) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : x.length + S x.length + 1 ≤ W) + (hW1 : 1 ≤ W) (n : ℕ) + (hn : Fintype.card (Code tm.Q k x.length (S x.length)) ≤ n) (ruler : List Bool) + (hruler : W ≤ ruler.length) {c : Cfg k tm.Q} + (hc : tm.ReachesCfg (tm.initCfg x) c) (hhalt : tm.halted c) + (hout : c.output.cells 1 = Γ.one) : + acceptScan k (stateCode tm.qhalt) (blockRuler W) ruler + (searchState tm (blockRuler W) (Cobham.cfgCode W (tm.initCfg x)) n).2 = [true] := by + have hRpos : 0 < (blockRuler W).length := by + rw [blockRuler_length, blockWidth] + omega + have hmem := searchState_complete tm hdec x W hq hW n hn hc + have hwpos : 0 < (wideRuler (codeBlocks k) (blockRuler W)).length := by + rw [wideRuler_blockRuler_length] + exact recordWidth_pos k W + obtain ⟨i, hlen, hblk⟩ := (memFlag_eq_true_iff _ _ _ hwpos).mp hmem + refine (acceptScan_eq_true_iff k _ _ _ _ hRpos).mpr ⟨i, hlen, ?_⟩ + rw [hblk] + exact (acceptFlag_cfgCode tm W c hq (codeInv_of_reachesCfg tm hdec x hc W hW) hW1 + ruler hruler).mpr ⟨hhalt, hout⟩ + +/-! ## The search as one polynomial-time function -/ + +/-- The initial record, built straight from the input. -/ +noncomputable def initRecord (tm : NTM k) (R x : List Bool) : List Bool := + Cobham.initFn (tm.branchTM false) R x + +theorem initRecord_eq (tm : NTM k) (W : ℕ) (x : List Bool) (hx : x.length ≤ W) : + initRecord tm (blockRuler W) x = Cobham.cfgCode W (tm.initCfg x) := + Cobham.initFn_eq (tm.branchTM false) W x hx + +theorem initRecordFn_mem_FP (tm : NTM k) {a b : List Bool → List Bool} (ha : a ∈ FP) + (hb : b ∈ FP) : (fun z => initRecord tm (a z) (b z)) ∈ FP := + binFn_mem_FP (g := initRecord tm) + (Cobham.initFn_mem (tm.branchTM false) (Cobham.proj 0) (Cobham.proj 1)) ha hb + +/-- The packed search, one step per bit of the ruler. -/ +noncomputable def searchRun (tm : NTM k) (R V₀ ruler : List Bool) : List Bool := + (searchStep tm (codeBlocks k))^[ruler.length] (searchPack R [] V₀) + +theorem searchRun_eq (tm : NTM k) (R V₀ ruler : List Bool) : + searchRun tm R V₀ ruler = searchPack R (searchState tm R V₀ ruler.length).1 + (searchState tm R V₀ ruler.length).2 := + searchStep_iterate tm (codeBlocks k) R ([], V₀) ruler.length + +/-- The visited string a search leaves behind. -/ +noncomputable def searchVisited (tm : NTM k) (R V₀ ruler : List Bool) : List Bool := + sndBlock (sndBlock (searchRun tm R V₀ ruler)) + +theorem searchVisited_eq (tm : NTM k) (R V₀ ruler : List Bool) : + searchVisited tm R V₀ ruler = (searchState tm R V₀ ruler.length).2 := by + rw [searchVisited, searchRun_eq, searchPack, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + +/-- **The search is polynomial-time**, given a polynomial bound on its state. -/ +theorem searchVisitedFn_mem_FP (tm : NTM k) + {Rf V₀f rulerf widthf : List Bool → List Bool} (hR : Rf ∈ FP) (hV₀ : V₀f ∈ FP) + (hruler : rulerf ∈ FP) (hwidth : widthf ∈ FP) + (hbound : ∀ x, ∀ n ≤ (rulerf x).length, + ((searchStep tm (codeBlocks k))^[n] (searchPack (Rf x) [] (V₀f x))).length + ≤ (widthf x).length) : + (fun x => searchVisited tm (Rf x) (V₀f x) (rulerf x)) ∈ FP := by + have hinit : (fun x => searchPack (Rf x) [] (V₀f x)) ∈ FP := + Cobham.pairFn_mem_FP hR (Cobham.pairFn_mem_FP (constFn_mem_FP []) hV₀) + have h := Cobham.iterate_mem_FP (searchStep_mem_FP tm (codeBlocks k)) hinit hruler + hwidth hbound + have h1 := mem_FP_comp h Cobham.sndBlock_mem_FP + have h2 := mem_FP_comp h1 Cobham.sndBlock_mem_FP + refine mem_FP_of_eq h2 fun x => ?_ + rw [Function.comp_apply, Function.comp_apply, searchVisited, searchRun] + +/-! ## The verdict -/ + +/-- **The whole decision**: search the configuration graph, then scan the visited +string for an accepting record. -/ +noncomputable def nlVerdict (tm : NTM k) (qp np : Polynomial ℕ) (x : List Bool) : + List Bool := + acceptScan k (stateCode tm.qhalt) (polyRuler (2 * qp + 2) x) (polyRuler qp x) + (searchVisited tm (polyRuler (2 * qp + 2) x) + (initRecord tm (polyRuler (2 * qp + 2) x) x) (polyRuler np x)) + +/-- The verdict is a flag. -/ +theorem nlVerdict_flag (tm : NTM k) (qp np : Polynomial ℕ) (x : List Bool) : + nlVerdict tm qp np x = [true] ∨ nlVerdict tm qp np x = [false] := + acceptScan_flag _ _ _ _ _ + +/-- **The verdict decides the language.** -/ +theorem nlVerdict_eq_true_iff (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (qp np : Polynomial ℕ) + (hqp : ∀ n, n + S n + 1 ≤ qp.eval n) + (hcardq : ∀ n, Fintype.card tm.Q ≤ blockWidth (qp.eval n)) + (hnp : ∀ n, Fintype.card (Code tm.Q k n (S n)) ≤ np.eval n) (x : List Bool) : + nlVerdict tm qp np x = [true] ↔ x ∈ L := by + have hW : x.length + S x.length + 1 ≤ qp.eval x.length := hqp x.length + have hW1 : 1 ≤ qp.eval x.length := by omega + have hxW : x.length ≤ qp.eval x.length := by omega + have hR : polyRuler (2 * qp + 2) x = blockRuler (qp.eval x.length) := + (blockRuler_eq_polyRuler qp x).symm + have hV : searchVisited tm (polyRuler (2 * qp + 2) x) + (initRecord tm (polyRuler (2 * qp + 2) x) x) (polyRuler np x) + = (searchState tm (blockRuler (qp.eval x.length)) + (Cobham.cfgCode (qp.eval x.length) (tm.initCfg x)) (np.eval x.length)).2 := by + rw [searchVisited_eq, hR, initRecord_eq tm _ x hxW, polyRuler_length] + rw [nlVerdict, hV, hR, mem_iff_exists_accepting_reachable hdec x] + constructor + · intro h + exact acceptScan_sound tm hdec x _ (hcardq x.length) hW hW1 _ (polyRuler qp x) + (by rw [polyRuler_length]) h + · rintro ⟨c, hc, hhalt, hout⟩ + exact acceptScan_complete tm hdec x _ (hcardq x.length) hW hW1 _ + (hnp x.length) (polyRuler qp x) (by rw [polyRuler_length]) hc hhalt hout + +/-- **The verdict is polynomial-time.** -/ +theorem nlVerdictFn_mem_FP (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (qp np wp : Polynomial ℕ) + (hqp : ∀ n, n + S n + 1 ≤ qp.eval n) + (hcardq : ∀ n, Fintype.card tm.Q ≤ blockWidth (qp.eval n)) + (hnp : ∀ n, Fintype.card (Code tm.Q k n (S n)) ≤ np.eval n) + (hwp : ∀ n, 2 * (2 * qp.eval n + 2) + 2 * np.eval n + + np.eval n * recordWidth k (qp.eval n) + 4 ≤ wp.eval n) : + (fun x => nlVerdict tm qp np x) ∈ FP := by + have hx : (fun x : List Bool => x) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hRf : (fun x => polyRuler (2 * qp + 2) x) ∈ FP := polyRulerFn_mem_FP _ hx + have hV₀ : (fun x => initRecord tm (polyRuler (2 * qp + 2) x) x) ∈ FP := + initRecordFn_mem_FP tm hRf hx + have hruler : (fun x => polyRuler np x) ∈ FP := polyRulerFn_mem_FP _ hx + have hwidth : (fun x => polyRuler wp x) ∈ FP := polyRulerFn_mem_FP _ hx + have hbound : ∀ x : List Bool, ∀ n ≤ (polyRuler np x).length, + ((searchStep tm (codeBlocks k))^[n] (searchPack (polyRuler (2 * qp + 2) x) [] + (initRecord tm (polyRuler (2 * qp + 2) x) x))).length + ≤ (polyRuler wp x).length := by + intro x n hn + have hW := hqp x.length + have hxW : x.length ≤ qp.eval x.length := by omega + have hR : polyRuler (2 * qp + 2) x = blockRuler (qp.eval x.length) := + (blockRuler_eq_polyRuler qp x).symm + rw [hR, initRecord_eq tm _ x hxW, + searchStep_iterate tm (codeBlocks k) (blockRuler (qp.eval x.length)) + ([], Cobham.cfgCode (qp.eval x.length) (tm.initCfg x)) n, + searchPack_length, polyRuler_length] + have hok := searchState_ok tm hdec x (qp.eval x.length) (hcardq x.length) hW n + have hlen := searchOk_length_le tm hdec x (qp.eval x.length) _ _ hok + have hcnt := searchState_counter tm (blockRuler (qp.eval x.length)) + (Cobham.cfgCode (qp.eval x.length) (tm.initCfg x)) n + have hcard : Fintype.card (Code tm.Q k x.length (S x.length)) + * recordWidth k (qp.eval x.length) + ≤ np.eval x.length * recordWidth k (qp.eval x.length) := + Nat.mul_le_mul_right _ (hnp x.length) + have hbr : (blockRuler (qp.eval x.length)).length = 2 * qp.eval x.length + 2 := by + rw [blockRuler_length, blockWidth] + ring + have hnle : n ≤ np.eval x.length := by + rw [polyRuler_length] at hn + exact hn + have hfin := hwp x.length + rw [searchState] at hlen hcnt + omega + have hqruler : (fun x => polyRuler qp x) ∈ FP := polyRulerFn_mem_FP _ hx + have hV := searchVisitedFn_mem_FP tm hRf hV₀ hruler hwidth hbound + exact acceptScanFn_mem_FP k (stateCode tm.qhalt) hRf hqruler hV + +/-! ## The containment -/ + +/-- **`NL ⊆ P`.** A log-space nondeterministic machine's configuration graph has +polynomially many nodes, and the worklist search above walks all of it in +polynomial time. -/ +theorem NL_subset_P_internal : NL ⊆ P := by + intro Lang hL + obtain ⟨k, tm, S, -, hdec, hS⟩ := hL + obtain ⟨C, D, hCD⟩ := exists_log_bound hS + obtain ⟨A, B, hAB⟩ := exists_config_bound (k := k) tm.Q hS + set qp : Polynomial ℕ := + Polynomial.C (C + 1) * Polynomial.X + Polynomial.C (D + 1 + Fintype.card tm.Q) with hqpdef + set np : Polynomial ℕ := Polynomial.C A * (Polynomial.X + 1) ^ B with hnpdef + set wp : Polynomial ℕ := + 2 * (2 * qp + 2) + 2 * np + np * (Polynomial.C (codeBlocks k) * (2 * qp + 2)) + 4 + with hwpdef + have hqpeval : ∀ n : ℕ, qp.eval n = (C + 1) * n + (D + 1 + Fintype.card tm.Q) := by + intro n + rw [hqpdef] + simp + have hnpeval : ∀ n : ℕ, np.eval n = A * (n + 1) ^ B := by + intro n + rw [hnpdef] + simp + have hqp : ∀ n, n + S n + 1 ≤ qp.eval n := by + intro n + have h1 : S n ≤ C * Nat.log 2 n + D := hCD n + have h2 : Nat.log 2 n ≤ n := Nat.log_le_self 2 n + have h3 : C * Nat.log 2 n ≤ C * n := Nat.mul_le_mul_left _ h2 + rw [hqpeval n] + have h4 : (C + 1) * n = C * n + n := by ring + omega + have hcardq : ∀ n, Fintype.card tm.Q ≤ blockWidth (qp.eval n) := by + intro n + rw [blockWidth, hqpeval n] + omega + have hnp : ∀ n, Fintype.card (Code tm.Q k n (S n)) ≤ np.eval n := by + intro n + rw [hnpeval n] + exact hAB n + have hwp : ∀ n, 2 * (2 * qp.eval n + 2) + 2 * np.eval n + + np.eval n * recordWidth k (qp.eval n) + 4 ≤ wp.eval n := by + intro n + rw [hwpdef, recordWidth, blockRuler_length, blockWidth] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_ofNat, + Polynomial.eval_C] + rw [show 2 * (qp.eval n + 1) = 2 * qp.eval n + 2 from by ring] + refine mem_P_of_decisionFn (f := fun x => nlVerdict tm qp np x) + (nlVerdictFn_mem_FP tm hdec qp np wp hqp hcardq hnp hwp) fun x => ?_ + show x ∈ Lang ↔ ∃ b ∈ nlVerdict tm qp np x, b = true + rw [← nlVerdict_eq_true_iff tm hdec qp np hqp hcardq hnp x] + constructor + · intro h + exact ⟨true, by rw [h]; simp, rfl⟩ + · rintro ⟨b, hb, rfl⟩ + rcases nlVerdict_flag tm qp np x with h | h + · exact h + · rw [h] at hb + simp at hb + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHAssemble.lean b/Complexitylib/Classes/Containments/Internal/PHAssemble.lean new file mode 100644 index 00000000..a2d37e80 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHAssemble.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHPrologue +public import Complexitylib.Classes.Containments.Internal.PHLoop +public import Complexitylib.Classes.Containments.Internal.PHEpilogue + +/-! +# The witness enumerator, assembled + +⚠️ Unreviewed by Bolton + +Five phases: park every head off the marker, copy the input, rewind what the copy left mid-scan, +fill the registers, run the counting loop, and publish whether any witness was accepted. + +## Main results + +- `PolyExists.enumTM` — the machine +- `PolyExists.enumPark_hoareTime` — its first phase, which parks the initial configuration +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- **The witness enumerator.** -/ +def enumTM (M : TM k) (p q : Polynomial ℕ) : TM (enumTapes k) := + TM.seqTM TM.skipTM + (TM.seqTM (TM.copyInputToWorkTM (xIdx k)) + (TM.seqTM (TM.parkRewindTM [xIdx k]) + (TM.seqTM (prologueTM k p q) + (TM.seqTM (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))) + (epilogueTM k))))) + +/-- **The parking phase.** The initial configuration has every head on the left marker, and no +stage of a composed machine can be entered that way; one step moves them all off. -/ +theorem enumPark_hoareTime (k : ℕ) (x : List Bool) : + (TM.skipTM (n := enumTapes k)).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun inp work out => inp = strTape x ∧ work = (fun _ => TM.blankTape) ∧ + out = TM.blankTape) + 1 := by + have hblank : Tape.StartInvariant (Tape.init ([] : List Γ)) := Tape.StartInvariant.init_nil + have hinit : Tape.StartInvariant (Tape.init (x.map Γ.ofBool)) := + Tape.StartInvariant.init_ofBool x + have hb : (⟨max (Tape.init ([] : List Γ)).head 1, (Tape.init ([] : List Γ)).cells⟩ : Tape) + = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show (Tape.init ([] : List Γ)).cells j = _ + rw [TM.blankTape, Tape.move_cells] + have hi : (⟨max (Tape.init (x.map Γ.ofBool)).head 1, (Tape.init (x.map Γ.ofBool)).cells⟩ : + Tape) = strTape x := by + refine Tape.ext rfl (funext fun j => ?_) + show (Tape.init (x.map Γ.ofBool)).cells j = _ + rw [strTape, Tape.move_cells] + refine (TM.parkAll_hoareTime (Tape.init (x.map Γ.ofBool)) + (fun _ => Tape.init ([] : List Γ)) (Tape.init ([] : List Γ)) hinit (fun _ => hblank) + hblank).strengthen_post ?_ + rintro inp work out ⟨hinp, hwork, hout⟩ + exact ⟨by rw [hinp, hi], funext fun i => by rw [hwork i, hb], by rw [hout, hb]⟩ + +/-- The state the copy phase leaves. -/ +def afterCopyX (k : ℕ) (x : List Bool) : TM.TapePred (enumTapes k) := fun inp work out => + inp.cells = (strTape x).cells ∧ inp.head = x.length + 1 ∧ + (∀ i, i ≠ xIdx k → work i = TM.blankTape) ∧ + (work (xIdx k)).HasBinaryPrefix x ∧ (work (xIdx k)).cells 0 = Γ.start ∧ + out = TM.blankTape + +theorem afterCopyX_parked (k : ℕ) (x : List Bool) {inp : Tape} + {work : Fin (enumTapes k) → Tape} {out : Tape} (h : afterCopyX k x inp work out) : + TM.Parked inp ∧ (∀ i, TM.Parked (work i)) ∧ TM.Parked out := by + obtain ⟨hic, hih, hother, hx, hx0, ho⟩ := h + have hIp : TM.Parked inp := by + refine ⟨by omega, fun j hj => ?_⟩ + rw [hic] + exact (strTape_parked x).2 j hj + have hxP : TM.Parked (work (xIdx k)) := by + refine ⟨by rw [hx.1]; omega, fun j hj => ?_⟩ + obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + by_cases hlt : i < x.length + · rw [hx.2.1 i hlt] + cases x[i] <;> simp [Γ.ofBool] + · rw [hx.2.2 i (by omega)] + simp + refine ⟨hIp, fun i => ?_, by rw [ho]; exact TM.blankTape_parked⟩ + by_cases hi : i = xIdx k + · rw [hi]; exact hxP + · rw [hother i hi]; exact TM.blankTape_parked + +/-- Every tape the copy phase leaves is parked, so the boundary after it is the identity. -/ +theorem afterCopyX_trans (k : ℕ) (x : List Bool) (inp : Tape) + (work : Fin (enumTapes k) → Tape) (out : Tape) (h : afterCopyX k x inp work out) : + afterCopyX k x (TM.transitionInput inp) (fun i => TM.transitionTape (work i)) + (TM.transitionTape out) := by + obtain ⟨hIp, hwP, hoP⟩ := afterCopyX_parked k x h + obtain ⟨h1, h2, h3⟩ := trans_id_of_parked hIp hwP hoP + rw [h1, h2, h3] + exact h + +/-- **The rewinding phase.** The copy left the input and its own target mid-scan; this puts both +back at cell one, which pins the bank the prologue starts from. -/ +theorem rewindX_hoareTime (k : ℕ) (x : List Bool) (B : ℕ) (hB : x.length + 1 ≤ B) : + (TM.parkRewindTM [xIdx k]).HoareTime + (afterCopyX k x) + (fun inp work out => inp = strTape x ∧ work = copiedBank k x ∧ out = TM.blankTape) + (1 + 1 + (2 * (max (B + 2) (1 * (B + 3) + 1) + 1) + 1)) := by + intro inp work out hpre + obtain ⟨hIp, hwP, hoP⟩ := afterCopyX_parked k x hpre + obtain ⟨hic, hih, hother, hx, hx0, ho⟩ := hpre + have hB1 : 1 ≤ B := by omega + have hSIw : ∀ i, Tape.StartInvariant (work i) := by + intro i + by_cases hi : i = xIdx k + · rw [hi] + exact ⟨hx0, fun j hj => (hwP (xIdx k)).2 j hj⟩ + · rw [hother i hi] + exact TM.blankTape_startInvariant + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpw, hpo⟩ := + TM.parkRewindTM_hoareTime [xIdx k] (List.nodup_singleton _) B hB1 inp work out + ⟨by rw [hic]; exact (strTape_startInvariant x).1, fun j hj => hIp.2 j hj⟩ + hSIw (by rw [ho]; exact TM.blankTape_startInvariant) + (by omega) (fun j hj => by rw [List.mem_singleton.mp hj, hx.1]; omega) + inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, ?_, ?_, ?_⟩ + · rw [hpi] + exact Tape.ext rfl hic + · rw [hpw] + funext j + by_cases hj : j = xIdx k + · rw [hj] + show (if xIdx k ∈ [xIdx k] then (⟨1, (work (xIdx k)).cells⟩ : Tape) else _) + = copiedBank k x (xIdx k) + rw [if_pos (List.mem_singleton.mpr rfl), copiedBank, Function.update_self] + exact Tape.eq_init_move_right_of_hasBinaryString + (Tape.hasBinaryString_of_hasBinaryPrefix hx rfl rfl) hx0 + · show (if j ∈ [xIdx k] then _ else TM.parkTape (work j)) = copiedBank k x j + rw [if_neg (fun hmem => hj (List.mem_singleton.mp hmem)), copiedBank_of_ne k x j hj, + hother j hj, TM.parkTape] + exact Tape.ext rfl rfl + · rw [hpo, ho, TM.parkTape] + exact Tape.ext rfl rfl + +/-- The enumerator's running time: its six phases and the five boundaries between them. -/ +def enumTime (p q : Polynomial ℕ) (lx : ℕ) (B N bBody bTest A : ℕ) : ℕ := + 1 + 1 + ((lx + 1) + 1 + + ((1 + 1 + (2 * (max (B + 2) (1 * (B + 3) + 1) + 1) + 1)) + 1 + + (prologueTime p q lx + 1 + + (N * (bBody + bTest + 5) + 1 + epilogueTime A)))) + +/-- **The enumerator, contracted.** From its initial configuration the machine ends with `1` in +the verdict slot exactly when some witness of the admitted lengths was accepted. -/ +theorem enumTM_hoareTime (M : TM k) {L' : Language} {T S : ℕ → ℕ} + (hdec : M.DecidesInTime L' T) (hdecS : M.DecidesInSpace L' S) + (p q : Polynomial ℕ) (x : List Bool) (N H B Hb bBody bTest : ℕ) + (hNdef : N = 2 ^ (p.eval x.length + 1) - 1) (hHdef : H = q.eval x.length) + (hN : 1 ≤ N) (hB1 : 1 ≤ B) (hBx : x.length + 1 ≤ B) (hHb1 : 1 ≤ Hb) + (hpair : ∀ v, v < N → 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) + (hspace : ∀ v, v < N → (pair x (dropTop (v + 1))).length + + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) + (hHbH : Hb + 1 ≤ H) + (hlenH : ∀ v, v < N → (pair x (dropTop (v + 1))).length + 1 ≤ H) + (hbodyB : ∀ v, v < N → bodyTime k x T H Hb B v (NTM.tally (enumP L' x) v) + (NTM.tally (fun u => !enumP L' x u) v) ≤ bBody) + (heqB : ∀ v, v < N → 1 + 1 + TM.binaryEqTime (v + 1).bits N.bits ≤ B) + (htestB : ∀ v, v < N → testTime B N v ≤ bTest) : + (enumTM M p q).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun _inp _work out => out = NTM.outSlot (TM.readBackWrite (Γ.ofBool + (decide (0 < NTM.tally (enumP L' x) N))))) + (enumTime p q x.length B N bBody bTest (NTM.tally (enumP L' x) N)) := by + set I : Tape := strTape x with hI + have hIp : TM.Parked I := strTape_parked x + have hIsi : Tape.StartInvariant I := strTape_startInvariant x + have hIhead : I.head = 1 := rfl + have hIz : I.cells 0 = Γ.start := (strTape_startInvariant x).1 + have hpinned : ∀ (W : Fin (enumTapes k) → Tape) (O : Tape), (∀ i, TM.Parked (W i)) → + TM.Parked O → ∀ inp work out, (inp = I ∧ work = W ∧ out = O) → + (TM.transitionInput inp = I ∧ (fun i => TM.transitionTape (work i)) = W ∧ + TM.transitionTape out = O) := by + rintro W O hW hO inp work out ⟨rfl, rfl, rfl⟩ + exact trans_id_of_parked hIp hW hO + have hepi := epilogueTM_hoareTime k x N H (NTM.tally (enumP L' x) N) + (NTM.tally (fun u => !enumP L' x u) N) I hIp hIsi + have hloop := enumLoop_hoareTime M hdec hdecS x N H hN I hIp hIsi hIhead hIz B Hb bBody bTest + hB1 hHb1 hpair hspace hHbH hlenH hbodyB heqB htestB + have hloop' : (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).HoareTime + (NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H 1) (enumP L' x) 0) + (fun inp work out => inp = I ∧ + work = enumBank k x N H N (NTM.tally (enumP L' x) N) + (NTM.tally (fun u => !enumP L' x u) N) ∧ out = NTM.outSlot Γw.one) + (N * (bBody + bTest + 5)) := by + refine hloop.strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, hw, by rw [ho, if_pos rfl]⟩ + have h56 := TM.seqTM_hoareTime _ _ hloop' + (hpinned _ _ (enumBank_parked k x N H N _ _) (NTM.outSlot_parked _)) hepi + have hprol : (prologueTM k p q).HoareTime + (fun inp work out => inp = I ∧ work = copiedBank k x ∧ out = TM.blankTape) + (fun inp work out => inp = I ∧ work = enumBank k x N H 0 0 0 ∧ out = TM.blankTape) + (prologueTime p q x.length) := by + refine (prologueTM_hoareTime k p q x).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, hNdef, hHdef] + have htrans45 : ∀ inp work out, (inp = I ∧ work = enumBank k x N H 0 0 0 ∧ + out = TM.blankTape) → + NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H 1) (enumP L' x) 0 + (TM.transitionInput inp) (fun i => TM.transitionTape (work i)) + (TM.transitionTape out) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + obtain ⟨h1, h2, h3⟩ := trans_id_of_parked hIp (enumBank_parked k x N H 0 0 0) + TM.blankTape_parked + rw [h1, h2, h3] + exact ⟨rfl, rfl, Γw.blank, by decide, NTM.outSlot_blank_eq_blankTape.symm⟩ + have h46 := TM.seqTM_hoareTime _ _ hprol htrans45 h56 + have h36 := TM.seqTM_hoareTime _ _ (rewindX_hoareTime k x B hBx) + (hpinned _ _ (copiedBank_parked k x) TM.blankTape_parked) h46 + have h26 := TM.seqTM_hoareTime _ _ (copyX_hoareTime k x) + (fun inp work out h => afterCopyX_trans k x inp work out h) h36 + exact TM.seqTM_hoareTime _ _ (enumPark_hoareTime k x) + (hpinned _ _ (fun _ => TM.blankTape_parked) TM.blankTape_parked) h26 + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHAssembleWindow.lean b/Complexitylib/Classes/Containments/Internal/PHAssembleWindow.lean new file mode 100644 index 00000000..8809e420 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHAssembleWindow.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHAssemble +public import Complexitylib.Classes.Containments.Internal.PHLoopWindow + +/-! +# The whole enumerator, in space + +⚠️ Unreviewed by Bolton + +Five of the machine's six phases are short, and their windows come from their running times; the +sixth is the counting loop, whose window is one iteration wide. Composing them is what +`TM.seqTM_keepsWindowOn` is for. + +## Main results + +- `PolyExists.afterCopyX_heads` — how far the copy phase can leave a head +- `PolyExists.enumPark_keepsWindowOn` and the other per-phase windows +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- The copy phase leaves every head inside the input's width. -/ +theorem afterCopyX_heads (k : ℕ) (x : List Bool) (inp : Tape) + (work : Fin (enumTapes k) → Tape) (out : Tape) (h : afterCopyX k x inp work out) : + ∀ i, (work i).head ≤ x.length + 1 := by + intro i + by_cases hi : i = xIdx k + · rw [hi, h.2.2.2.1.1] + · rw [h.2.2.1 i hi] + show (1 : ℕ) ≤ x.length + 1 + omega + +theorem copiedBank_head (k : ℕ) (x : List Bool) (i : Fin (enumTapes k)) : + (copiedBank k x i).head = 1 := by + rw [copiedBank] + by_cases h : i = xIdx k + · rw [h, Function.update_self] + exact strTape_head x + · rw [Function.update_of_ne h] + rfl + +/-- The parking phase's window. -/ +theorem enumPark_keepsWindowOn (k : ℕ) (x : List Bool) (W : ℕ) (hW : 1 ≤ W) : + (TM.skipTM (n := enumTapes k)).KeepsWindowOn + (fun c => c.state = (TM.skipTM (n := enumTapes k)).qstart ∧ + (c.input = Tape.init (x.map Γ.ofBool) ∧ + c.work = (fun _ => Tape.init ([] : List Γ)) ∧ c.output = Tape.init ([] : List Γ))) + x.length W := + (TM.keepsWindowOn_of_hoareTime (h₀ := 0) (enumPark_hoareTime k x) + (fun inp work out hpre i => by rw [hpre.2.1]; exact le_of_eq rfl) + (fun inp work out hpre => by rw [hpre.1]; show (0 : ℕ) ≤ x.length + 0 + 1; omega) + (fun inp work out hpre => by rw [hpre.2.2]; show (0 : ℕ) ≤ 0 + 1; omega)).mono_space hW + +/-- The input copy's window. -/ +theorem copyX_keepsWindowOn (k : ℕ) (x : List Bool) (W : ℕ) (hW : 1 + (x.length + 1) ≤ W) : + (TM.copyInputToWorkTM (xIdx k)).KeepsWindowOn + (fun c => c.state = (TM.copyInputToWorkTM (xIdx k)).qstart ∧ + (c.input = strTape x ∧ c.work = (fun _ => TM.blankTape) ∧ c.output = TM.blankTape)) + x.length W := + (TM.keepsWindowOn_of_hoareTime (h₀ := 1) (copyX_hoareTime k x) + (fun inp work out hpre i => by rw [hpre.2.1]; exact le_of_eq rfl) + (fun inp work out hpre => by rw [hpre.1]; show (1 : ℕ) ≤ x.length + 1 + 1; omega) + (fun inp work out hpre => by + rw [hpre.2.2] + show (1 : ℕ) ≤ 1 + 1 + omega)).mono_space hW + +/-- The rewind's window. -/ +theorem rewindX_keepsWindowOn (k : ℕ) (x : List Bool) (B W : ℕ) (hB : x.length + 1 ≤ B) + (hW : (x.length + 1) + (1 + 1 + (2 * (max (B + 2) (1 * (B + 3) + 1) + 1) + 1)) ≤ W) : + (TM.parkRewindTM [xIdx k]).KeepsWindowOn + (fun c => c.state = (TM.parkRewindTM [xIdx k]).qstart ∧ + afterCopyX k x c.input c.work c.output) + x.length W := + (TM.keepsWindowOn_of_hoareTime (h₀ := x.length + 1) (rewindX_hoareTime k x B hB) + (fun inp work out hpre i => afterCopyX_heads k x inp work out hpre i) + (fun inp work out hpre => by rw [hpre.2.1]; omega) + (fun inp work out hpre => by + rw [hpre.2.2.2.2.2] + show (1 : ℕ) ≤ x.length + 1 + 1 + omega)).mono_space hW + +/-- The prologue's window. -/ +theorem prologue_keepsWindowOn (k : ℕ) (p q : Polynomial ℕ) (x : List Bool) (W : ℕ) + (hW : 1 + prologueTime p q x.length ≤ W) : + (prologueTM k p q).KeepsWindowOn + (fun c => c.state = (prologueTM k p q).qstart ∧ + (c.input = strTape x ∧ c.work = copiedBank k x ∧ c.output = TM.blankTape)) + x.length W := + (TM.keepsWindowOn_of_hoareTime (h₀ := 1) (prologueTM_hoareTime k p q x) + (fun inp work out hpre i => by + rw [hpre.2.1, copiedBank_head]) + (fun inp work out hpre => by rw [hpre.1]; show (1 : ℕ) ≤ x.length + 1 + 1; omega) + (fun inp work out hpre => by + rw [hpre.2.2] + show (1 : ℕ) ≤ 1 + 1 + omega)).mono_space hW + +/-- The epilogue's window. -/ +theorem epilogue_keepsWindowOn (k : ℕ) (x : List Bool) (N H A R : ℕ) (I : Tape) + (hI : TM.Parked I) (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (W : ℕ) + (hW : 1 + epilogueTime A ≤ W) : + (epilogueTM k).KeepsWindowOn + (fun c => c.state = (epilogueTM k).qstart ∧ + (c.input = I ∧ c.work = enumBank k x N H N A R ∧ c.output = NTM.outSlot Γw.one)) + x.length W := + (TM.keepsWindowOn_of_hoareTime (h₀ := 1) (epilogueTM_hoareTime k x N H A R I hI hIsi) + (fun inp work out hpre i => by rw [hpre.2.1, enumBank_head]) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.2] + show (1 : ℕ) ≤ 1 + 1 + omega)).mono_space hW + +/-- **The whole machine keeps a window.** Five short phases, whose windows come from their +running times, and one long loop, whose window is one iteration wide. -/ +theorem enumTM_keepsWindowOn (M : TM k) {L' : Language} (p q : Polynomial ℕ) (x : List Bool) + (N H A R : ℕ) (W : ℕ) + (hloopW : (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).KeepsWindowOn + (fun c => c.state = + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart ∧ + NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) (strTape x) (enumRest k x N H 1) + (enumP L' x) 0 c.input c.work c.output) x.length W) + {bnd : ℕ} + (hloopC : (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).HoareTime + (NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) (strTape x) (enumRest k x N H 1) (enumP L' x) 0) + (fun inp work out => inp = strTape x ∧ work = enumBank k x N H N A R ∧ + out = NTM.outSlot Γw.one) bnd) + (hprologuePost : (prologueTM k p q).HoareTime + (fun inp work out => inp = strTape x ∧ work = copiedBank k x ∧ out = TM.blankTape) + (fun inp work out => inp = strTape x ∧ work = enumBank k x N H 0 0 0 ∧ + out = TM.blankTape) (prologueTime p q x.length)) + (B : ℕ) (hBx : x.length + 1 ≤ B) + (hWpark : 1 ≤ W) (hWcopy : 1 + (x.length + 1) ≤ W) + (hWrewind : (x.length + 1) + (1 + 1 + (2 * (max (B + 2) (1 * (B + 3) + 1) + 1) + 1)) ≤ W) + (hWprol : 1 + prologueTime p q x.length ≤ W) + (hWepi : 1 + epilogueTime A ≤ W) : + ∀ c, (enumTM M p q).reaches ((enumTM M p q).initCfg x) c → + c.WithinDecisionSpace x.length W := by + set I : Tape := strTape x with hIdef + have hI : TM.Parked I := strTape_parked x + have hIsi : Tape.StartInvariant I := strTape_startInvariant x + have hIhead : I.head = 1 := rfl + have hs : 1 ≤ W := hWpark + have hpinnedPre : ∀ {Q : Type} (c : Cfg (enumTapes k) Q) (qs : Q) + (W' : Fin (enumTapes k) → Tape) (O : Tape), (∀ i, (W' i).head = 1) → + (∀ i, Tape.StartInvariant (W' i)) → O.head = 1 → Tape.StartInvariant O → + c.state = qs → c.input = I → c.work = W' → c.output = O → + c.state = qs ∧ c.WithinDecisionSpace x.length W ∧ TM.CfgStartInvariant c := by + intro Q c qs W' O hW'h hW'si hOh hOsi hst hi hw ho + refine ⟨hst, ⟨⟨fun i => ?_, ?_⟩, ?_⟩, ?_, ?_, ?_⟩ + · rw [hw, hW'h i]; omega + · rw [hi, hIhead]; omega + · rw [ho, hOh]; omega + · rw [hi]; exact hIsi + · intro i; rw [hw]; exact hW'si i + · rw [ho]; exact hOsi + -- the epilogue + have w6 := epilogue_keepsWindowOn k x N H A R I hI hIsi hIhead W hWepi + -- loop and epilogue + have c56 := TM.seqTM_keepsWindowOn + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))) (epilogueTM k) hs + (mid := fun inp work out => inp = I ∧ work = enumBank k x N H N A R ∧ + out = NTM.outSlot Γw.one) + (fun c hc => by + obtain ⟨hi, hw, sy, -, ho⟩ := hc.2 + exact hpinnedPre c _ (enumBank k x N H 0 0 0) (NTM.outSlot sy) + (fun i => enumBank_head k x N H 0 0 0 i) + (fun i => enumBank_startInvariant k x N H 0 0 0 i) rfl + ⟨rfl, fun j hj => (NTM.outSlot_parked sy).2 j hj⟩ hc.1 hi hw ho) + hloopW + (fun c hc => hoare_post_of hloopC c hc.1 hc.2) + w6 + (fun inp work out h => + ⟨rfl, by + show TM.transitionInput inp = I + rw [h.1] + exact TM.transitionInput_eq_self hI.read_ne_start, + by + show (fun i => TM.transitionTape (work i)) = enumBank k x N H N A R + rw [h.2.1] + exact funext fun i => TM.transitionTape_eq_self + (enumBank_parked k x N H N A R i).read_ne_start, + by + show TM.transitionTape out = NTM.outSlot Γw.one + rw [h.2.2] + exact TM.transitionTape_eq_self (NTM.outSlot_parked _).read_ne_start⟩) + -- prologue + have c46 := TM.seqTM_keepsWindowOn (prologueTM k p q) _ hs + (mid := fun inp work out => inp = I ∧ work = enumBank k x N H 0 0 0 ∧ out = TM.blankTape) + (fun c hc => by + obtain ⟨hi, hw, ho⟩ := hc.2 + exact hpinnedPre c _ (copiedBank k x) TM.blankTape (copiedBank_head k x) + (fun i => by + rw [copiedBank] + by_cases hix : i = xIdx k + · rw [hix, Function.update_self] + exact strTape_startInvariant x + · rw [Function.update_of_ne hix] + exact TM.blankTape_startInvariant) rfl TM.blankTape_startInvariant hc.1 hi hw ho) + (prologue_keepsWindowOn k p q x W hWprol) + (fun c hc => hoare_post_of hprologuePost c hc.1 hc.2) + c56 + (fun inp work out h => ⟨⟨(TM.loopTM (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, by rw [h.1]; exact TM.transitionInput_eq_self hI.read_ne_start, + by + rw [h.2.1] + exact funext fun i => TM.transitionTape_eq_self + (enumBank_parked k x N H 0 0 0 i).read_ne_start, + ⟨Γw.blank, by decide, by + rw [h.2.2, TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start] + exact NTM.outSlot_blank_eq_blankTape.symm⟩⟩, rfl⟩) + -- rewind + have c36 := TM.seqTM_keepsWindowOn (TM.parkRewindTM [xIdx k]) _ hs + (mid := fun inp work out => inp = I ∧ work = copiedBank k x ∧ out = TM.blankTape) + (fun c hc => by + obtain ⟨hIp', hwP', hoP'⟩ := afterCopyX_parked k x hc.2 + refine ⟨hc.1, ⟨⟨fun i => le_trans (afterCopyX_heads k x _ _ _ hc.2 i) (by omega), + by rw [hc.2.2.1]; omega⟩, ?_⟩, ?_, ?_, ?_⟩ + · rw [hc.2.2.2.2.2.2] + show (1 : ℕ) ≤ W + 1 + omega + · exact ⟨by rw [hc.2.1]; exact (strTape_startInvariant x).1, + fun j hj => hIp'.2 j hj⟩ + · intro i + by_cases hix : i = xIdx k + · rw [hix] + exact ⟨hc.2.2.2.2.2.1, fun j hj => (hwP' (xIdx k)).2 j hj⟩ + · rw [hc.2.2.2.1 i hix] + exact TM.blankTape_startInvariant + · rw [hc.2.2.2.2.2.2] + exact TM.blankTape_startInvariant) + (rewindX_keepsWindowOn k x B W hBx hWrewind) + (fun c hc => hoare_post_of (rewindX_hoareTime k x B hBx) c hc.1 hc.2) + c46 + (fun inp work out h => ⟨⟨(prologueTM k p q).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, by rw [h.1]; exact TM.transitionInput_eq_self hI.read_ne_start, + by + rw [h.2.1] + exact funext fun i => TM.transitionTape_eq_self (copiedBank_parked k x i).read_ne_start, + by + rw [h.2.2] + exact TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start⟩, rfl⟩) + -- copy + have c26 := TM.seqTM_keepsWindowOn (TM.copyInputToWorkTM (xIdx k)) _ hs + (mid := afterCopyX k x) + (fun c hc => by + obtain ⟨hi, hw, ho⟩ := hc.2 + exact hpinnedPre c _ (fun _ => TM.blankTape) TM.blankTape (fun _ => rfl) + (fun _ => TM.blankTape_startInvariant) rfl TM.blankTape_startInvariant hc.1 hi hw ho) + (copyX_keepsWindowOn k x W hWcopy) + (fun c hc => hoare_post_of (copyX_hoareTime k x) c hc.1 hc.2) + c36 + (fun inp work out h => ⟨⟨(TM.parkRewindTM [xIdx k]).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, afterCopyX_trans k x inp work out h⟩, rfl⟩) + -- park + have c16 := TM.seqTM_keepsWindowOn (TM.skipTM (n := enumTapes k)) _ hs + (mid := fun inp work out => inp = I ∧ work = (fun _ => TM.blankTape) ∧ out = TM.blankTape) + (fun c hc => by + obtain ⟨hi, hw, ho⟩ := hc.2 + refine ⟨hc.1, ⟨⟨fun i => by rw [hw]; show (0 : ℕ) ≤ W; omega, + by rw [hi]; show (0 : ℕ) ≤ x.length + W + 1; omega⟩, ?_⟩, ?_, ?_, ?_⟩ + · rw [ho] + show (0 : ℕ) ≤ W + 1 + omega + · rw [hi] + exact Tape.StartInvariant.init_ofBool x + · intro i + rw [hw] + exact Tape.StartInvariant.init_nil + · rw [ho] + exact Tape.StartInvariant.init_nil) + (enumPark_keepsWindowOn k x W hWpark) + (fun c hc => hoare_post_of (enumPark_hoareTime k x) c hc.1 hc.2) + c26 + (fun inp work out h => ⟨⟨(TM.copyInputToWorkTM (xIdx k)).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, by rw [h.1]; exact TM.transitionInput_eq_self hI.read_ne_start, + by + rw [h.2.1] + exact funext fun i => TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start, + by + rw [h.2.2] + exact TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start⟩, rfl⟩) + intro c hD + exact c16 _ ⟨⟨(TM.skipTM (n := enumTapes k)).qstart, Tape.init (x.map Γ.ofBool), + fun _ => Tape.init ([] : List Γ), Tape.init ([] : List Γ)⟩, ⟨rfl, rfl, rfl, rfl⟩, rfl⟩ c hD + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHBank.lean b/Complexitylib/Classes/Containments/Internal/PHBank.lean new file mode 100644 index 00000000..064ad1f6 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHBank.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHLayout +public import Complexitylib.Classes.Containments.Internal.TallyLoopIndexed +public import Complexitylib.Classes.Containments.Internal.WitnessEnum + +/-! +# What the enumerator's tapes rest in between iterations + +⚠️ Unreviewed by Bolton + +The counting loop's state names three registers; every other tape has to be back at a known +resting value when an iteration ends, or the next one cannot be entered. For the witness +enumerator that bank is *not* the same at every index: the witness tape advances with the counter, +which is why the loop rule this machine uses is the indexed one. + +Everything else rests where it started — the input copy rewound, the horizon in place, the wipe's +height register loaded, and every scratch tape blank. + +## Main results + +- `PolyExists.strTape` — a rewound tape holding a bitstring, and that it is parked +- `PolyExists.enumRest` — the resting bank at a given count, and its values at the named indices +- `PolyExists.enumRest_parked`, `PolyExists.enumRest_head` — what the loop rule asks of it +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- A rewound tape holding a bitstring. -/ +def strTape (l : List Bool) : Tape := (Tape.init (l.map Γ.ofBool)).move Dir3.right + +@[simp] theorem strTape_head (l : List Bool) : (strTape l).head = 1 := rfl + +theorem strTape_hasBinaryString (l : List Bool) : (strTape l).HasBinaryString l := + Tape.init_move_right_hasBinaryString l + +/-- **A tape holding a bitstring is parked**: its head is off the left marker and no cell past +the marker holds one. -/ +theorem strTape_parked (l : List Bool) : TM.Parked (strTape l) := by + have h : (strTape l).HasBinaryString l := strTape_hasBinaryString l + refine ⟨by rw [show (strTape l).head = 1 from h.1], fun j hj => ?_⟩ + obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + by_cases hb : i < l.length + · rw [h.2.1 i hb] + cases l[i] <;> simp [Γ.ofBool] + · rw [h.2.2 i (by omega)] + simp + +theorem strTape_startInvariant (l : List Bool) : Tape.StartInvariant (strTape l) := + (TM.startInvariant_initOfBool l).move Dir3.right + +theorem regTape_parked (v : ℕ) : TM.Parked (TM.regTape v) := by + refine ⟨le_of_eq rfl, fun j hj => ?_⟩ + show (if j = 0 then Γ.start else if j ≤ v then Γ.one else Γ.blank) ≠ Γ.start + rw [if_neg (by omega)] + split <;> decide + +theorem regTape_startInvariant (v : ℕ) : Tape.StartInvariant (TM.regTape v) := by + refine ⟨rfl, fun j hj => ?_⟩ + show (if j = 0 then Γ.start else if j ≤ v then Γ.one else Γ.blank) ≠ Γ.start + rw [if_neg (by omega)] + split <;> decide + +/-- **The resting bank at a given count.** The input copy and the horizon are where the prologue +put them, the wipe's height register is loaded, the witness is the one the count denotes, and +every scratch tape is blank. -/ +def enumRest (k : ℕ) (x : List Bool) (N H : ℕ) (v : ℕ) : Fin (enumTapes k) → Tape := fun i => + if i = xIdx k then strTape x + else if i = wIdx k then strTape (dropTop v) + else if i = nIdx k then natTape N + else if i = regIdx k then TM.regTape H + else TM.blankTape + +@[simp] theorem enumRest_x (k : ℕ) (x : List Bool) (N H v : ℕ) : + enumRest k x N H v (xIdx k) = strTape x := by + rw [enumRest, if_pos rfl] + +@[simp] theorem enumRest_w (k : ℕ) (x : List Bool) (N H v : ℕ) : + enumRest k x N H v (wIdx k) = strTape (dropTop v) := by + obtain ⟨hxw, -⟩ := enumIdx_distinct k + rw [enumRest, if_neg (fun h => hxw h.symm), if_pos rfl] + +@[simp] theorem enumRest_n (k : ℕ) (x : List Bool) (N H v : ℕ) : + enumRest k x N H v (nIdx k) = natTape N := by + have hxn : nIdx k ≠ xIdx k := fun h => by + have h' := congrArg Fin.val h + simp only [nIdx, xIdx] at h' + omega + have hwn : nIdx k ≠ wIdx k := fun h => by + have h' := congrArg Fin.val h + simp only [nIdx, wIdx] at h' + omega + rw [enumRest, if_neg hxn, if_neg hwn, if_pos rfl] + +/-- **The bank is parked at every index**, which is what the loop rule asks of the tapes its +state does not name. -/ +theorem enumRest_parked (k : ℕ) (x : List Bool) (N H v : ℕ) (i : Fin (enumTapes k)) : + TM.Parked (enumRest k x N H v i) := by + rw [enumRest] + split + · exact strTape_parked x + · split + · exact strTape_parked _ + · split + · exact natTape_parked N + · split + · exact regTape_parked H + · exact TM.blankTape_parked + +/-- **Every resting tape is at cell one**, which is what makes the loop's window one iteration +wide. -/ +theorem enumRest_head (k : ℕ) (x : List Bool) (N H v : ℕ) (i : Fin (enumTapes k)) : + (enumRest k x N H v i).head ≤ 1 := by + rw [enumRest] + split + · exact le_of_eq rfl + · split + · exact le_of_eq rfl + · split + · exact le_of_eq (Tape.init_move_right_hasBinaryNat N).2.1 + · split + · exact le_of_eq rfl + · exact le_of_eq rfl + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHBody.lean b/Complexitylib/Classes/Containments/Internal/PHBody.lean new file mode 100644 index 00000000..b17ef1ae --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHBody.lean @@ -0,0 +1,1284 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHBank +public import Complexitylib.Classes.Containments.Internal.PHEmit +public import Complexitylib.Classes.Containments.Internal.PHMatrix +public import Complexitylib.Classes.Containments.Internal.PPBody +public import Complexitylib.Classes.Containments.Internal.PPTest +public import Complexitylib.Models.TuringMachine.Subroutines.CopyToVirtualInput +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryBump +public import Complexitylib.Models.TuringMachine.Hoare.StartInvariant + +/-! +# One pass of the witness enumerator + +⚠️ Unreviewed by Bolton + +An iteration takes the count `v`, tests the witness it denotes, and leaves the loop one count +further along. In order: + +1. blank the verdict slot, so the pass starts from a known output; +2. emit `pair x w` onto the first pair tape; +3. rewind the input copy, the witness, and that tape, which the emitter left mid-scan; +4. copy the pair into virtual-input shape on the tape the matrix machine reads; +5. run the matrix machine, which writes its verdict to the verdict tape; +6. rewind the verdict tape, since the matrix machine left its head wherever it halted; +7. publish that verdict into the slot; +8. bump the tally the slot names and advance the counter; +9. advance the witness in step with the counter; +10. blank everything the pass dirtied. + +Steps 8 and 10 are the counting machine's own — `TM.tallyBumpTM` and `TM.wipeRewindTM` — and step +9 is what makes the loop's resting bank depend on the count. + +## Main results + +- `PolyExists.copyPairTM` — the copy into virtual-input shape +- `PolyExists.bodyTM` — one pass of the enumerator +- `PolyExists.enumBank` — the tapes an iteration starts from, and its values at the named indices +- `PolyExists.blankSlot_hoareTime` — the first stage's contract +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- Move the emitted pair onto the tape the matrix machine reads, in the shape it expects. -/ +def copyPairTM (k : ℕ) : TM (enumTapes k) := + TM.seqTM (TM.copyWorkToWorkTM (y1Idx k) (yIdx k)) (TM.rewindWorkTM (yIdx k)) + +/-- **One pass of the witness enumerator.** -/ +def bodyTM (M : TM k) : TM (enumTapes k) := + TM.seqTM (TM.writeOutputBitTM (zIdx k)) + (TM.seqTM (emitTM k) + (TM.seqTM (TM.parkRewindTM [xIdx k, wIdx k, y1Idx k]) + (TM.seqTM (copyPairTM k) + (TM.seqTM (matrixTM M) + (TM.seqTM (TM.parkRewindTM [vIdx k]) + (TM.seqTM (TM.writeOutputBitTM (vIdx k)) + (TM.seqTM (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)) + (TM.seqTM (TM.binaryBumpTM (wIdx k)) + (TM.wipeRewindTM (scratchTargets k) (regIdx k)))))))))) + +/-! ## The bank the loop rests in -/ + +/-- The tapes at count `v` with tallies `a` and `r`: the loop's three registers over the resting +bank. -/ +def enumBank (k : ℕ) (x : List Bool) (N H v a r : ℕ) : Fin (enumTapes k) → Tape := + tallyWork (cIdx k) (aIdx k) (rIdx k) (enumRest k x N H (v + 1)) (v, a, r) + +/-- A tape that is none of the loop's three registers rests where the bank puts it. -/ +theorem enumBank_of_ne (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) + (hc : i ≠ cIdx k) (ha : i ≠ aIdx k) (hr : i ≠ rIdx k) : + enumBank k x N H v a r i = enumRest k x N H (v + 1) i := by + rw [enumBank, tallyWork] + dsimp only + rw [if_neg hc, if_neg ha, if_neg hr] + +theorem ne_tallyRegs {k : ℕ} (i : Fin (enumTapes k)) + (h2 : i.val ≠ 3 + k + 2) (h5 : i.val ≠ 3 + k + 5) (h8 : i.val ≠ 3 + k + 8) : + i ≠ cIdx k ∧ i ≠ aIdx k ∧ i ≠ rIdx k := + ⟨Fin.ne_of_val_ne h2, Fin.ne_of_val_ne h5, Fin.ne_of_val_ne h8⟩ + +theorem x_ne_regs (k : ℕ) : xIdx k ≠ cIdx k ∧ xIdx k ≠ aIdx k ∧ xIdx k ≠ rIdx k := + ne_tallyRegs _ (by show (0 : ℕ) ≠ 3 + k + 2; omega) (by show (0 : ℕ) ≠ 3 + k + 5; omega) + (by show (0 : ℕ) ≠ 3 + k + 8; omega) + +theorem w_ne_regs (k : ℕ) : wIdx k ≠ cIdx k ∧ wIdx k ≠ aIdx k ∧ wIdx k ≠ rIdx k := + ne_tallyRegs _ (by show (1 : ℕ) ≠ 3 + k + 2; omega) (by show (1 : ℕ) ≠ 3 + k + 5; omega) + (by show (1 : ℕ) ≠ 3 + k + 8; omega) + +theorem y1_ne_regs (k : ℕ) : y1Idx k ≠ cIdx k ∧ y1Idx k ≠ aIdx k ∧ y1Idx k ≠ rIdx k := + ne_tallyRegs _ (by show (2 : ℕ) ≠ 3 + k + 2; omega) (by show (2 : ℕ) ≠ 3 + k + 5; omega) + (by show (2 : ℕ) ≠ 3 + k + 8; omega) + +theorem y_ne_regs (k : ℕ) : yIdx k ≠ cIdx k ∧ yIdx k ≠ aIdx k ∧ yIdx k ≠ rIdx k := + ne_tallyRegs _ (by show 3 + k ≠ 3 + k + 2; omega) (by show 3 + k ≠ 3 + k + 5; omega) + (by show 3 + k ≠ 3 + k + 8; omega) + +theorem v_ne_regs (k : ℕ) : vIdx k ≠ cIdx k ∧ vIdx k ≠ aIdx k ∧ vIdx k ≠ rIdx k := + ne_tallyRegs _ (by show 3 + k + 1 ≠ 3 + k + 2; omega) (by show 3 + k + 1 ≠ 3 + k + 5; omega) + (by show 3 + k + 1 ≠ 3 + k + 8; omega) + +theorem n_ne_regs (k : ℕ) : nIdx k ≠ cIdx k ∧ nIdx k ≠ aIdx k ∧ nIdx k ≠ rIdx k := + ne_tallyRegs _ (by show 3 + k + 3 ≠ 3 + k + 2; omega) (by show 3 + k + 3 ≠ 3 + k + 5; omega) + (by show 3 + k + 3 ≠ 3 + k + 8; omega) + +theorem res_ne_regs (k : ℕ) : resIdx k ≠ cIdx k ∧ resIdx k ≠ aIdx k ∧ resIdx k ≠ rIdx k := + ne_tallyRegs _ (by show 3 + k + 4 ≠ 3 + k + 2; omega) (by show 3 + k + 4 ≠ 3 + k + 5; omega) + (by show 3 + k + 4 ≠ 3 + k + 8; omega) + +theorem z_ne_regs (k : ℕ) : zIdx k ≠ cIdx k ∧ zIdx k ≠ aIdx k ∧ zIdx k ≠ rIdx k := + ne_tallyRegs _ (by show 3 + k + 6 ≠ 3 + k + 2; omega) (by show 3 + k + 6 ≠ 3 + k + 5; omega) + (by show 3 + k + 6 ≠ 3 + k + 8; omega) + +theorem reg_ne_regs (k : ℕ) : regIdx k ≠ cIdx k ∧ regIdx k ≠ aIdx k ∧ regIdx k ≠ rIdx k := + ne_tallyRegs _ (by show 3 + k + 7 ≠ 3 + k + 2; omega) (by show 3 + k + 7 ≠ 3 + k + 5; omega) + (by show 3 + k + 7 ≠ 3 + k + 8; omega) + +@[simp] theorem enumBank_x (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (xIdx k) = strTape x := by + rw [enumBank_of_ne k x N H v a r _ (x_ne_regs k).1 (x_ne_regs k).2.1 (x_ne_regs k).2.2, + enumRest_x] + +@[simp] theorem enumBank_w (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (wIdx k) = strTape (dropTop (v + 1)) := by + rw [enumBank_of_ne k x N H v a r _ (w_ne_regs k).1 (w_ne_regs k).2.1 (w_ne_regs k).2.2, + enumRest_w] + +/-- Every scratch tape rests blank. -/ +theorem enumRest_blank (k : ℕ) (x : List Bool) (N H v : ℕ) (i : Fin (enumTapes k)) + (hx : i ≠ xIdx k) (hw : i ≠ wIdx k) (hn : i ≠ nIdx k) (hreg : i ≠ regIdx k) : + enumRest k x N H v i = TM.blankTape := by + rw [enumRest, if_neg hx, if_neg hw, if_neg hn, if_neg hreg] + +theorem enumBank_blank (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) + (hc : i ≠ cIdx k) (ha : i ≠ aIdx k) (hr : i ≠ rIdx k) + (hx : i ≠ xIdx k) (hw : i ≠ wIdx k) (hn : i ≠ nIdx k) (hreg : i ≠ regIdx k) : + enumBank k x N H v a r i = TM.blankTape := by + rw [enumBank_of_ne k x N H v a r i hc ha hr, + enumRest_blank k x N H (v + 1) i hx hw hn hreg] + +@[simp] theorem enumBank_y1 (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (y1Idx k) = TM.blankTape := + enumBank_blank k x N H v a r _ (y1_ne_regs k).1 (y1_ne_regs k).2.1 (y1_ne_regs k).2.2 + (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 0; omega)) + (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 1; omega)) + (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 3 + k + 3; omega)) + (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 3 + k + 7; omega)) + +@[simp] theorem enumBank_z (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (zIdx k) = TM.blankTape := + enumBank_blank k x N H v a r _ (z_ne_regs k).1 (z_ne_regs k).2.1 (z_ne_regs k).2.2 + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 0; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 1; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 3; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 7; omega)) + +/-- **The bank is parked on every tape.** -/ +theorem enumBank_parked (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) : + TM.Parked (enumBank k x N H v a r i) := by + rw [enumBank, tallyWork] + dsimp only + split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · exact enumRest_parked k x N H (v + 1) i + +theorem natTape_startInvariant (v : ℕ) : Tape.StartInvariant (natTape v) := + ⟨NTM.natTape_cells_zero v, fun j hj => (natTape_parked v).2 j hj⟩ + +theorem strTape_cells_zero (l : List Bool) : (strTape l).cells 0 = Γ.start := + (strTape_startInvariant l).1 + +/-- **The bank satisfies the left-marker invariant on every tape**, which every rewind, park and +wipe downstream asks of the tapes it carries. -/ +theorem enumBank_startInvariant (k : ℕ) (x : List Bool) (N H v a r : ℕ) + (i : Fin (enumTapes k)) : Tape.StartInvariant (enumBank k x N H v a r i) := by + rw [enumBank, tallyWork] + dsimp only + split + · exact natTape_startInvariant _ + · split + · exact natTape_startInvariant _ + · split + · exact natTape_startInvariant _ + · rw [enumRest] + split + · exact strTape_startInvariant x + · split + · exact strTape_startInvariant _ + · split + · exact natTape_startInvariant N + · split + · exact regTape_startInvariant H + · exact TM.blankTape_startInvariant + +/-- **Every tape of the bank is parked at cell one.** -/ +theorem enumBank_head (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) : + (enumBank k x N H v a r i).head = 1 := by + have hle : (enumBank k x N H v a r i).head ≤ 1 := by + rw [enumBank, tallyWork] + dsimp only + split + · exact le_of_eq (Tape.init_move_right_hasBinaryNat _).2.1 + · split + · exact le_of_eq (Tape.init_move_right_hasBinaryNat _).2.1 + · split + · exact le_of_eq (Tape.init_move_right_hasBinaryNat _).2.1 + · exact enumRest_head k x N H (v + 1) i + have hge : 1 ≤ (enumBank k x N H v a r i).head := (enumBank_parked k x N H v a r i).1 + omega + +theorem natTape_head_one (v : ℕ) : (natTape v).head = 1 := + (Tape.init_move_right_hasBinaryNat v).2.1 + +/-- **The body's first stage: blank the verdict slot.** The loop returns to its start state with +the previous check's verdict still in the slot; everything downstream — the emitter, the matrix +machine, the wipe — needs the real output tape blank. -/ +theorem blankSlot_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) : + (TM.writeOutputBitTM (zIdx k)).HoareTime + (fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ out = NTM.outSlot s) + (fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ out = TM.blankTape) + 1 := by + intro inp work out hpre + obtain ⟨hi, hw, s, -, ho⟩ := hpre + refine (TM.writeOutputBitTM_hoareTime_frame (zIdx k) I (enumBank k x N H v a r) + (NTM.outSlot s) hI (enumBank_parked k x N H v a r) (NTM.outSlot_parked _)).strengthen_post + (post' := fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ + out = TM.blankTape) ?_ inp work out ⟨hi, hw, ho⟩ + rintro inp' work' out' ⟨hi', hw', ho'⟩ + refine ⟨hi', hw', ?_⟩ + have hread : (enumBank k x N H v a r (zIdx k)).read = Γ.blank := by + rw [enumBank_z] + exact Tape.init_nil_move_right_read + rw [ho', hread, ← NTM.outSlot_blank_eq_blankTape] + show (NTM.outSlot s).write (TM.readBackWrite Γ.blank).toΓ = _ + exact NTM.outSlot_write s Γw.blank + +theorem blankTape_eq_parkedBlank : TM.blankTape = TM.parkedBlank := rfl + +/-- The tapes after the pair has been emitted and everything the emitter scanned rewound: the +bank, with the pair now on its tape. -/ +def afterPair (k : ℕ) (x : List Bool) (N H v a r : ℕ) : Fin (enumTapes k) → Tape := + Function.update (enumBank k x N H v a r) (y1Idx k) (strTape (pair x (dropTop (v + 1)))) + +/-- What the emitter leaves behind: the pair on its tape, both sources with their cells intact, +every other tape untouched, and no head further out than the stage is long. -/ +def midEmit (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (B : ℕ) : + TM.TapePred (enumTapes k) := fun inp work out => + inp = I ∧ out = TM.blankTape ∧ + (∀ i, ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 i → work i = enumBank k x N H v a r i) ∧ + (work (xIdx k)).cells = (strTape x).cells ∧ + (work (wIdx k)).cells = (strTape (dropTop (v + 1))).cells ∧ + (work (y1Idx k)).HasBinaryPrefix (pair x (dropTop (v + 1))) ∧ + (∀ i, Tape.StartInvariant (work i)) ∧ (∀ i, (work i).head ≤ B) + +/-- **The emitting stage's contract.** -/ +theorem emit_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hISI : Tape.StartInvariant I) (B : ℕ) + (hB : 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) : + (emitTM k).HoareTime + (fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ out = TM.blankTape) + (midEmit k x N H v a r I B) + (TM.pairInputWorkTime x (dropTop (v + 1))) := by + have hbase := emitTM_hoareTime k x (dropTop (v + 1)) (strTape x) rfl + (Tape.hasOutput_of_hasBinaryString (strTape_hasBinaryString x)) (strTape_startInvariant x) + (enumBank k x N H v a r) + (fun i _ => enumBank_startInvariant k x N H v a r i) + (fun i _ => le_of_eq (enumBank_head k x N H v a r i).symm) + rintro inp work out ⟨hi, hw, ho⟩ + obtain ⟨c', t, ht, hreach, hhalt, hframe, hxc, hxout, hwc, hy1, hoeq⟩ := + hbase inp work out ⟨fun i _ => by rw [hw], by rw [hw, enumBank_x], + by rw [hw, enumBank_w]; rfl, by rw [hw, enumBank_y1, blankTape_eq_parkedBlank], + by rw [ho, blankTape_eq_parkedBlank]⟩ + have hSI := TM.reachesIn_startInvariant hreach (by rw [hi]; exact hISI) + (fun i => by rw [hw]; exact enumBank_startInvariant k x N H v a r i) + (by rw [ho]; exact TM.blankTape_startInvariant) + obtain ⟨-, -, hwork⟩ := TM.head_le_start_add_of_reachesIn (emitTM k) hreach + dsimp only at hwork + refine ⟨c', t, ht, hreach, hhalt, ?_, ?_, hframe, hxc, hwc, hy1, hSI.2.1, fun i => ?_⟩ + · rw [← hi] + exact TM.reachesIn_input_eq_of_idlesInput + (show TM.IdlesInput (emitTM k) from fun _ _ _ _ => rfl) hreach (by rw [hi]; exact hI) + · rw [hoeq, blankTape_eq_parkedBlank] + · have h1 := hwork i + have h2 : (work i).head = 1 := by rw [hw]; exact enumBank_head k x N H v a r i + omega + +theorem pairTargets_nodup (k : ℕ) : + ([xIdx k, wIdx k, y1Idx k] : List (Fin (enumTapes k))).Nodup := by + have h01 : xIdx k ≠ wIdx k := Fin.ne_of_val_ne (by show (0 : ℕ) ≠ 1; omega) + have h02 : xIdx k ≠ y1Idx k := Fin.ne_of_val_ne (by show (0 : ℕ) ≠ 2; omega) + have h12 : wIdx k ≠ y1Idx k := Fin.ne_of_val_ne (by show (1 : ℕ) ≠ 2; omega) + simp [h01, h02, h12] + +/-- A tape of the layout is one of the three the emitter touches exactly when it is inside the +emitter's block. -/ +theorem mem_pairTargets_iff (k : ℕ) (j : Fin (enumTapes k)) : + j ∈ ([xIdx k, wIdx k, y1Idx k] : List (Fin (enumTapes k))) ↔ + TM.placeWorkInMiddle (post := k + 9) 0 3 j := by + constructor + · intro h + refine ⟨Nat.zero_le _, ?_⟩ + rcases List.mem_cons.mp h with h | h + · rw [h]; show (0 : ℕ) < 0 + 3; omega + · rcases List.mem_cons.mp h with h | h + · rw [h]; show (1 : ℕ) < 0 + 3; omega + · rcases List.mem_cons.mp h with h | h + · rw [h]; show (2 : ℕ) < 0 + 3; omega + · exact absurd h (List.not_mem_nil) + · rintro ⟨-, hlt⟩ + have hcases : j.val = 0 ∨ j.val = 1 ∨ j.val = 2 := by omega + rcases hcases with h | h | h + · exact List.mem_cons.mpr (Or.inl (Fin.ext h)) + · exact List.mem_cons.mpr (Or.inr (List.mem_cons.mpr (Or.inl (Fin.ext h)))) + · exact List.mem_cons.mpr (Or.inr (List.mem_cons.mpr (Or.inr + (List.mem_cons.mpr (Or.inl (Fin.ext h)))))) + +/-- **The rewinding stage's contract.** The emitter left three heads mid-scan; this puts them +back at cell one, which pins every tape again. -/ +theorem parkPair_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hISI : Tape.StartInvariant I) (hIhead : I.head = 1) (B : ℕ) (hB : 1 ≤ B) : + (TM.parkRewindTM [xIdx k, wIdx k, y1Idx k]).HoareTime + (midEmit k x N H v a r I B) + (fun inp work out => inp = I ∧ work = afterPair k x N H v a r ∧ out = TM.blankTape) + (1 + 1 + (2 * (max (B + 2) (3 * (B + 3) + 1) + 1) + 1)) := by + rintro inp work out ⟨hi, ho, hframe, hxc, hwc, hy1, hSI, hhead⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpw, hpo⟩ := + TM.parkRewindTM_hoareTime [xIdx k, wIdx k, y1Idx k] (pairTargets_nodup k) B hB inp work out + (by rw [hi]; exact hISI) hSI (by rw [ho]; exact TM.blankTape_startInvariant) + (by rw [hi, hIhead]; exact hB) (fun j _ => hhead j) + inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, ?_, ?_, ?_⟩ + · rw [hpi, hi] + exact Tape.ext hIhead.symm rfl + · rw [hpw] + funext j + by_cases hj : j ∈ ([xIdx k, wIdx k, y1Idx k] : List (Fin (enumTapes k))) + · rw [if_pos hj] + rcases List.mem_cons.mp hj with h | h + · rw [h, afterPair, Function.update_of_ne + (Fin.ne_of_val_ne (by show (0 : ℕ) ≠ 2; omega)), enumBank_x] + exact Tape.ext rfl hxc + · rcases List.mem_cons.mp h with h | h + · rw [h, afterPair, Function.update_of_ne + (Fin.ne_of_val_ne (by show (1 : ℕ) ≠ 2; omega)), enumBank_w] + exact Tape.ext rfl hwc + · rcases List.mem_cons.mp h with h | h + · rw [h, afterPair, Function.update_self] + exact Tape.eq_init_move_right_of_hasBinaryString + (Tape.hasBinaryString_of_hasBinaryPrefix hy1 rfl rfl) (hSI (y1Idx k)).1 + · exact absurd h (List.not_mem_nil) + · rw [if_neg hj] + have hout : ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 j := + fun hm => hj ((mem_pairTargets_iff k j).mpr hm) + have hwj : work j = enumBank k x N H v a r j := hframe j hout + have hne : j ≠ y1Idx k := fun h => hj (by rw [h]; simp) + rw [afterPair, Function.update_of_ne hne, ← hwj, TM.parkTape] + refine Tape.ext ?_ rfl + show max (work j).head 1 = (work j).head + rw [hwj, enumBank_head] + omega + · rw [hpo, ho, TM.parkTape] + refine Tape.ext ?_ rfl + show max TM.blankTape.head 1 = TM.blankTape.head + rfl + +/-- **Every tape of the scratch block rests blank**: the emitter's target, the matrix machine's +own tapes, the tape it reads and the one it writes. -/ +theorem enumBank_blank_of_val (k : ℕ) (x : List Bool) (N H v a r : ℕ) + (i : Fin (enumTapes k)) (h2 : 2 ≤ i.val) (hlt : i.val < 3 + k + 2) : + enumBank k x N H v a r i = TM.blankTape := + enumBank_blank k x N H v a r i + (Fin.ne_of_val_ne (by show i.val ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show i.val ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show i.val ≠ 3 + k + 8; omega)) + (Fin.ne_of_val_ne (by show i.val ≠ 0; omega)) + (Fin.ne_of_val_ne (by show i.val ≠ 1; omega)) + (Fin.ne_of_val_ne (by show i.val ≠ 3 + k + 3; omega)) + (Fin.ne_of_val_ne (by show i.val ≠ 3 + k + 7; omega)) + +@[simp] theorem enumBank_y (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (yIdx k) = TM.blankTape := + enumBank_blank_of_val k x N H v a r _ (by show 2 ≤ 3 + k; omega) + (by show 3 + k < 3 + k + 2; omega) + +@[simp] theorem enumBank_v (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (vIdx k) = TM.blankTape := + enumBank_blank_of_val k x N H v a r _ (by show 2 ≤ 3 + k + 1; omega) + (by show 3 + k + 1 < 3 + k + 2; omega) + +/-- The tapes after the pair has been moved into the shape the matrix machine reads: the emitter's +target keeps its contents with its head left past them, and the matrix machine's input tape now +holds the pair. -/ +def afterCopy (k : ℕ) (x : List Bool) (N H v a r : ℕ) : Fin (enumTapes k) → Tape := + Function.update + (Function.update (enumBank k x N H v a r) (yIdx k) (strTape (pair x (dropTop (v + 1))))) + (y1Idx k) + (⟨(pair x (dropTop (v + 1))).length + 1, (strTape (pair x (dropTop (v + 1)))).cells⟩ : Tape) + +/-- **The copying stage's contract.** -/ +theorem copyPair_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) : + (copyPairTM k).HoareTime + (fun inp work out => inp = I ∧ work = afterPair k x N H v a r ∧ out = TM.blankTape) + (fun inp work out => inp = I ∧ work = afterCopy k x N H v a r ∧ out = TM.blankTape) + (2 * (pair x (dropTop (v + 1))).length + 5) := by + have hne : y1Idx k ≠ yIdx k := Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 3 + k; omega) + have hsrc : afterPair k x N H v a r (y1Idx k) = strTape (pair x (dropTop (v + 1))) := by + rw [afterPair, Function.update_self] + have hdst : afterPair k x N H v a r (yIdx k) = TM.blankTape := by + rw [afterPair, Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k ≠ 2; omega)), + enumBank_y] + have hpark : ∀ i, TM.Parked (afterPair k x N H v a r i) := by + intro i + rw [afterPair] + by_cases hi : i = y1Idx k + · rw [hi, Function.update_self] + exact strTape_parked _ + · rw [Function.update_of_ne hi] + exact enumBank_parked k x N H v a r i + rintro inp work out ⟨rfl, rfl, rfl⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpo, hpdst, hpsrcCells, hpsrcHead, hpother⟩ := + TM.copyToVirtualInput_hoareTime (y1Idx k) (yIdx k) hne (pair x (dropTop (v + 1))) inp + (afterPair k x N H v a r) TM.blankTape + (by rw [hsrc]; rfl) + (by rw [hsrc]; exact Tape.hasOutput_of_hasBinaryString (strTape_hasBinaryString _)) + (by rw [hsrc]; exact strTape_parked _) + (by rw [hdst]; rfl) + hI TM.blankTape_parked + (fun i _ _ => hpark i) + inp (afterPair k x N H v a r) TM.blankTape ⟨rfl, rfl, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, hpi, ?_, hpo⟩ + funext j + by_cases hj : j = y1Idx k + · rw [hj, afterCopy, Function.update_self] + refine Tape.ext ?_ ?_ + · rw [hpsrcHead] + · rw [hpsrcCells, hsrc] + · by_cases hj' : j = yIdx k + · rw [hj', hpdst, afterCopy, Function.update_of_ne hne.symm, Function.update_self] + rfl + · rw [hpother j hj hj', afterCopy, Function.update_of_ne hj, Function.update_of_ne hj', + afterPair, Function.update_of_ne hj] + +/-- **The layout and the placement agree.** The tapes the copy stage leaves behind are exactly +the ones the placed matrix machine expects to be entered with: its own scratch blank, the pair on +the tape it reads, the verdict tape blank, and the enumerator's registers on either side. -/ +theorem matrixEntry_afterCopy (M : TM k) (x : List Bool) (N H v a r : ℕ) (I : Tape) : + matrixEntry M (afterCopy k x N H v a r) (pair x (dropTop (v + 1))) I + = afterCopy k x N H v a r := by + funext i + rw [matrixEntry] + by_cases hi : TM.placeWorkInMiddle 3 (k + 2) i + · rw [dif_pos hi] + set j := TM.placeWorkCoord 3 (k + 2) i hi with hjdef + have hival : i.val = 3 + j.val := by + rw [hjdef] + show i.val = 3 + (i.val - 3) + have := hi.1 + omega + refine Fin.lastCases (motive := fun j' => ∀ (hj : j = j'), + TM.applyPre M (pair x (dropTop (v + 1))) I j' = afterCopy k x N H v a r i) ?_ ?_ j rfl + · intro hj + have hi' : i = vIdx k := by + apply Fin.ext + rw [hival, hj] + show 3 + (k + 1) = 3 + k + 1 + omega + rw [TM.applyPre, Fin.snoc_last, hi', afterCopy, + Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 1 ≠ 2; omega)), + Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 1 ≠ 3 + k; omega)), enumBank_v] + rfl + · intro j' hj + by_cases hjk : j'.val < k + · have hi' : (2 : ℕ) ≤ i.val ∧ i.val < 3 + k + 2 := by + rw [hival, hj] + show 2 ≤ 3 + j'.val ∧ 3 + j'.val < 3 + k + 2 + omega + rw [TM.applyPre, Fin.snoc_castSucc] + show (if j'.val < k then (Tape.init ([] : List Γ)).move Dir3.right + else (Tape.init ((pair x (dropTop (v + 1))).map Γ.ofBool)).move Dir3.right) = _ + rw [if_pos hjk, afterCopy, + Function.update_of_ne (Fin.ne_of_val_ne (by rw [hival, hj]; show 3 + j'.val ≠ 2; omega)), + Function.update_of_ne + (Fin.ne_of_val_ne (by rw [hival, hj]; show 3 + j'.val ≠ 3 + k; omega)), + enumBank_blank_of_val k x N H v a r i hi'.1 hi'.2] + rfl + · have hjk' : j'.val = k := by + have := j'.isLt + omega + have hi' : i = yIdx k := by + apply Fin.ext + rw [hival, hj] + show 3 + j'.val = 3 + k + omega + rw [TM.applyPre, Fin.snoc_castSucc] + show (if j'.val < k then (Tape.init ([] : List Γ)).move Dir3.right + else (Tape.init ((pair x (dropTop (v + 1))).map Γ.ofBool)).move Dir3.right) = _ + rw [if_neg hjk, hi', afterCopy, + Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k ≠ 2; omega)), + Function.update_self] + rfl + · rw [dif_neg hi] + +theorem afterCopy_startInvariant (k : ℕ) (x : List Bool) (N H v a r : ℕ) + (i : Fin (enumTapes k)) : Tape.StartInvariant (afterCopy k x N H v a r i) := by + rw [afterCopy] + by_cases h1 : i = y1Idx k + · rw [h1, Function.update_self] + exact ⟨(strTape_startInvariant (pair x (dropTop (v + 1)))).1, + fun j hj => (strTape_startInvariant (pair x (dropTop (v + 1)))).2 j hj⟩ + · rw [Function.update_of_ne h1] + by_cases h2 : i = yIdx k + · rw [h2, Function.update_self] + exact strTape_startInvariant _ + · rw [Function.update_of_ne h2] + exact enumBank_startInvariant k x N H v a r i + +theorem afterCopy_head_pos (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) : + 1 ≤ (afterCopy k x N H v a r i).head := by + rw [afterCopy] + by_cases h1 : i = y1Idx k + · rw [h1, Function.update_self] + show 1 ≤ (pair x (dropTop (v + 1))).length + 1 + omega + · rw [Function.update_of_ne h1] + by_cases h2 : i = yIdx k + · rw [h2, Function.update_self] + exact le_of_eq rfl + · rw [Function.update_of_ne h2] + exact (enumBank_parked k x N H v a r i).1 + +/-- **The evaluating stage's contract, in the enumerator's own terms.** -/ +theorem matrix_hoareTime (M : TM k) {L : Language} {T S : ℕ → ℕ} (hdec : M.DecidesInTime L T) + (hdecS : M.DecidesInSpace L S) + (x : List Bool) (N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) (hISI : Tape.StartInvariant I) + (Hb : ℕ) (hHS : (pair x (dropTop (v + 1))).length + + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) : + (matrixTM M).HoareTime + (fun inp work out => inp = I ∧ work = afterCopy k x N H v a r ∧ out = TM.blankTape) + (fun inp work out => inp = I ∧ out = TM.blankTape ∧ + (pair x (dropTop (v + 1)) ∈ L → (work (vIdx k)).cells 1 = Γ.one) ∧ + (pair x (dropTop (v + 1)) ∉ L → (work (vIdx k)).cells 1 = Γ.zero) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → work i = afterCopy k x N H v a r i) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + Tape.StartInvariant (work i) ∧ (work i).head ≤ Hb ∧ + ∀ j, Hb < j → (work i).cells j = Γ.blank)) + (T (pair x (dropTop (v + 1))).length) := by + have h := matrixTM_hoareTime M hdec hdecS (pair x (dropTop (v + 1))) I hI hISI + (afterCopy k x N H v a r) + (fun i _ => afterCopy_startInvariant k x N H v a r i) + (fun i _ => afterCopy_head_pos k x N H v a r i) Hb hHS + rw [matrixEntry_afterCopy] at h + exact h + +/-- What the matrix machine leaves behind: its verdict on the verdict tape, the enumerator's own +tapes untouched, and its block dirty but bounded. -/ +def midMatrix (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) : + TM.TapePred (enumTapes k) := fun inp work out => + inp = I ∧ out = TM.blankTape ∧ + ((work (vIdx k)).cells 1 = Γ.one ↔ b = true) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → work i = afterCopy k x N H v a r i) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + Tape.StartInvariant (work i) ∧ (work i).head ≤ Hb ∧ + ∀ j, Hb < j → (work i).cells j = Γ.blank) + +/-- The evaluating stage, with its verdict read as a Boolean. -/ +theorem matrix_hoareTime_bool (M : TM k) {L : Language} {T S : ℕ → ℕ} + (hdec : M.DecidesInTime L T) (hdecS : M.DecidesInSpace L S) + (x : List Bool) (N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) (hISI : Tape.StartInvariant I) + (Hb : ℕ) (hHS : (pair x (dropTop (v + 1))).length + + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) (b : Bool) + (hb : b = true ↔ pair x (dropTop (v + 1)) ∈ L) : + (matrixTM M).HoareTime + (fun inp work out => inp = I ∧ work = afterCopy k x N H v a r ∧ out = TM.blankTape) + (midMatrix k x N H v a r I Hb b) + (T (pair x (dropTop (v + 1))).length) := by + refine (matrix_hoareTime M hdec hdecS x N H v a r I hI hISI Hb hHS).strengthen_post ?_ + rintro inp work out ⟨hi, ho, hone, hzero, hframe, hblock⟩ + refine ⟨hi, ho, ?_, hframe, hblock⟩ + by_cases hmem : pair x (dropTop (v + 1)) ∈ L + · rw [hone hmem] + simp [hb.mpr hmem] + · rw [hzero hmem] + constructor + · intro hcon + exact absurd hcon (by decide) + · intro hcon + exact absurd (hb.mp hcon) hmem + +/-- The verdict tape rewound: the pass can read the bit it published. -/ +def midParked (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) : + TM.TapePred (enumTapes k) := fun inp work out => + inp = I ∧ out = TM.blankTape ∧ + ((work (vIdx k)).read = Γ.one ↔ b = true) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → work i = afterCopy k x N H v a r i) ∧ + (∀ i, TM.Parked (work i)) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + Tape.StartInvariant (work i) ∧ (work i).head ≤ Hb + 1 ∧ + ∀ j, Hb < j → (work i).cells j = Γ.blank) + +/-- **Rewinding the verdict tape.** The matrix machine halts wherever it likes; the bit it wrote +is at cell one, so the head has to go back there before the pass can publish it. -/ +theorem parkVerdict_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hISI : Tape.StartInvariant I) (hIhead : I.head = 1) (Hb : ℕ) (hHb : 1 ≤ Hb) (b : Bool) : + (TM.parkRewindTM [vIdx k]).HoareTime + (midMatrix k x N H v a r I Hb b) + (midParked k x N H v a r I Hb b) + (1 + 1 + (2 * (max (Hb + 2) (1 * (Hb + 3) + 1) + 1) + 1)) := by + rintro inp work out ⟨hi, ho, hverdict, hframe, hblock⟩ + have hSI : ∀ i, Tape.StartInvariant (work i) := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · exact (hblock i hm).1 + · rw [hframe i hm] + exact afterCopy_startInvariant k x N H v a r i + have hmid : TM.placeWorkInMiddle 3 (k + 2) (vIdx k) := vIdx_inMiddle k + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpw, hpo⟩ := + TM.parkRewindTM_hoareTime [vIdx k] (List.nodup_singleton _) Hb hHb inp work out + (by rw [hi]; exact hISI) hSI (by rw [ho]; exact TM.blankTape_startInvariant) + (by rw [hi, hIhead]; exact hHb) + (fun j hj => by + rw [List.mem_singleton.mp hj] + exact (hblock (vIdx k) hmid).2.1) + inp work out ⟨rfl, rfl, rfl⟩ + have hvw : c'.work (vIdx k) = (⟨1, (work (vIdx k)).cells⟩ : Tape) := by + rw [hpw] + show (if vIdx k ∈ [vIdx k] then (⟨1, (work (vIdx k)).cells⟩ : Tape) else _) = _ + rw [if_pos (List.mem_singleton.mpr rfl)] + have hother : ∀ j, j ≠ vIdx k → c'.work j = TM.parkTape (work j) := by + intro j hj + rw [hpw] + show (if j ∈ [vIdx k] then _ else TM.parkTape (work j)) = _ + rw [if_neg (fun hmem => hj (List.mem_singleton.mp hmem))] + refine ⟨c', t, ht, hreach, hhalt, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hpi, hi] + exact Tape.ext hIhead.symm rfl + · rw [hpo, ho, TM.parkTape] + exact Tape.ext rfl rfl + · rw [hvw] + show (work (vIdx k)).cells 1 = Γ.one ↔ b = true + exact hverdict + · intro i hm + have hne : i ≠ vIdx k := fun h => hm (h ▸ hmid) + rw [hother i hne, hframe i hm, TM.parkTape] + refine Tape.ext ?_ rfl + show max (afterCopy k x N H v a r i).head 1 = (afterCopy k x N H v a r i).head + have := afterCopy_head_pos k x N H v a r i + omega + · intro i + by_cases hi' : i = vIdx k + · rw [hi', hvw] + exact ⟨le_of_eq rfl, fun j hj => (hSI (vIdx k)).2 j hj⟩ + · rw [hother i hi'] + exact TM.parkTape_parked (hSI i) + · intro i hm + by_cases hi' : i = vIdx k + · rw [hi', hvw] + refine ⟨⟨(hSI (vIdx k)).1, fun j hj => (hSI (vIdx k)).2 j hj⟩, ?_, ?_⟩ + · show (1 : ℕ) ≤ Hb + 1 + omega + · rw [hi'] at hm + exact (hblock (vIdx k) hm).2.2 + · rw [hother i hi', TM.parkTape] + refine ⟨⟨(hSI i).1, fun j hj => (hSI i).2 j hj⟩, ?_, (hblock i hm).2.2⟩ + show max (work i).head 1 ≤ Hb + 1 + have := (hblock i hm).2.1 + omega + +/-- Reading a cell back as a writable symbol turns it into `1` exactly when it was `1`. -/ +theorem readBackWrite_one_iff (s : Γ) : TM.readBackWrite s = Γw.one ↔ s = Γ.one := by + cases s <;> simp [TM.readBackWrite] + +/-- The verdict published into the slot, where the tally bump can branch on it. -/ +def midPublish (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) : + TM.TapePred (enumTapes k) := fun inp work out => + inp = I ∧ (∃ s : Γw, (s = Γw.one ↔ b = true) ∧ out = NTM.outSlot s) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → work i = afterCopy k x N H v a r i) ∧ + (∀ i, TM.Parked (work i)) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + Tape.StartInvariant (work i) ∧ (work i).head ≤ Hb + 1 ∧ + ∀ j, Hb < j → (work i).cells j = Γ.blank) + +/-- **Publishing the verdict.** The bit under the verdict tape's head is copied into the output +slot, which is the only channel between a work tape and the real output. -/ +theorem publishVerdict_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (Hb : ℕ) (b : Bool) : + (TM.writeOutputBitTM (vIdx k)).HoareTime + (midParked k x N H v a r I Hb b) + (midPublish k x N H v a r I Hb b) + 1 := by + rintro inp work out ⟨hi, ho, hverdict, hframe, hpark, hblock⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpw, hpo⟩ := + TM.writeOutputBitTM_hoareTime_frame (vIdx k) inp work out (by rw [hi]; exact hI) hpark + (by rw [ho]; exact TM.blankTape_parked) inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, by rw [hpi, hi], ?_, ?_, ?_, ?_⟩ + · refine ⟨TM.readBackWrite ((work (vIdx k)).read), ?_, ?_⟩ + · rw [readBackWrite_one_iff] + exact hverdict + · rw [hpo, ho, ← NTM.outSlot_blank_eq_blankTape] + exact NTM.outSlot_write Γw.blank _ + · intro i hm + rw [hpw] + exact hframe i hm + · intro i + rw [hpw] + exact hpark i + · intro i hm + rw [hpw] + exact hblock i hm + +@[simp] theorem enumBank_c (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (cIdx k) = natTape v := by + rw [enumBank, tallyWork] + dsimp only + rw [if_pos rfl] + +@[simp] theorem enumBank_a (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (aIdx k) = natTape a := by + rw [enumBank, tallyWork] + dsimp only + rw [if_neg (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 2; omega)), if_pos rfl] + +@[simp] theorem enumBank_r (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (rIdx k) = natTape r := by + rw [enumBank, tallyWork] + dsimp only + rw [if_neg (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 2; omega)), + if_neg (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 5; omega)), if_pos rfl] + +theorem afterCopy_of_ne (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) + (h1 : i ≠ y1Idx k) (h2 : i ≠ yIdx k) : + afterCopy k x N H v a r i = enumBank k x N H v a r i := by + rw [afterCopy, Function.update_of_ne h1, Function.update_of_ne h2] + +/-- A tape outside the matrix machine's block is neither of the two the copy stage disturbed. -/ +theorem afterCopy_outside (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) + (hm : ¬ TM.placeWorkInMiddle 3 (k + 2) i) (h1 : i ≠ y1Idx k) : + afterCopy k x N H v a r i = enumBank k x N H v a r i := + afterCopy_of_ne k x N H v a r i h1 (fun h => hm (h ▸ yIdx_inMiddle k)) + +/-- What the tally bump leaves: the counter advanced, one tally bumped, and the slot blank +again. -/ +def midBump (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) : + TM.TapePred (enumTapes k) := fun inp work out => + inp = I ∧ out = TM.blankTape ∧ + work (cIdx k) = natTape (v + 1) ∧ + work (aIdx k) = natTape (a + if b then 1 else 0) ∧ + work (rIdx k) = natTape (r + if b then 0 else 1) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → i ≠ cIdx k → i ≠ aIdx k → i ≠ rIdx k → + work i = afterCopy k x N H v a r i) ∧ + (∀ i, TM.Parked (work i)) ∧ (∀ i, (work i).cells 0 = Γ.start) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + (work i).head ≤ Hb + 1 ∧ ∀ j, Hb < j → (work i).cells j = Γ.blank) + +/-- **The tally bump.** The slot the previous stage published names which tally to advance; the +counter advances with it, and the slot is blanked so that the wipe can run. -/ +theorem tallyBump_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) (Hb : ℕ) (b : Bool) : + (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)).HoareTime + (midPublish k x N H v a r I Hb b) + (midBump k x N H v a r I Hb b) + (3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1) := by + rintro inp work out ⟨hi, ⟨s, hs, ho⟩, hframe, hpark, hblock⟩ + have hzero : ∀ i, (work i).cells 0 = Γ.start := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · exact (hblock i hm).1.1 + · rw [hframe i hm] + exact (afterCopy_startInvariant k x N H v a r i).1 + have hy1 : y1Idx k ≠ cIdx k ∧ y1Idx k ≠ aIdx k ∧ y1Idx k ≠ rIdx k := y1_ne_regs k + have hcout : ¬ TM.placeWorkInMiddle 3 (k + 2) (cIdx k) := + fun hm => absurd (show (3 + k + 2 : ℕ) < 3 + (k + 2) from hm.2) (by omega) + have haout : ¬ TM.placeWorkInMiddle 3 (k + 2) (aIdx k) := + fun hm => absurd (show (3 + k + 5 : ℕ) < 3 + (k + 2) from hm.2) (by omega) + have hrout : ¬ TM.placeWorkInMiddle 3 (k + 2) (rIdx k) := + fun hm => absurd (show (3 + k + 8 : ℕ) < 3 + (k + 2) from hm.2) (by omega) + have hc : work (cIdx k) = natTape v := by + rw [hframe (cIdx k) hcout, + afterCopy_outside k x N H v a r _ hcout (fun h => hy1.1 h.symm), enumBank_c] + have ha : work (aIdx k) = natTape a := by + rw [hframe (aIdx k) haout, + afterCopy_outside k x N H v a r _ haout (fun h => hy1.2.1 h.symm), enumBank_a] + have hr : work (rIdx k) = natTape r := by + rw [hframe (rIdx k) hrout, + afterCopy_outside k x N H v a r _ hrout (fun h => hy1.2.2 h.symm), enumBank_r] + have hzblank : (work (zIdx k)).read = Γ.blank := by + have hzout : ¬ TM.placeWorkInMiddle 3 (k + 2) (zIdx k) := + fun hm => absurd (show (3 + k + 6 : ℕ) < 3 + (k + 2) from hm.2) (by omega) + rw [hframe (zIdx k) hzout, + afterCopy_outside k x N H v a r _ hzout + (fun h => absurd (show (3 + k + 6 : ℕ) = 2 from congrArg Fin.val h) (by omega)), + enumBank_blank k x N H v a r _ (z_ne_regs k).1 (z_ne_regs k).2.1 (z_ne_regs k).2.2 + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 0; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 1; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 3; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 7; omega))] + exact Tape.init_nil_move_right_read + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpw, hpo⟩ := + TM.tallyBumpTM_hoareTime (cIdx k) (aIdx k) (rIdx k) (zIdx k) + (Fin.ne_of_val_ne (by show 3 + k + 2 ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 2 ≠ 3 + k + 8; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 8; omega)) + v a r b s hs inp work (by rw [hi]; exact hI) (by rw [hi]; exact hIz) hpark hzero + hc ha hr hzblank inp work out ⟨rfl, rfl, ho⟩ + have hupd : ∀ i, i ≠ cIdx k → i ≠ aIdx k → i ≠ rIdx k → c'.work i = work i := by + intro i h1 h2 h3 + rw [hpw, Function.update_of_ne h1] + split + · rw [Function.update_of_ne h2] + · rw [Function.update_of_ne h3] + refine ⟨c', t, ht, hreach, hhalt, by rw [hpi, hi], ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hpo, ← NTM.outSlot_blank_eq_blankTape] + · rw [hpw, Function.update_self] + · rw [hpw, Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 2; omega))] + by_cases hb : b + · rw [if_pos hb, Function.update_self, if_pos hb] + · rw [if_neg hb, Function.update_of_ne + (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 8; omega)), ha, if_neg hb] + rfl + · rw [hpw, Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 2; omega))] + by_cases hb : b + · rw [if_pos hb, Function.update_of_ne + (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 5; omega)), hr, if_pos hb] + rfl + · rw [if_neg hb, Function.update_self, if_neg hb] + · intro i hm h1 h2 h3 + rw [hupd i h1 h2 h3] + exact hframe i hm + · intro i + by_cases h1 : i = cIdx k + · rw [h1, hpw, Function.update_self] + exact natTape_parked _ + · by_cases h2 : i = aIdx k + · rw [h2, hpw, Function.update_of_ne + (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 2; omega))] + split + · rw [Function.update_self] + exact natTape_parked _ + · rw [Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 8; omega))] + exact hpark _ + · by_cases h3 : i = rIdx k + · rw [h3, hpw, Function.update_of_ne + (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 2; omega))] + split + · rw [Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 5; omega))] + exact hpark _ + · rw [Function.update_self] + exact natTape_parked _ + · rw [hupd i h1 h2 h3] + exact hpark i + · intro i + by_cases h1 : i = cIdx k + · rw [h1, hpw, Function.update_self] + exact NTM.natTape_cells_zero _ + · by_cases h2 : i = aIdx k + · rw [h2, hpw, Function.update_of_ne + (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 2; omega))] + split + · rw [Function.update_self] + exact NTM.natTape_cells_zero _ + · rw [Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 8; omega))] + exact hzero _ + · by_cases h3 : i = rIdx k + · rw [h3, hpw, Function.update_of_ne + (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 2; omega))] + split + · rw [Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 3 + k + 5; omega))] + exact hzero _ + · rw [Function.update_self] + exact NTM.natTape_cells_zero _ + · rw [hupd i h1 h2 h3] + exact hzero i + · intro i hm + have h1 : i ≠ cIdx k := fun h => hcout (h ▸ hm) + have h2 : i ≠ aIdx k := fun h => haout (h ▸ hm) + have h3 : i ≠ rIdx k := fun h => hrout (h ▸ hm) + rw [hupd i h1 h2 h3] + exact ⟨(hblock i hm).2.1, (hblock i hm).2.2⟩ + +/-- The witness advanced in step with the counter. -/ +def midBumped (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) : + TM.TapePred (enumTapes k) := fun inp work out => + inp = I ∧ out = TM.blankTape ∧ + work (cIdx k) = natTape (v + 1) ∧ + work (aIdx k) = natTape (a + if b then 1 else 0) ∧ + work (rIdx k) = natTape (r + if b then 0 else 1) ∧ + work (wIdx k) = strTape (dropTop (v + 1 + 1)) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → i ≠ cIdx k → i ≠ aIdx k → i ≠ rIdx k → + i ≠ wIdx k → work i = afterCopy k x N H v a r i) ∧ + (∀ i, TM.Parked (work i)) ∧ (∀ i, (work i).cells 0 = Γ.start) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + (work i).head ≤ Hb + 1 ∧ ∀ j, Hb < j → (work i).cells j = Γ.blank) + +/-- **Advancing the witness.** The counter has just moved on, and `TM.binaryBumpTM` moves the +witness with it: `PolyExists.dropTop_succ` says the string the next count denotes is exactly the +zero-extending increment of this one. -/ +theorem witnessBump_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (Hb : ℕ) (b : Bool) : + (TM.binaryBumpTM (wIdx k)).HoareTime + (midBump k x N H v a r I Hb b) + (midBumped k x N H v a r I Hb b) + (TM.binaryBumpTime (dropTop (v + 1))) := by + rintro inp work out ⟨hi, ho, hc, ha, hr, hframe, hpark, hzero, hblock⟩ + have hwout : ¬ TM.placeWorkInMiddle 3 (k + 2) (wIdx k) := + fun hm => absurd (show (3 : ℕ) ≤ 1 from hm.1) (by omega) + have hw : work (wIdx k) = strTape (dropTop (v + 1)) := by + rw [hframe (wIdx k) hwout + (Fin.ne_of_val_ne (by show (1 : ℕ) ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show (1 : ℕ) ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show (1 : ℕ) ≠ 3 + k + 8; omega)), + afterCopy_outside k x N H v a r _ hwout + (Fin.ne_of_val_ne (by show (1 : ℕ) ≠ 2; omega)), enumBank_w] + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpother, hpbits, hpcell0, hpo⟩ := + TM.binaryBumpTM_hoareTime_frame (wIdx k) (dropTop (v + 1)) inp work out + (by rw [hw]; exact strTape_hasBinaryString _) + (by rw [hw]; exact strTape_cells_zero _) + (by rw [hi]; exact hI.2 _ hI.1) + (fun i _ => (hpark i).2 _ (hpark i).1) + (by rw [ho]; exact TM.blankTape_parked.2 _ TM.blankTape_parked.1) + inp work out ⟨rfl, rfl, rfl⟩ + have hwnew : c'.work (wIdx k) = strTape (dropTop (v + 1 + 1)) := by + have hbits : (c'.work (wIdx k)).HasBinaryString (dropTop (v + 1 + 1)) := by + have heq : BinaryBump.bump (dropTop (v + 1)) = dropTop (v + 1 + 1) := by + rw [bump_eq_bumpLE, ← dropTop_succ (by omega)] + rw [← heq] + exact hpbits + exact Tape.eq_init_move_right_of_hasBinaryString hbits hpcell0 + refine ⟨c', t, ht, hreach, hhalt, by rw [hpi, hi], by rw [hpo, ho], ?_, ?_, ?_, hwnew, ?_, ?_, + ?_, ?_⟩ + · rw [hpother (cIdx k) (Fin.ne_of_val_ne (by show 3 + k + 2 ≠ 1; omega))] + exact hc + · rw [hpother (aIdx k) (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 1; omega))] + exact ha + · rw [hpother (rIdx k) (Fin.ne_of_val_ne (by show 3 + k + 8 ≠ 1; omega))] + exact hr + · intro i hm h1 h2 h3 h4 + rw [hpother i h4] + exact hframe i hm h1 h2 h3 + · intro i + by_cases hiw : i = wIdx k + · rw [hiw, hwnew] + exact strTape_parked _ + · rw [hpother i hiw] + exact hpark i + · intro i + by_cases hiw : i = wIdx k + · rw [hiw, hwnew] + exact strTape_cells_zero _ + · rw [hpother i hiw] + exact hzero i + · intro i hm + have hiw : i ≠ wIdx k := fun h => hwout (h ▸ hm) + rw [hpother i hiw] + exact hblock i hm + +/-- The resting bank depends on the count only through the witness. -/ +theorem enumRest_eq_of_ne_w (k : ℕ) (x : List Bool) (N H v v' : ℕ) (i : Fin (enumTapes k)) + (hw : i ≠ wIdx k) : enumRest k x N H v i = enumRest k x N H v' i := by + rw [enumRest, enumRest] + by_cases hx : i = xIdx k + · rw [if_pos hx, if_pos hx] + · rw [if_neg hx, if_neg hx, if_neg hw, if_neg hw] + +/-- **The wipe, and the bridge back to the loop invariant.** Blanking everything the pass dirtied +turns the bank into the one the loop's state names at the next count. -/ +theorem wipe_hoareTime (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hISI : Tape.StartInvariant I) (Hb : ℕ) (b : Bool) + (hHb : Hb + 1 ≤ H) (hpairH : (pair x (dropTop (v + 1))).length + 1 ≤ H) : + (TM.wipeRewindTM (scratchTargets k) (regIdx k)).HoareTime + (midBumped k x N H v a r I Hb b) + (fun inp work out => inp = I ∧ + work = enumBank k x N H (v + 1) (a + if b then 1 else 0) (r + if b then 0 else 1) ∧ + out = TM.blankTape) + ((scratchTargets k).length * (H + 4) + H * 4 + 8 + 1 + + ((scratchTargets k).length * (H + 4) + 1)) := by + rintro inp work out ⟨hi, ho, hc, ha, hr, hw, hframe, hpark, hzero, hblock⟩ + have hregout : ¬ TM.placeWorkInMiddle 3 (k + 2) (regIdx k) := + fun hm => absurd (show (3 + k + 7 : ℕ) < 3 + (k + 2) from hm.2) (by omega) + have hregmem : regIdx k ∉ scratchTargets k := (not_mem_scratchTargets k).2.2.2.2.2.2.2.1 + have hreg : work (regIdx k) = TM.regTape H := by + rw [hframe (regIdx k) hregout + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 8; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 1; omega)), + afterCopy_outside k x N H v a r _ hregout + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 2; omega)), + enumBank_of_ne k x N H v a r _ + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 8; omega)), enumRest, if_neg + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 0; omega)), if_neg + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 1; omega)), if_neg + (Fin.ne_of_val_ne (by show 3 + k + 7 ≠ 3 + k + 3; omega)), if_pos rfl] + have hy1 : work (y1Idx k) = + (⟨(pair x (dropTop (v + 1))).length + 1, (strTape (pair x (dropTop (v + 1)))).cells⟩ : + Tape) := by + have hy1out : ¬ TM.placeWorkInMiddle 3 (k + 2) (y1Idx k) := + fun hm => absurd (show (3 : ℕ) ≤ 2 from hm.1) (by omega) + rw [hframe (y1Idx k) hy1out (y1_ne_regs k).1 (y1_ne_regs k).2.1 (y1_ne_regs k).2.2 + (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 1; omega)), afterCopy, Function.update_self] + obtain ⟨c', t, ht, hreach, hhalt, hpi, hpw, hpo⟩ := + TM.wipeRewindTM_hoareTime (scratchTargets k) (scratchTargets_nodup k) (regIdx k) hregmem H + inp work out (by rw [hi]; exact hISI) (by rw [hi]; exact hI) ho + (fun j _ => ⟨hzero j, fun i hi' => (hpark j).2 i hi'⟩) + (fun j hj => by + by_cases hjy : j = y1Idx k + · rw [hjy, hy1] + show (pair x (dropTop (v + 1))).length + 1 ≤ H + omega + · have hjm : TM.placeWorkInMiddle 3 (k + 2) j := by + have hv := scratchTargets_val k j hj + refine ⟨?_, by omega⟩ + rcases Nat.lt_or_ge j.val 3 with h | h + · exact absurd (Fin.ext (show j.val = 2 by omega)) hjy + · exact h + have := (hblock j hjm).1 + omega) + (fun j hj i hi' => by + by_cases hjy : j = y1Idx k + · rw [hjy, hy1] + show (strTape (pair x (dropTop (v + 1)))).cells i = Γ.blank + obtain ⟨m, rfl⟩ : ∃ m, i = m + 1 := ⟨i - 1, by omega⟩ + exact (strTape_hasBinaryString (pair x (dropTop (v + 1)))).2.2 m (by omega) + · have hjm : TM.placeWorkInMiddle 3 (k + 2) j := by + have hv := scratchTargets_val k j hj + refine ⟨?_, by omega⟩ + rcases Nat.lt_or_ge j.val 3 with h | h + · exact absurd (Fin.ext (show j.val = 2 by omega)) hjy + · exact h + exact (hblock j hjm).2 i (by omega)) + hreg (fun j _ hj => hpark j) + inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, by rw [hpi, hi], ?_, by rw [hpo, ho]⟩ + rw [hpw] + funext j + by_cases hj : j ∈ scratchTargets k + · rw [if_pos hj] + have hv := scratchTargets_val k j hj + exact (enumBank_blank_of_val k x N H (v + 1) (a + if b then 1 else 0) + (r + if b then 0 else 1) j hv.1 hv.2).symm + · rw [if_neg hj] + by_cases h1 : j = cIdx k + · rw [h1, hc, enumBank_c] + · by_cases h2 : j = aIdx k + · rw [h2, ha, enumBank_a] + · by_cases h3 : j = rIdx k + · rw [h3, hr, enumBank_r] + · by_cases h4 : j = wIdx k + · rw [h4, hw, enumBank_w] + · have hjm : ¬ TM.placeWorkInMiddle 3 (k + 2) j := by + intro hm + refine hj ?_ + rw [scratchTargets] + refine List.mem_cons.mpr (Or.inr (List.mem_append.mpr ?_)) + rcases Nat.lt_or_ge j.val (3 + k) with h | h + · exact Or.inl ((mem_matrixTapes_iff k j).mpr ⟨hm.1, h⟩) + · rcases Nat.lt_or_ge j.val (3 + k + 1) with h' | h' + · exact Or.inr (List.mem_cons.mpr (Or.inl (Fin.ext + (show j.val = 3 + k by omega)))) + · exact Or.inr (List.mem_cons.mpr (Or.inr (List.mem_cons.mpr + (Or.inl (Fin.ext (show j.val = 3 + k + 1 by + have := show j.val < 3 + (k + 2) from hm.2 + omega)))))) + rw [hframe j hjm h1 h2 h3 h4, afterCopy_outside k x N H v a r j hjm + (fun h => hj (by rw [h, scratchTargets]; exact List.mem_cons_self ..)), + enumBank_of_ne k x N H v a r j h1 h2 h3, + enumBank_of_ne k x N H (v + 1) _ _ j h1 h2 h3] + exact enumRest_eq_of_ne_w k x N H (v + 1) (v + 1 + 1) j h4 + +/-! ## Chaining the pass -/ + +/-- A phase boundary parks every tape it crosses. -/ +theorem transitionTape_park {t : Tape} (h : Tape.StartInvariant t) : + TM.transitionTape t = (⟨max t.head 1, t.cells⟩ : Tape) := by + rw [TM.transitionTape, TM.writeAndMove_readBack_of_startInvariant t h, + TM.move_idleDir_eq_of_startInvariant h] + +/-- A phase boundary is the identity on parked tapes. -/ +theorem trans_id_of_parked {inp : Tape} {work : Fin (enumTapes k) → Tape} {out : Tape} + (hi : TM.Parked inp) (hw : ∀ i, TM.Parked (work i)) (ho : TM.Parked out) : + TM.transitionInput inp = inp ∧ (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + ⟨TM.transitionInput_eq_self hi.read_ne_start, + funext fun i => TM.transitionTape_eq_self (hw i).read_ne_start, + TM.transitionTape_eq_self ho.read_ne_start⟩ + +theorem afterPair_parked (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) : + TM.Parked (afterPair k x N H v a r i) := by + rw [afterPair] + by_cases h : i = y1Idx k + · rw [h, Function.update_self] + exact strTape_parked _ + · rw [Function.update_of_ne h] + exact enumBank_parked k x N H v a r i + +theorem afterCopy_parked (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) : + TM.Parked (afterCopy k x N H v a r i) := + ⟨afterCopy_head_pos k x N H v a r i, + fun j hj => (afterCopy_startInvariant k x N H v a r i).2 j hj⟩ + +/-- **The seam after the emitter.** The emitter can leave a head on the marker; the boundary step +moves it off, and everything the next stage needs survives. -/ +theorem midEmit_trans (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) + (B : ℕ) (hB : 1 ≤ B) (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midEmit k x N H v a r I B inp work out) : + midEmit k x N H v a r I B (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨hi, ho, hframe, hxc, hwc, hy1, hSI, hhead⟩ := h + have hpark : ∀ i, TM.transitionTape (work i) = (⟨max (work i).head 1, (work i).cells⟩ : Tape) := + fun i => transitionTape_park (hSI i) + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hi, TM.transitionInput_eq_self hI.read_ne_start] + · rw [ho, TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start] + · intro i hm + show TM.transitionTape (work i) = enumBank k x N H v a r i + rw [hpark i, hframe i hm] + refine Tape.ext ?_ rfl + show max (enumBank k x N H v a r i).head 1 = (enumBank k x N H v a r i).head + rw [enumBank_head] + omega + · show (TM.transitionTape (work (xIdx k))).cells = (strTape x).cells + rw [hpark (xIdx k)] + exact hxc + · show (TM.transitionTape (work (wIdx k))).cells = (strTape (dropTop (v + 1))).cells + rw [hpark (wIdx k)] + exact hwc + · show (TM.transitionTape (work (y1Idx k))).HasBinaryPrefix (pair x (dropTop (v + 1))) + rw [hpark (y1Idx k)] + refine ⟨?_, hy1.2.1, hy1.2.2⟩ + show max (work (y1Idx k)).head 1 = (pair x (dropTop (v + 1))).length + 1 + rw [hy1.1] + omega + · intro i + show Tape.StartInvariant (TM.transitionTape (work i)) + rw [hpark i] + exact ⟨(hSI i).1, fun j hj => (hSI i).2 j hj⟩ + · intro i + show (TM.transitionTape (work i)).head ≤ B + rw [hpark i] + show max (work i).head 1 ≤ B + have := hhead i + omega + +/-- **The seam after the matrix machine.** Same story: the machine may halt with a head on the +marker, and the boundary moves it off. -/ +theorem midMatrix_trans (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) + (Hb : ℕ) (hHb : 1 ≤ Hb) (b : Bool) (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midMatrix k x N H v a r I Hb b inp work out) : + midMatrix k x N H v a r I Hb b (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨hi, ho, hverdict, hframe, hblock⟩ := h + have hSI : ∀ i, Tape.StartInvariant (work i) := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · exact (hblock i hm).1 + · rw [hframe i hm] + exact afterCopy_startInvariant k x N H v a r i + have hpark : ∀ i, TM.transitionTape (work i) = (⟨max (work i).head 1, (work i).cells⟩ : Tape) := + fun i => transitionTape_park (hSI i) + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [hi, TM.transitionInput_eq_self hI.read_ne_start] + · rw [ho, TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start] + · show (TM.transitionTape (work (vIdx k))).cells 1 = Γ.one ↔ b = true + rw [hpark (vIdx k)] + exact hverdict + · intro i hm + show TM.transitionTape (work i) = afterCopy k x N H v a r i + rw [hpark i, hframe i hm] + refine Tape.ext ?_ rfl + show max (afterCopy k x N H v a r i).head 1 = (afterCopy k x N H v a r i).head + have := afterCopy_head_pos k x N H v a r i + omega + · intro i hm + show Tape.StartInvariant (TM.transitionTape (work i)) ∧ + (TM.transitionTape (work i)).head ≤ Hb ∧ + ∀ j, Hb < j → (TM.transitionTape (work i)).cells j = Γ.blank + rw [hpark i] + refine ⟨⟨(hSI i).1, fun j hj => (hSI i).2 j hj⟩, ?_, (hblock i hm).2.2⟩ + show max (work i).head 1 ≤ Hb + have := (hblock i hm).2.1 + omega + +/-- A predicate about parked tapes survives a phase boundary, since the boundary does not move +them. -/ +theorem trans_of_parked_pred {P : TM.TapePred (enumTapes k)} + {inp : Tape} {work : Fin (enumTapes k) → Tape} {out : Tape} + (hi : TM.Parked inp) (hw : ∀ i, TM.Parked (work i)) (ho : TM.Parked out) + (h : P inp work out) : + P (TM.transitionInput inp) (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨h1, h2, h3⟩ := trans_id_of_parked hi hw ho + rw [h1, h2, h3] + exact h + +/-- The pass's running time: its ten stages and the nine boundaries between them. -/ +def bodyTime (k : ℕ) (x : List Bool) (T : ℕ → ℕ) (H Hb B v a r : ℕ) : ℕ := + 1 + 1 + (TM.pairInputWorkTime x (dropTop (v + 1)) + 1 + + ((1 + 1 + (2 * (max (B + 2) (3 * (B + 3) + 1) + 1) + 1)) + 1 + + ((2 * (pair x (dropTop (v + 1))).length + 5) + 1 + + (T (pair x (dropTop (v + 1))).length + 1 + + ((1 + 1 + (2 * (max (Hb + 2) (1 * (Hb + 3) + 1) + 1) + 1)) + 1 + + (1 + 1 + + ((3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1) + 1 + + (TM.binaryBumpTime (dropTop (v + 1)) + 1 + + ((scratchTargets k).length * (H + 4) + H * 4 + 8 + 1 + + ((scratchTargets k).length * (H + 4) + 1)))))))))) + +/-- **One pass of the enumerator, contracted.** From the loop's state at count `v` the pass tests +the witness that count denotes, advances the counter and the witness, bumps the tally the verdict +names, and leaves the loop's state at count `v + 1`. -/ +theorem bodyTM_hoareTime (M : TM k) {L : Language} {T S : ℕ → ℕ} (hdec : M.DecidesInTime L T) + (hdecS : M.DecidesInSpace L S) + (x : List Bool) (N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) (hISI : Tape.StartInvariant I) + (hIhead : I.head = 1) (hIz : I.cells 0 = Γ.start) + (B Hb : ℕ) (hB : 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) (hB1 : 1 ≤ B) + (hHb1 : 1 ≤ Hb) + (hHS : (pair x (dropTop (v + 1))).length + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) + (hHbH : Hb + 1 ≤ H) (hpairH : (pair x (dropTop (v + 1))).length + 1 ≤ H) + (b : Bool) (hb : b = true ↔ pair x (dropTop (v + 1)) ∈ L) : + (bodyTM M).HoareTime + (fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ out = NTM.outSlot s) + (fun inp work out => inp = I ∧ + work = enumBank k x N H (v + 1) (a + if b then 1 else 0) (r + if b then 0 else 1) ∧ + out = TM.blankTape) + (bodyTime k x T H Hb B v a r) := by + have hpinned : ∀ (W : Fin (enumTapes k) → Tape) (O : Tape), (∀ i, TM.Parked (W i)) → + TM.Parked O → ∀ inp work out, (inp = I ∧ work = W ∧ out = O) → + (TM.transitionInput inp = I ∧ (fun i => TM.transitionTape (work i)) = W ∧ + TM.transitionTape out = O) := by + rintro W O hW hO inp work out ⟨rfl, rfl, rfl⟩ + exact trans_id_of_parked hI hW hO + have h10 := wipe_hoareTime k x N H v a r I hI hISI Hb b hHbH hpairH + have h9 := TM.seqTM_hoareTime _ _ (witnessBump_hoareTime k x N H v a r I hI Hb b) + (fun inp work out h => trans_of_parked_pred (by rw [h.1]; exact hI) h.2.2.2.2.2.2.2.1 (by + rw [h.2.1]; exact TM.blankTape_parked) h) h10 + have h8 := TM.seqTM_hoareTime _ _ (tallyBump_hoareTime k x N H v a r I hI hIz Hb b) + (fun inp work out h => trans_of_parked_pred (by rw [h.1]; exact hI) h.2.2.2.2.2.2.1 (by + rw [h.2.1]; exact TM.blankTape_parked) h) h9 + have h7 := TM.seqTM_hoareTime _ _ (publishVerdict_hoareTime k x N H v a r I hI Hb b) + (fun inp work out h => trans_of_parked_pred (by rw [h.1]; exact hI) h.2.2.2.1 (by + obtain ⟨s, -, hs⟩ := h.2.1 + rw [hs] + exact NTM.outSlot_parked s) h) h8 + have h6 := TM.seqTM_hoareTime _ _ + (parkVerdict_hoareTime k x N H v a r I hISI hIhead Hb hHb1 b) + (fun inp work out h => trans_of_parked_pred (by rw [h.1]; exact hI) h.2.2.2.2.1 (by + rw [h.2.1]; exact TM.blankTape_parked) h) h7 + have h5 := TM.seqTM_hoareTime _ _ + (matrix_hoareTime_bool M hdec hdecS x N H v a r I hI hISI Hb hHS b hb) + (fun inp work out h => midMatrix_trans k x N H v a r I hI Hb hHb1 b inp work out h) h6 + have h4 := TM.seqTM_hoareTime _ _ (copyPair_hoareTime k x N H v a r I hI) + (hpinned _ _ (afterCopy_parked k x N H v a r) TM.blankTape_parked) h5 + have h3 := TM.seqTM_hoareTime _ _ + (parkPair_hoareTime k x N H v a r I hISI hIhead B hB1) + (hpinned _ _ (afterPair_parked k x N H v a r) TM.blankTape_parked) h4 + have h2 := TM.seqTM_hoareTime _ _ (emit_hoareTime k x N H v a r I hI hISI B hB) + (fun inp work out h => midEmit_trans k x N H v a r I hI B hB1 inp work out h) h3 + have h1 := TM.seqTM_hoareTime _ _ (blankSlot_hoareTime k x N H v a r I hI) + (hpinned _ _ (enumBank_parked k x N H v a r) TM.blankTape_parked) h2 + exact h1 + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHBodyWindow.lean b/Complexitylib/Classes/Containments/Internal/PHBodyWindow.lean new file mode 100644 index 00000000..6cf0b0ff --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHBodyWindow.lean @@ -0,0 +1,650 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHBody +public import Complexitylib.Classes.Containments.Internal.PHMatrix + +/-! +# One pass of the enumerator, in space + +⚠️ Unreviewed by Bolton + +Nine of the pass's ten stages are short, and their windows come straight from their running +times. The tenth — the matrix machine — is not short at all: it may run for exponentially many +steps, and its window has to come from its space bound instead +(`PolyExists.matrixTM_keepsWindowOn`). Composing the ten is what +`TM.seqTM_keepsWindowOn` is for. + +## Main results + +- `PolyExists.afterCopy_head_le`, `PolyExists.mid*_heads` — how far each intermediate state's + heads can be +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- Every tape the copy stage leaves has its head inside the pair's width. -/ +theorem afterCopy_head_le (k : ℕ) (x : List Bool) (N H v a r G : ℕ) + (hG : (pair x (dropTop (v + 1))).length + 1 ≤ G) (i : Fin (enumTapes k)) : + (afterCopy k x N H v a r i).head ≤ G := by + rw [afterCopy] + by_cases h1 : i = y1Idx k + · rw [h1, Function.update_self] + exact hG + · rw [Function.update_of_ne h1] + by_cases h2 : i = yIdx k + · rw [h2, Function.update_self] + show 1 ≤ G + omega + · rw [Function.update_of_ne h2, enumBank_head] + omega + +/-- Every tape of the loop's own state has its head at cell one. -/ +theorem enumBank_head_le (k : ℕ) (x : List Bool) (N H v a r G : ℕ) (hG : 1 ≤ G) + (i : Fin (enumTapes k)) : (enumBank k x N H v a r i).head ≤ G := by + rw [enumBank_head] + exact hG + +theorem midMatrix_heads (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb G : ℕ) + (b : Bool) (hHb : Hb ≤ G) (hpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midMatrix k x N H v a r I Hb b inp work out) : ∀ i, (work i).head ≤ G := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · have := (h.2.2.2.2 i hm).2.1 + omega + · rw [h.2.2.2.1 i hm] + exact afterCopy_head_le k x N H v a r G hpair i + +theorem midParked_heads (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb G : ℕ) + (b : Bool) (hHb : Hb + 1 ≤ G) (hpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midParked k x N H v a r I Hb b inp work out) : ∀ i, (work i).head ≤ G := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · have := (h.2.2.2.2.2 i hm).2.1 + omega + · rw [h.2.2.2.1 i hm] + exact afterCopy_head_le k x N H v a r G hpair i + +theorem midPublish_heads (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb G : ℕ) + (b : Bool) (hHb : Hb + 1 ≤ G) (hpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midPublish k x N H v a r I Hb b inp work out) : ∀ i, (work i).head ≤ G := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · have := (h.2.2.2.2 i hm).2.1 + omega + · rw [h.2.2.1 i hm] + exact afterCopy_head_le k x N H v a r G hpair i + +theorem midBump_heads (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb G : ℕ) + (b : Bool) (hHb : Hb + 1 ≤ G) (hpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) + (hG1 : 1 ≤ G) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midBump k x N H v a r I Hb b inp work out) : ∀ i, (work i).head ≤ G := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · have := (h.2.2.2.2.2.2.2.2 i hm).1 + omega + · by_cases h1 : i = cIdx k + · rw [h1, h.2.2.1, natTape_head_one] + omega + · by_cases h2 : i = aIdx k + · rw [h2, h.2.2.2.1, natTape_head_one] + omega + · by_cases h3 : i = rIdx k + · rw [h3, h.2.2.2.2.1, natTape_head_one] + omega + · rw [h.2.2.2.2.2.1 i hm h1 h2 h3] + exact afterCopy_head_le k x N H v a r G hpair i + +theorem midBumped_heads (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb G : ℕ) + (b : Bool) (hHb : Hb + 1 ≤ G) (hpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) + (hG1 : 1 ≤ G) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midBumped k x N H v a r I Hb b inp work out) : ∀ i, (work i).head ≤ G := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · have := (h.2.2.2.2.2.2.2.2.2 i hm).1 + omega + · by_cases h1 : i = cIdx k + · rw [h1, h.2.2.1, natTape_head_one] + omega + · by_cases h2 : i = aIdx k + · rw [h2, h.2.2.2.1, natTape_head_one] + omega + · by_cases h3 : i = rIdx k + · rw [h3, h.2.2.2.2.1, natTape_head_one] + omega + · by_cases h4 : i = wIdx k + · rw [h4, h.2.2.2.2.2.1] + show 1 ≤ G + omega + · rw [h.2.2.2.2.2.2.1 i hm h1 h2 h3 h4] + exact afterCopy_head_le k x N H v a r G hpair i + +/-- The wipe's window. -/ +theorem wipe_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) + (Hb G : ℕ) (b : Bool) (hHbH : Hb + 1 ≤ H) + (hpairH : (pair x (dropTop (v + 1))).length + 1 ≤ H) + (hG1 : 1 ≤ G) (hGHb : Hb + 1 ≤ G) + (hGpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) : + (TM.wipeRewindTM (scratchTargets k) (regIdx k)).KeepsWindowOn + (fun c => c.state = (TM.wipeRewindTM (scratchTargets k) (regIdx k)).qstart ∧ + midBumped k x N H v a r I Hb b c.input c.work c.output) x.length + (G + ((scratchTargets k).length * (H + 4) + H * 4 + 8 + 1 + + ((scratchTargets k).length * (H + 4) + 1))) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) + (wipe_hoareTime k x N H v a r I hI hIsi Hb b hHbH hpairH) + (fun inp work out hpre i => midBumped_heads k x N H v a r I Hb G b hGHb hGpair hG1 + inp work out hpre i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.1] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The witness bump's window. -/ +theorem witnessBump_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIhead : I.head = 1) (Hb G : ℕ) (b : Bool) + (hG1 : 1 ≤ G) (hGHb : Hb + 1 ≤ G) + (hGpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) : + (TM.binaryBumpTM (wIdx k)).KeepsWindowOn + (fun c => c.state = (TM.binaryBumpTM (wIdx k)).qstart ∧ + midBump k x N H v a r I Hb b c.input c.work c.output) x.length + (G + TM.binaryBumpTime (dropTop (v + 1))) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) + (witnessBump_hoareTime k x N H v a r I hI Hb b) + (fun inp work out hpre i => midBump_heads k x N H v a r I Hb G b hGHb hGpair hG1 + inp work out hpre i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.1] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The tally bump's window. -/ +theorem tallyBump_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) (hIhead : I.head = 1) (Hb G : ℕ) (b : Bool) + (hG1 : 1 ≤ G) (hGHb : Hb + 1 ≤ G) + (hGpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) : + (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)).KeepsWindowOn + (fun c => c.state = (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)).qstart ∧ + midPublish k x N H v a r I Hb b c.input c.work c.output) x.length + (G + (3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1)) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) + (tallyBump_hoareTime k x N H v a r I hI hIz Hb b) + (fun inp work out hpre i => midPublish_heads k x N H v a r I Hb G b hGHb hGpair + inp work out hpre i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + obtain ⟨-, ⟨s, -, hs⟩, -⟩ := hpre + rw [hs] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The publication's window. -/ +theorem publishVerdict_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIhead : I.head = 1) (Hb G : ℕ) (b : Bool) + (hG1 : 1 ≤ G) (hGHb : Hb + 1 ≤ G) + (hGpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) : + (TM.writeOutputBitTM (vIdx k)).KeepsWindowOn + (fun c => c.state = (TM.writeOutputBitTM (vIdx k)).qstart ∧ + midParked k x N H v a r I Hb b c.input c.work c.output) x.length (G + 1) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) + (publishVerdict_hoareTime k x N H v a r I hI Hb b) + (fun inp work out hpre i => midParked_heads k x N H v a r I Hb G b hGHb hGpair + inp work out hpre i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.1] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The verdict rewind's window. -/ +theorem parkVerdict_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (Hb G : ℕ) (hHb1 : 1 ≤ Hb) (b : Bool) + (hG1 : 1 ≤ G) (hGHb : Hb ≤ G) + (hGpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) : + (TM.parkRewindTM [vIdx k]).KeepsWindowOn + (fun c => c.state = (TM.parkRewindTM [vIdx k]).qstart ∧ + midMatrix k x N H v a r I Hb b c.input c.work c.output) x.length + (G + (1 + 1 + (2 * (max (Hb + 2) (1 * (Hb + 3) + 1) + 1) + 1))) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) + (parkVerdict_hoareTime k x N H v a r I hIsi hIhead Hb hHb1 b) + (fun inp work out hpre i => midMatrix_heads k x N H v a r I Hb G b hGHb hGpair + inp work out hpre i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.1] + show (1 : ℕ) ≤ G + 1 + omega) + +theorem afterPair_startInvariant (k : ℕ) (x : List Bool) (N H v a r : ℕ) + (i : Fin (enumTapes k)) : Tape.StartInvariant (afterPair k x N H v a r i) := by + rw [afterPair] + by_cases h : i = y1Idx k + · rw [h, Function.update_self] + exact strTape_startInvariant _ + · rw [Function.update_of_ne h] + exact enumBank_startInvariant k x N H v a r i + +theorem afterPair_head (k : ℕ) (x : List Bool) (N H v a r : ℕ) (i : Fin (enumTapes k)) : + (afterPair k x N H v a r i).head = 1 := by + rw [afterPair] + by_cases h : i = y1Idx k + · rw [h, Function.update_self] + exact strTape_head _ + · rw [Function.update_of_ne h, enumBank_head] + +/-- The blanking stage's window. -/ +theorem blankSlot_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIhead : I.head = 1) (G : ℕ) (hG1 : 1 ≤ G) : + (TM.writeOutputBitTM (zIdx k)).KeepsWindowOn + (fun c => c.state = (TM.writeOutputBitTM (zIdx k)).qstart ∧ + (c.input = I ∧ c.work = enumBank k x N H v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ c.output = NTM.outSlot s)) x.length (G + 1) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) (blankSlot_hoareTime k x N H v a r I hI) + (fun inp work out hpre i => by + rw [hpre.2.1] + exact enumBank_head_le k x N H v a r G hG1 i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + obtain ⟨-, -, s, -, hs⟩ := hpre + rw [hs] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The emitter's window. -/ +theorem emit_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (B G : ℕ) + (hB : 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) (hG1 : 1 ≤ G) : + (emitTM k).KeepsWindowOn + (fun c => c.state = (emitTM k).qstart ∧ + (c.input = I ∧ c.work = enumBank k x N H v a r ∧ c.output = TM.blankTape)) + x.length (G + TM.pairInputWorkTime x (dropTop (v + 1))) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) (emit_hoareTime k x N H v a r I hI hIsi B hB) + (fun inp work out hpre i => by + rw [hpre.2.1] + exact enumBank_head_le k x N H v a r G hG1 i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.2] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The rewinding stage's window. -/ +theorem parkPair_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (B G : ℕ) (hB1 : 1 ≤ B) + (hGB : B ≤ G) : + (TM.parkRewindTM [xIdx k, wIdx k, y1Idx k]).KeepsWindowOn + (fun c => c.state = (TM.parkRewindTM [xIdx k, wIdx k, y1Idx k]).qstart ∧ + midEmit k x N H v a r I B c.input c.work c.output) x.length + (G + (1 + 1 + (2 * (max (B + 2) (3 * (B + 3) + 1) + 1) + 1))) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) (parkPair_hoareTime k x N H v a r I hIsi hIhead B hB1) + (fun inp work out hpre i => by + have := hpre.2.2.2.2.2.2.2 i + omega) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.1] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The copy stage's window. -/ +theorem copyPair_keepsWindowOn (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) + (hI : TM.Parked I) (hIhead : I.head = 1) (G : ℕ) (hG1 : 1 ≤ G) : + (copyPairTM k).KeepsWindowOn + (fun c => c.state = (copyPairTM k).qstart ∧ + (c.input = I ∧ c.work = afterPair k x N H v a r ∧ c.output = TM.blankTape)) + x.length (G + (2 * (pair x (dropTop (v + 1))).length + 5)) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) (copyPair_hoareTime k x N H v a r I hI) + (fun inp work out hpre i => by + rw [hpre.2.1, afterPair_head] + omega) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.2] + show (1 : ℕ) ≤ G + 1 + omega) + +/-- The evaluating stage's window, at the tapes the copy stage leaves. -/ +theorem matrix_keepsWindowOn (M : TM k) {L' : Language} {S : ℕ → ℕ} + (hdecS : M.DecidesInSpace L' S) (hne : M.qstart ≠ M.qhalt) + (x : List Bool) (N H v a r : ℕ) (I : Tape) (hIsi : Tape.StartInvariant I) + (hIhead : I.head = 1) (W : ℕ) + (hW : (pair x (dropTop (v + 1))).length + S (pair x (dropTop (v + 1))).length + 2 ≤ W) + (hWpair : (pair x (dropTop (v + 1))).length + 1 ≤ W) : + (matrixTM M).KeepsWindowOn + (fun c => c.state = (matrixTM M).qstart ∧ + (c.input = I ∧ c.work = afterCopy k x N H v a r ∧ c.output = TM.blankTape)) + x.length W := by + have h := matrixTM_keepsWindowOn M hdecS hne (pair x (dropTop (v + 1))) I hIsi + (afterCopy k x N H v a r) + (fun i _ => afterCopy_startInvariant k x N H v a r i) + (fun i _ => afterCopy_head_pos k x N H v a r i) + (inputLength := x.length) (space := W) + (fun i _ => afterCopy_head_le k x N H v a r W hWpair i) hW + (by rw [hIhead]; omega) + intro c hc D hD + refine h c ⟨hc.1, hc.2.1, ?_, hc.2.2.2⟩ D hD + rw [hc.2.2.1, matrixEntry_afterCopy] + +theorem midMatrix_si (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midMatrix k x N H v a r I Hb b inp work out) : + ∀ i, Tape.StartInvariant (work i) := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · exact (h.2.2.2.2 i hm).1 + · rw [h.2.2.2.1 i hm] + exact afterCopy_startInvariant k x N H v a r i + +theorem midParked_si (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midParked k x N H v a r I Hb b inp work out) : + ∀ i, Tape.StartInvariant (work i) := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · exact (h.2.2.2.2.2 i hm).1 + · rw [h.2.2.2.1 i hm] + exact afterCopy_startInvariant k x N H v a r i + +theorem midPublish_si (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midPublish k x N H v a r I Hb b inp work out) : + ∀ i, Tape.StartInvariant (work i) := by + intro i + by_cases hm : TM.placeWorkInMiddle 3 (k + 2) i + · exact (h.2.2.2.2 i hm).1 + · rw [h.2.2.1 i hm] + exact afterCopy_startInvariant k x N H v a r i + +theorem midBump_si (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midBump k x N H v a r I Hb b inp work out) : + ∀ i, Tape.StartInvariant (work i) := + fun i => ⟨h.2.2.2.2.2.2.2.1 i, fun j hj => (h.2.2.2.2.2.2.1 i).2 j hj⟩ + +theorem midBumped_si (k : ℕ) (x : List Bool) (N H v a r : ℕ) (I : Tape) (Hb : ℕ) (b : Bool) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : midBumped k x N H v a r I Hb b inp work out) : + ∀ i, Tape.StartInvariant (work i) := + fun i => ⟨h.2.2.2.2.2.2.2.2.1 i, fun j hj => (h.2.2.2.2.2.2.2.1 i).2 j hj⟩ + +/-- A contract yields the halting witness the window composition asks for. -/ +theorem hoare_post_of {m : ℕ} {tm : TM m} {pre post : TM.TapePred m} {bnd : ℕ} + (h : tm.HoareTime pre post bnd) (c : Cfg m tm.Q) (hst : c.state = tm.qstart) + (hpre : pre c.input c.work c.output) : + ∃ e, tm.reaches c e ∧ tm.halted e ∧ post e.input e.work e.output := by + obtain ⟨e, t, -, hreach, hhalt, hpost⟩ := h c.input c.work c.output hpre + refine ⟨e, ?_, hhalt, hpost⟩ + rw [show (⟨tm.qstart, c.input, c.work, c.output⟩ : Cfg m tm.Q) = c from + Cfg.ext hst.symm rfl rfl rfl] at hreach + exact TM.reaches_of_reachesIn hreach + +/-- A configuration whose heads are inside `G` is inside any wider window. -/ +theorem windowed_of_heads {Q : Type} (c : Cfg (enumTapes k) Q) (lx G W : ℕ) (hGW : G ≤ W) + (hw : ∀ i, (c.work i).head ≤ G) (hi : c.input.head ≤ 1) (ho : c.output.head ≤ 1) + (h1 : 1 ≤ W) : c.WithinDecisionSpace lx W := + ⟨⟨fun i => le_trans (hw i) hGW, by omega⟩, by omega⟩ + +/-- And it satisfies the left-marker invariant if each of its tapes does. -/ +theorem cfgStartInvariant_of {Q : Type} (c : Cfg (enumTapes k) Q) + (hi : Tape.StartInvariant c.input) (hw : ∀ i, Tape.StartInvariant (c.work i)) + (ho : Tape.StartInvariant c.output) : TM.CfgStartInvariant c := ⟨hi, hw, ho⟩ + +/-- **One pass of the enumerator keeps a window.** Nine stages are bounded by their running +times; the matrix machine is bounded by its space, which is the only bound of the ten that is +polynomial in the input length. -/ +theorem bodyTM_keepsWindowOn (M : TM k) {L' : Language} {T S : ℕ → ℕ} + (hdec : M.DecidesInTime L' T) (hdecS : M.DecidesInSpace L' S) + (hne : M.qstart ≠ M.qhalt) + (x : List Bool) (N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) + (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (hIz : I.cells 0 = Γ.start) + (B Hb G W : ℕ) (hB : 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) (hB1 : 1 ≤ B) + (hHb1 : 1 ≤ Hb) + (hHS : (pair x (dropTop (v + 1))).length + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) + (hHbH : Hb + 1 ≤ H) (hpairH : (pair x (dropTop (v + 1))).length + 1 ≤ H) + (b : Bool) (hb : b = true ↔ pair x (dropTop (v + 1)) ∈ L') + (hG1 : 1 ≤ G) (hGB : B ≤ G) (hGHb : Hb + 1 ≤ G) + (hGpair : (pair x (dropTop (v + 1))).length + 1 ≤ G) + (hW1 : G + 1 ≤ W) + (hW2 : G + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ W) + (hW3 : G + (1 + 1 + (2 * (max (B + 2) (3 * (B + 3) + 1) + 1) + 1)) ≤ W) + (hW4 : G + (2 * (pair x (dropTop (v + 1))).length + 5) ≤ W) + (hW6 : G + (1 + 1 + (2 * (max (Hb + 2) (1 * (Hb + 3) + 1) + 1) + 1)) ≤ W) + (hW8 : G + (3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1) ≤ W) + (hW9 : G + TM.binaryBumpTime (dropTop (v + 1)) ≤ W) + (hW10 : G + ((scratchTargets k).length * (H + 4) + H * 4 + 8 + 1 + + ((scratchTargets k).length * (H + 4) + 1)) ≤ W) : + (bodyTM M).KeepsWindowOn + (fun c => c.state = (bodyTM M).qstart ∧ c.input = I ∧ + c.work = enumBank k x N H v a r ∧ ∃ s : Γw, s ≠ Γw.one ∧ c.output = NTM.outSlot s) + x.length W := by + have hs : 1 ≤ W := by omega + have hGW : G ≤ W := by omega + have w1 := (blankSlot_keepsWindowOn k x N H v a r I hI hIhead G hG1).mono_space hW1 + have w2 := (emit_keepsWindowOn k x N H v a r I hI hIsi hIhead B G hB hG1).mono_space hW2 + have w3 := (parkPair_keepsWindowOn k x N H v a r I hIsi hIhead B G hB1 hGB).mono_space hW3 + have w4 := (copyPair_keepsWindowOn k x N H v a r I hI hIhead G hG1).mono_space hW4 + have w5 := matrix_keepsWindowOn M hdecS hne x N H v a r I hIsi hIhead W (by omega) (by omega) + have w6 := (parkVerdict_keepsWindowOn k x N H v a r I hIsi hIhead Hb G (by omega) b hG1 + (by omega) hGpair).mono_space hW6 + have w7 := (publishVerdict_keepsWindowOn k x N H v a r I hI hIhead Hb G b hG1 hGHb + hGpair).mono_space hW1 + have w8 := (tallyBump_keepsWindowOn k x N H v a r I hI hIz hIhead Hb G b hG1 hGHb + hGpair).mono_space hW8 + have w9 := (witnessBump_keepsWindowOn k x N H v a r I hI hIhead Hb G b hG1 hGHb + hGpair).mono_space hW9 + have w10 := (wipe_keepsWindowOn k x N H v a r I hI hIsi hIhead Hb G b hHbH hpairH hG1 + hGHb hGpair).mono_space hW10 + -- Stage 9 with the wipe. + have c910 := TM.seqTM_keepsWindowOn (TM.binaryBumpTM (wIdx k)) + (TM.wipeRewindTM (scratchTargets k) (regIdx k)) hs + (mid := midBumped k x N H v a r I Hb b) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (midBump_heads k x N H v a r I Hb G b hGHb hGpair hG1 _ _ _ hc.2) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.1]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (midBump_si k x N H v a r I Hb b _ _ _ hc.2) + (by rw [hc.2.2.1]; exact TM.blankTape_startInvariant)⟩) + w9 + (fun c hc => hoare_post_of (witnessBump_hoareTime k x N H v a r I hI Hb b) c hc.1 hc.2) + w10 + (fun inp work out h => ⟨rfl, + trans_of_parked_pred (P := midBumped k x N H v a r I Hb b) + (by rw [h.1]; exact hI) (h.2.2.2.2.2.2.2.1) + (by rw [h.2.1]; exact TM.blankTape_parked) h⟩) + -- Stage 8. + have c810 := TM.seqTM_keepsWindowOn (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)) + (TM.seqTM (TM.binaryBumpTM (wIdx k)) (TM.wipeRewindTM (scratchTargets k) (regIdx k))) hs + (mid := midBump k x N H v a r I Hb b) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (midPublish_heads k x N H v a r I Hb G b hGHb hGpair _ _ _ hc.2) + (by rw [hc.2.1, hIhead]) (by + obtain ⟨-, ⟨sy, -, hsy⟩, -⟩ := hc.2 + rw [hsy] + exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (midPublish_si k x N H v a r I Hb b _ _ _ hc.2) + (by + obtain ⟨-, ⟨sy, -, hsy⟩, -⟩ := hc.2 + rw [hsy] + exact ⟨rfl, fun j hj => (NTM.outSlot_parked sy).2 j hj⟩)⟩) + w8 + (fun c hc => hoare_post_of (tallyBump_hoareTime k x N H v a r I hI hIz Hb b) c hc.1 hc.2) + c910 + (fun inp work out h => ⟨⟨(TM.binaryBumpTM (wIdx k)).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, trans_of_parked_pred (P := midBump k x N H v a r I Hb b) + (by rw [h.1]; exact hI) (h.2.2.2.2.2.2.1) + (by rw [h.2.1]; exact TM.blankTape_parked) h⟩, rfl⟩) + -- Stage 7. + have c710 := TM.seqTM_keepsWindowOn (TM.writeOutputBitTM (vIdx k)) _ hs + (mid := midPublish k x N H v a r I Hb b) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (midParked_heads k x N H v a r I Hb G b hGHb hGpair _ _ _ hc.2) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.1]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (midParked_si k x N H v a r I Hb b _ _ _ hc.2) + (by rw [hc.2.2.1]; exact TM.blankTape_startInvariant)⟩) + w7 + (fun c hc => hoare_post_of (publishVerdict_hoareTime k x N H v a r I hI Hb b) c hc.1 hc.2) + c810 + (fun inp work out h => ⟨⟨(TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)).qstart, + TM.transitionInput inp, fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, trans_of_parked_pred (P := midPublish k x N H v a r I Hb b) + (by rw [h.1]; exact hI) h.2.2.2.1 + (by + obtain ⟨-, ⟨sy, -, hsy⟩, -⟩ := h + rw [hsy] + exact NTM.outSlot_parked sy) h⟩, rfl⟩) + -- Stage 6. + have c610 := TM.seqTM_keepsWindowOn (TM.parkRewindTM [vIdx k]) _ hs + (mid := midParked k x N H v a r I Hb b) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (midMatrix_heads k x N H v a r I Hb G b (by omega) hGpair _ _ _ hc.2) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.1]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (midMatrix_si k x N H v a r I Hb b _ _ _ hc.2) + (by rw [hc.2.2.1]; exact TM.blankTape_startInvariant)⟩) + w6 + (fun c hc => hoare_post_of (parkVerdict_hoareTime k x N H v a r I hIsi hIhead Hb hHb1 b) c + hc.1 hc.2) + c710 + (fun inp work out h => ⟨⟨(TM.writeOutputBitTM (vIdx k)).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, trans_of_parked_pred (P := midParked k x N H v a r I Hb b) + (by rw [h.1]; exact hI) h.2.2.2.2.1 + (by rw [h.2.1]; exact TM.blankTape_parked) h⟩, rfl⟩) + -- Stage 5: the matrix machine. + have c510 := TM.seqTM_keepsWindowOn (matrixTM M) _ hs + (mid := midMatrix k x N H v a r I Hb b) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (fun i => by rw [hc.2.2.1]; exact afterCopy_head_le k x N H v a r G hGpair i) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.2]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (fun i => by rw [hc.2.2.1]; exact afterCopy_startInvariant k x N H v a r i) + (by rw [hc.2.2.2]; exact TM.blankTape_startInvariant)⟩) + w5 + (fun c hc => hoare_post_of + (matrix_hoareTime_bool M hdec hdecS x N H v a r I hI hIsi Hb hHS b hb) c hc.1 + ⟨hc.2.1, hc.2.2.1, hc.2.2.2⟩) + c610 + (fun inp work out h => ⟨⟨(TM.parkRewindTM [vIdx k]).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, midMatrix_trans k x N H v a r I hI Hb (by omega) b inp work out h⟩, rfl⟩) + -- Stage 4. + have c410 := TM.seqTM_keepsWindowOn (copyPairTM k) _ hs + (mid := fun inp work out => inp = I ∧ work = afterCopy k x N H v a r ∧ + out = TM.blankTape) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (fun i => by rw [hc.2.2.1, afterPair_head]; omega) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.2]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (fun i => by rw [hc.2.2.1]; exact afterPair_startInvariant k x N H v a r i) + (by rw [hc.2.2.2]; exact TM.blankTape_startInvariant)⟩) + w4 + (fun c hc => hoare_post_of (copyPair_hoareTime k x N H v a r I hI) c hc.1 + ⟨hc.2.1, hc.2.2.1, hc.2.2.2⟩) + c510 + (fun inp work out h => ⟨⟨(matrixTM M).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, trans_of_parked_pred + (P := fun inp work out => inp = I ∧ work = afterCopy k x N H v a r ∧ + out = TM.blankTape) (by rw [h.1]; exact hI) + (fun i => by rw [h.2.1]; exact afterCopy_parked k x N H v a r i) + (by rw [h.2.2]; exact TM.blankTape_parked) h⟩, rfl⟩) + -- Stage 3. + have c310 := TM.seqTM_keepsWindowOn (TM.parkRewindTM [xIdx k, wIdx k, y1Idx k]) _ hs + (mid := fun inp work out => inp = I ∧ work = afterPair k x N H v a r ∧ + out = TM.blankTape) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (fun i => le_trans (hc.2.2.2.2.2.2.2.2 i) hGB) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.1]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) hc.2.2.2.2.2.2.2.1 + (by rw [hc.2.2.1]; exact TM.blankTape_startInvariant)⟩) + w3 + (fun c hc => hoare_post_of (parkPair_hoareTime k x N H v a r I hIsi hIhead B hB1) c hc.1 + hc.2) + c410 + (fun inp work out h => ⟨⟨(copyPairTM k).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, trans_of_parked_pred + (P := fun inp work out => inp = I ∧ work = afterPair k x N H v a r ∧ + out = TM.blankTape) (by rw [h.1]; exact hI) + (fun i => by rw [h.2.1]; exact afterPair_parked k x N H v a r i) + (by rw [h.2.2]; exact TM.blankTape_parked) h⟩, rfl⟩) + -- Stage 2. + have c210 := TM.seqTM_keepsWindowOn (emitTM k) _ hs + (mid := midEmit k x N H v a r I B) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (fun i => by rw [hc.2.2.1]; exact enumBank_head_le k x N H v a r G hG1 i) + (by rw [hc.2.1, hIhead]) (by rw [hc.2.2.2]; exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (fun i => by rw [hc.2.2.1]; exact enumBank_startInvariant k x N H v a r i) + (by rw [hc.2.2.2]; exact TM.blankTape_startInvariant)⟩) + w2 + (fun c hc => hoare_post_of (emit_hoareTime k x N H v a r I hI hIsi B hB) c hc.1 + ⟨hc.2.1, hc.2.2.1, hc.2.2.2⟩) + c310 + (fun inp work out h => ⟨⟨(TM.parkRewindTM [xIdx k, wIdx k, y1Idx k]).qstart, + TM.transitionInput inp, fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, midEmit_trans k x N H v a r I hI B (by omega) inp work out h⟩, rfl⟩) + -- Stage 1. + have c110 := TM.seqTM_keepsWindowOn (TM.writeOutputBitTM (zIdx k)) _ hs + (mid := fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ + out = TM.blankTape) + (fun c hc => ⟨hc.1, + windowed_of_heads c x.length G W hGW + (fun i => by rw [hc.2.2.1]; exact enumBank_head_le k x N H v a r G hG1 i) + (by rw [hc.2.1, hIhead]) (by + obtain ⟨-, -, -, sy, -, hsy⟩ := hc + rw [hsy] + exact le_of_eq rfl) hs, + cfgStartInvariant_of c (by rw [hc.2.1]; exact hIsi) + (fun i => by rw [hc.2.2.1]; exact enumBank_startInvariant k x N H v a r i) + (by + obtain ⟨-, -, -, sy, -, hsy⟩ := hc + rw [hsy] + exact ⟨rfl, fun j hj => (NTM.outSlot_parked sy).2 j hj⟩)⟩) + w1 + (fun c hc => hoare_post_of (blankSlot_hoareTime k x N H v a r I hI) c hc.1 + ⟨hc.2.1, hc.2.2.1, hc.2.2.2⟩) + c210 + (fun inp work out h => ⟨⟨(emitTM k).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, trans_of_parked_pred + (P := fun inp work out => inp = I ∧ work = enumBank k x N H v a r ∧ + out = TM.blankTape) (by rw [h.1]; exact hI) + (fun i => by rw [h.2.1]; exact enumBank_parked k x N H v a r i) + (by rw [h.2.2]; exact TM.blankTape_parked) h⟩, rfl⟩) + intro c hc D hD + exact c110 c ⟨⟨(TM.writeOutputBitTM (zIdx k)).qstart, c.input, c.work, c.output⟩, + ⟨rfl, hc.2.1, hc.2.2.1, hc.2.2.2⟩, Cfg.ext hc.1 rfl rfl rfl⟩ D hD + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHBounds.lean b/Complexitylib/Classes/Containments/Internal/PHBounds.lean new file mode 100644 index 00000000..a1434094 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHBounds.lean @@ -0,0 +1,687 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHAssembleWindow +public import Complexitylib.Classes.Containments.Internal.PSPACESubsetEXP + +/-! +# The enumerator's bounds, in the input's length + +⚠️ Unreviewed by Bolton + +Every quantity the enumerator's contracts and windows are stated in terms of — the width of a +pair, the number of digits in a counter, the running time of a stage — is bounded by a polynomial +in the input's length. This file collects those bounds. + +## Main results + +- `PolyExists.dropTop_length_le`, `PolyExists.pair_length_le` — the witness and the pair it goes + into are no wider than the horizon's exponent allows +- `PolyExists.bits_length_le` — a counter below the horizon has that many digits +- `PolyExists.tally_le` — a tally never exceeds its count +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- **A witness below the horizon is no longer than the exponent.** -/ +theorem dropTop_length_le (m j N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hj : j < N) : + (dropTop (j + 1)).length ≤ m := by + refine length_dropTop_le (m := m) ?_ + have h1 : 1 ≤ 2 ^ (m + 1) := Nat.one_le_two_pow + omega + +/-- **And the pair it goes into is bounded too.** -/ +theorem pair_length_le (x : List Bool) (m j N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hj : j < N) : + (pair x (dropTop (j + 1))).length ≤ 2 * x.length + 2 + m := by + rw [pair_length] + have := dropTop_length_le m j N hN hj + omega + +/-- **A counter at most the horizon has at most `m + 1` digits.** -/ +theorem bits_length_le (m j N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hj : j ≤ N) : + j.bits.length ≤ m + 1 := by + have h1 : 1 ≤ 2 ^ (m + 1) := Nat.one_le_two_pow + have hjlt : j < 2 ^ (m + 1) := by omega + have hsize : j.size ≤ m + 1 := Nat.size_le.mpr hjlt + rw [Nat.size_eq_bits_len j] + exact hsize + +/-- **A tally never exceeds its count.** -/ +theorem tally_le (P : ℕ → Bool) : ∀ v, NTM.tally P v ≤ v + | 0 => le_refl 0 + | v + 1 => by + have := tally_le P v + rw [NTM.tally] + split <;> omega + +/-- **The successor's running time, in digits.** -/ +theorem binarySuccTime_le' (m v N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hv : v ≤ N) : + TM.binarySuccTime v ≤ 2 * (m + 1) + 2 := by + refine le_trans (BinarySucc.steps_le v.bits) ?_ + have := bits_length_le m v N hN hv + omega + +/-- **The witness advance's running time.** -/ +theorem binaryBumpTime_le' (m j N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hj : j < N) : + TM.binaryBumpTime (dropTop (j + 1)) ≤ 2 * m + 2 := by + refine le_trans (BinaryBump.steps_le _) ?_ + have := dropTop_length_le m j N hN hj + omega + +/-- **The comparison's running time.** -/ +theorem binaryEqTime_le' (m j N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hj : j < N) : + TM.binaryEqTime (j + 1).bits N.bits ≤ m + 2 := by + rw [TM.binaryEqTime] + have h1 := bits_length_le m (j + 1) N hN (by omega) + have h2 := bits_length_le m N N hN (le_refl N) + omega + +/-- **A polynomial with natural coefficients is monotone.** -/ +theorem eval_mono (r : Polynomial ℕ) {a b : ℕ} (h : a ≤ b) : r.eval a ≤ r.eval b := by + induction r using Polynomial.induction_on' with + | add p q hp hq => + simp only [Polynomial.eval_add] + omega + | monomial n c => + simp only [Polynomial.eval_monomial] + exact Nat.mul_le_mul_left c (Nat.pow_le_pow_left h n) + +/-! ## The bounds themselves -/ + +/-- The width of the pair the matrix machine reads. -/ +def bP (lx m : ℕ) : ℕ := 2 * lx + 2 + m + +/-- The window the matrix machine needs. -/ +def bHb (lx m sb : ℕ) : ℕ := bP lx m + sb + 2 + +/-- The wipe height. -/ +def bH (lx m sb : ℕ) : ℕ := bHb lx m sb + 1 + +/-- The bound on the heads the rewinds have to chase. -/ +def bB (lx m : ℕ) : ℕ := (lx + 1) + (2 * lx + m + 4) + (m + 4) + +/-- The uniform bound on every head of every intermediate state. -/ +def bG (lx m sb : ℕ) : ℕ := (bHb lx m sb + 1) + bB lx m + (bP lx m + 1) + +theorem bP_le_bHb (lx m sb : ℕ) : bP lx m ≤ bHb lx m sb := by + rw [bHb] + omega + +theorem bHb_lt_bH (lx m sb : ℕ) : bHb lx m sb + 1 ≤ bH lx m sb := le_refl _ + +theorem bP_lt_bH (lx m sb : ℕ) : bP lx m + 1 ≤ bH lx m sb := by + have := bP_le_bHb lx m sb + rw [bH] + omega + +theorem bB_le_bG (lx m sb : ℕ) : bB lx m ≤ bG lx m sb := by + rw [bG] + omega + +theorem bHb_le_bG (lx m sb : ℕ) : bHb lx m sb + 1 ≤ bG lx m sb := by + rw [bG] + omega + +theorem bP_le_bG (lx m sb : ℕ) : bP lx m + 1 ≤ bG lx m sb := by + rw [bG] + omega + +theorem one_le_bG (lx m sb : ℕ) : 1 ≤ bG lx m sb := by + rw [bG, bB] + omega + +theorem one_le_bB (lx m : ℕ) : 1 ≤ bB lx m := by + rw [bB] + omega + +theorem one_le_bHb (lx m sb : ℕ) : 1 ≤ bHb lx m sb := by + rw [bHb, bP] + omega + +/-- The window the whole machine runs in: the uniform head bound plus one summand for every +stage's own budget. Sums, not maxima, so that the whole thing is visibly a polynomial in the +input's length. -/ +def bW (st lx m sb pro epi : ℕ) : ℕ := + bG lx m sb + + 1 + + (2 * lx + m + 3) + + (1 + 1 + (2 * ((bB lx m + 2) + (3 * (bB lx m + 3) + 1) + 1) + 1)) + + (2 * bP lx m + 5) + + (1 + 1 + (2 * ((bHb lx m sb + 2) + (1 * (bHb lx m sb + 3) + 1) + 1) + 1)) + + (3 * ((1 + 1 + ((2 * (m + 1) + 2) + (2 * (m + 1) + 2)) + 5) + (2 * (m + 1) + 2) + 1) + 1) + + (2 * m + 2) + + (st * (bH lx m sb + 4) + bH lx m sb * 4 + 8 + 1 + (st * (bH lx m sb + 4) + 1)) + + ((m + 2) + 1 + (3 * ((3 * (bB lx m + 3) + 1) + (bB lx m + 2 + 1 + (2 * 1 + 5)) + 1) + 1)) + + (1 + lx + 1) + + ((lx + 1) + (1 + 1 + (2 * ((bB lx m + 2) + (1 * (bB lx m + 3) + 1) + 1) + 1))) + + (1 + pro) + + (1 + epi) + +theorem bG_le_bW (st lx m sb pro epi : ℕ) : bG lx m sb ≤ bW st lx m sb pro epi := by + rw [bW] + omega + +theorem one_le_bW (st lx m sb pro epi : ℕ) : 1 ≤ bW st lx m sb pro epi := by + have := one_le_bG lx m sb + have := bG_le_bW st lx m sb pro epi + omega + +section Bounds + +variable (st lx m sb pro epi : ℕ) + +theorem bW_stage1 : bG lx m sb + 1 ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_stage2 (x w : List Bool) (hx : x.length = lx) (hw : w.length ≤ m) : + bG lx m sb + TM.pairInputWorkTime x w ≤ bW st lx m sb pro epi := by + rw [bW, TM.pairInputWorkTime, hx] + omega + +theorem bW_stage3 : bG lx m sb + + (1 + 1 + (2 * (max (bB lx m + 2) (3 * (bB lx m + 3) + 1) + 1) + 1)) + ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_stage4 (P : ℕ) (hP : P ≤ bP lx m) : + bG lx m sb + (2 * P + 5) ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_stage6 : bG lx m sb + + (1 + 1 + (2 * (max (bHb lx m sb + 2) (1 * (bHb lx m sb + 3) + 1) + 1) + 1)) + ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_stage8 (a r v : ℕ) (ha : TM.binarySuccTime a ≤ 2 * (m + 1) + 2) + (hr : TM.binarySuccTime r ≤ 2 * (m + 1) + 2) (hv : TM.binarySuccTime v ≤ 2 * (m + 1) + 2) : + bG lx m sb + (3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1) ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_stage9 (t : ℕ) (ht : t ≤ 2 * m + 2) : + bG lx m sb + t ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_stage10 (H : ℕ) (hH : H = bH lx m sb) : + bG lx m sb + (st * (H + 4) + H * 4 + 8 + 1 + (st * (H + 4) + 1)) + ≤ bW st lx m sb pro epi := by + rw [bW, hH]; omega + +theorem bW_test (N j : ℕ) (hj : TM.binaryEqTime (j + 1).bits N.bits ≤ m + 2) : + bG lx m sb + testTime (bB lx m) N j ≤ bW st lx m sb pro epi := by + rw [bW, testTime, TM.resetBinaryWorkTime, TM.clearWorkTimeBound] + omega + +theorem bW_copy : 1 + (lx + 1) ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_rewind : (lx + 1) + + (1 + 1 + (2 * (max (bB lx m + 2) (1 * (bB lx m + 3) + 1) + 1) + 1)) + ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_prologue : 1 + pro ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_epilogue (e : ℕ) (he : e ≤ epi) : 1 + e ≤ bW st lx m sb pro epi := by + rw [bW]; omega + +theorem bW_matrix : bHb lx m sb ≤ bW st lx m sb pro epi := by + have := bHb_le_bG lx m sb + have := bG_le_bW st lx m sb pro epi + omega + +end Bounds + +/-! ## The bounds as polynomials -/ + +/-- The width of the pair, as a polynomial in the input's length. -/ +noncomputable def bPPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 2 * Polynomial.X + Polynomial.C 2 + p + +@[simp] theorem bPPoly_eval (p : Polynomial ℕ) (lx : ℕ) : + (bPPoly p).eval lx = bP lx (p.eval lx) := by + simp only [bPPoly, bP, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X] + +/-- The matrix machine's window, as a polynomial. -/ +noncomputable def bHbPoly (p s : Polynomial ℕ) : Polynomial ℕ := + bPPoly p + s.comp (bPPoly p) + Polynomial.C 2 + +@[simp] theorem bHbPoly_eval (p s : Polynomial ℕ) (lx : ℕ) : + (bHbPoly p s).eval lx = bHb lx (p.eval lx) (s.eval (bP lx (p.eval lx))) := by + simp only [bHbPoly, bHb, Polynomial.eval_add, Polynomial.eval_C, Polynomial.eval_comp, + bPPoly_eval] + +/-- The wipe height, as a polynomial. -/ +noncomputable def bHPoly (p s : Polynomial ℕ) : Polynomial ℕ := bHbPoly p s + 1 + +@[simp] theorem bHPoly_eval (p s : Polynomial ℕ) (lx : ℕ) : + (bHPoly p s).eval lx = bH lx (p.eval lx) (s.eval (bP lx (p.eval lx))) := by + simp only [bHPoly, bH, Polynomial.eval_add, Polynomial.eval_one, bHbPoly_eval] + +/-- The rewind bound, as a polynomial. -/ +noncomputable def bBPoly (p : Polynomial ℕ) : Polynomial ℕ := + (Polynomial.X + 1) + (Polynomial.C 2 * Polynomial.X + p + Polynomial.C 4) + + (p + Polynomial.C 4) + +@[simp] theorem bBPoly_eval (p : Polynomial ℕ) (lx : ℕ) : + (bBPoly p).eval lx = bB lx (p.eval lx) := by + simp only [bBPoly, bB, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, Polynomial.eval_one] + +/-- The uniform head bound, as a polynomial. -/ +noncomputable def bGPoly (p s : Polynomial ℕ) : Polynomial ℕ := + (bHbPoly p s + 1) + bBPoly p + (bPPoly p + 1) + +@[simp] theorem bGPoly_eval (p s : Polynomial ℕ) (lx : ℕ) : + (bGPoly p s).eval lx = bG lx (p.eval lx) (s.eval (bP lx (p.eval lx))) := by + simp only [bGPoly, bG, Polynomial.eval_add, Polynomial.eval_one, bHbPoly_eval, bBPoly_eval, + bPPoly_eval] + +/-- The Horner cap, as a polynomial. -/ +noncomputable def capPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C ((TM.polyCoeffs p).sum + 1) * (Polynomial.X + 1) ^ (TM.polyCoeffs p).length + +@[simp] theorem capPoly_eval (p : Polynomial ℕ) (lx : ℕ) : + (capPoly p).eval lx = prologueCap p lx := by + simp only [capPoly, prologueCap, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_add, Polynomial.eval_X, Polynomial.eval_one] + +/-- The register machine's per-operation budget, as a polynomial. -/ +noncomputable def opBudgetPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 32 * (capPoly p + Polynomial.C 2) ^ 3 + +@[simp] theorem opBudgetPoly_eval (p : Polynomial ℕ) (lx : ℕ) : + (opBudgetPoly p).eval lx = TM.opBudget (prologueCap p lx) := by + simp only [opBudgetPoly, TM.opBudget, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_add, capPoly_eval] + ring + +/-- Its per-layer budget. -/ +noncomputable def layerBudgetPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 4 * opBudgetPoly p + Polynomial.C 3 + +@[simp] theorem layerBudgetPoly_eval (p : Polynomial ℕ) (lx : ℕ) : + (layerBudgetPoly p).eval lx = TM.layerBudget (prologueCap p lx) := by + simp only [layerBudgetPoly, TM.layerBudget, Polynomial.eval_add, Polynomial.eval_mul, + Polynomial.eval_C, opBudgetPoly_eval] + +/-- The prologue's running time, dominated by a polynomial. -/ +noncomputable def proPoly (p q : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 7 * ((Polynomial.C 2 * Polynomial.X + Polynomial.C 4) + + (opBudgetPoly p + 1 + (Polynomial.C (p.natDegree + 1) * (layerBudgetPoly p + 1) + 1)) + + (Polynomial.C 2 * p + Polynomial.C 4) + + (opBudgetPoly q + 1 + (Polynomial.C (q.natDegree + 1) * (layerBudgetPoly q + 1) + 1)) + + (Polynomial.C 2 * q + Polynomial.C 4) + 1) + 1 + +theorem prologueTime_le (p q : Polynomial ℕ) (lx : ℕ) : + prologueTime p q lx ≤ (proPoly p q).eval lx := by + rw [prologueTime, prologueBnd, proPoly] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X, + Polynomial.eval_one, opBudgetPoly_eval, layerBudgetPoly_eval] + omega + +/-- The epilogue's running time, dominated by a polynomial. -/ +noncomputable def epiPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 6 * p + Polynomial.C 50 + +theorem epilogueTime_le (m A N : ℕ) (hN : N = 2 ^ (m + 1) - 1) (hA : A ≤ N) : + epilogueTime A ≤ 6 * m + 50 := by + have hsize : A.size ≤ m + 1 := by + have h1 : 1 ≤ 2 ^ (m + 1) := Nat.one_le_two_pow + exact Nat.size_le.mpr (by omega) + have hsucc : TM.binarySuccTime 0 = 2 := rfl + have hsub : TM.binaryRippleSubTime 1 A ≤ 3 * m + 14 := by + rw [TM.binaryRippleSubTime] + have h1 : (1 : ℕ).size = 1 := rfl + omega + have heq : TM.binaryEqTime (1 - A).bits (0 : ℕ).bits ≤ 2 := by + rw [TM.binaryEqTime] + have h0 : (0 : ℕ).bits = [] := by simp + have h1 : (1 - A).bits.length ≤ 1 := by + rcases Nat.eq_zero_or_pos A with rfl | hpos + · show (1 - 0 : ℕ).bits.length ≤ 1 + decide + · have : 1 - A = 0 := by omega + rw [this] + simp + rw [h0] + simp only [List.length_nil] + omega + rw [epilogueTime, hsucc] + omega + +/-- **The enumerator's space bound, as a polynomial.** -/ +noncomputable def bWPoly (st : ℕ) (p s q : Polynomial ℕ) : Polynomial ℕ := + bGPoly p s + + 1 + + (Polynomial.C 2 * Polynomial.X + p + Polynomial.C 3) + + (1 + 1 + (Polynomial.C 2 * ((bBPoly p + Polynomial.C 2) + + (Polynomial.C 3 * (bBPoly p + Polynomial.C 3) + 1) + 1) + 1)) + + (Polynomial.C 2 * bPPoly p + Polynomial.C 5) + + (1 + 1 + (Polynomial.C 2 * ((bHbPoly p s + Polynomial.C 2) + + (Polynomial.C 1 * (bHbPoly p s + Polynomial.C 3) + 1) + 1) + 1)) + + (Polynomial.C 3 * ((1 + 1 + ((Polynomial.C 2 * (p + 1) + Polynomial.C 2) + + (Polynomial.C 2 * (p + 1) + Polynomial.C 2)) + Polynomial.C 5) + + (Polynomial.C 2 * (p + 1) + Polynomial.C 2) + 1) + 1) + + (Polynomial.C 2 * p + Polynomial.C 2) + + (Polynomial.C st * (bHPoly p s + Polynomial.C 4) + bHPoly p s * Polynomial.C 4 + + Polynomial.C 8 + 1 + (Polynomial.C st * (bHPoly p s + Polynomial.C 4) + 1)) + + ((p + Polynomial.C 2) + 1 + (Polynomial.C 3 * + ((Polynomial.C 3 * (bBPoly p + Polynomial.C 3) + 1) + + (bBPoly p + Polynomial.C 2 + 1 + (Polynomial.C 2 * 1 + Polynomial.C 5)) + 1) + 1)) + + (1 + Polynomial.X + 1) + + ((Polynomial.X + 1) + (1 + 1 + (Polynomial.C 2 * ((bBPoly p + Polynomial.C 2) + + (Polynomial.C 1 * (bBPoly p + Polynomial.C 3) + 1) + 1) + 1))) + + (1 + proPoly p q) + + (1 + epiPoly p) + +@[simp] theorem bWPoly_eval (st : ℕ) (p s q : Polynomial ℕ) (lx : ℕ) : + (bWPoly st p s q).eval lx = + bW st lx (p.eval lx) (s.eval (bP lx (p.eval lx))) ((proPoly p q).eval lx) + ((epiPoly p).eval lx) := by + simp only [bWPoly, bW, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, Polynomial.eval_one, bGPoly_eval, bBPoly_eval, bPPoly_eval, + bHbPoly_eval, bHPoly_eval] + +@[simp] theorem epiPoly_eval (p : Polynomial ℕ) (lx : ℕ) : + (epiPoly p).eval lx = 6 * p.eval lx + 50 := by + simp only [epiPoly, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C] + +/-- **A tally is positive exactly when something below the count satisfied the predicate.** -/ +theorem tally_pos_iff (P : ℕ → Bool) : ∀ N, 0 < NTM.tally P N ↔ ∃ j, j < N ∧ P j = true + | 0 => by + constructor + · intro h + exact absurd h (by simp [NTM.tally]) + · rintro ⟨j, hj, -⟩ + omega + | N + 1 => by + have ih := tally_pos_iff P N + rw [NTM.tally] + constructor + · intro h + by_cases hPN : P N + · exact ⟨N, by omega, hPN⟩ + · rw [if_neg (by simp [hPN])] at h + obtain ⟨j, hj, hPj⟩ := ih.mp (by omega) + exact ⟨j, by omega, hPj⟩ + · rintro ⟨j, hj, hPj⟩ + by_cases hjN : j = N + · rw [hjN] at hPj + rw [if_pos (by simp [hPj])] + omega + · have := ih.mpr ⟨j, by omega, hPj⟩ + split <;> omega + +/-- **What the machine computes is membership in the bounded existential.** -/ +theorem tally_pos_iff_mem (L' : Language) (p : Polynomial ℕ) (x : List Bool) (N : ℕ) + (hN : N = 2 ^ (p.eval x.length + 1) - 1) : + 0 < NTM.tally (enumP L' x) N ↔ x ∈ polyExistsLang p L' := by + rw [tally_pos_iff, show (x ∈ polyExistsLang p L') ↔ + ∃ v < 2 ^ (p.eval x.length + 1), pair x (dropTop v) ∈ L' from + (mem_polyExistsLang (p := p) (L := L') (x := x)).trans + (exists_bounded_iff_count (p.eval x.length) (fun w => pair x w ∈ L'))] + constructor + · rintro ⟨j, hj, hPj⟩ + refine ⟨j + 1, ?_, (enumP_iff L' x j).mp hPj⟩ + have h1 : 1 ≤ 2 ^ (p.eval x.length + 1) := Nat.one_le_two_pow + omega + · rintro ⟨v, hv, hmem⟩ + have h1 : 1 ≤ 2 ^ (p.eval x.length + 1) := Nat.one_le_two_pow + rcases Nat.eq_zero_or_pos v with rfl | hpos + · refine ⟨0, by omega, (enumP_iff L' x 0).mpr ?_⟩ + show pair x (dropTop 1) ∈ L' + have : dropTop 1 = dropTop 0 := by decide + rw [this] + exact hmem + · refine ⟨v - 1, by omega, (enumP_iff L' x (v - 1)).mpr ?_⟩ + rw [show v - 1 + 1 = v from by omega] + exact hmem + +/-! ## The enumerator, instantiated -/ + +section Final + +variable {k : ℕ} + +/-- Every hypothesis the enumerator's contract and window need, at one input. -/ +theorem enum_bounds {f : ℕ → ℕ} (s : Polynomial ℕ) + (hs : ∀ n, f n ≤ s.eval n) (p : Polynomial ℕ) + (x : List Bool) (j : ℕ) + (hj : j < 2 ^ (p.eval x.length + 1) - 1) : + 1 + TM.pairInputWorkTime x (dropTop (j + 1)) ≤ bB x.length (p.eval x.length) ∧ + (pair x (dropTop (j + 1))).length + f (pair x (dropTop (j + 1))).length + 2 ≤ + bHb x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length))) ∧ + (pair x (dropTop (j + 1))).length + 1 ≤ + bH x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length))) ∧ + 1 + 1 + TM.binaryEqTime (j + 1).bits (2 ^ (p.eval x.length + 1) - 1).bits ≤ + bB x.length (p.eval x.length) ∧ + (pair x (dropTop (j + 1))).length + 1 ≤ + bG x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length))) := by + set lx := x.length with hlx + set m := p.eval lx with hm + set N := 2 ^ (m + 1) - 1 with hNdef + have hlen : (dropTop (j + 1)).length ≤ m := dropTop_length_le m j N hNdef hj + have hpairlen : (pair x (dropTop (j + 1))).length ≤ bP lx m := by + rw [pair_length, bP] + omega + have hfle : f (pair x (dropTop (j + 1))).length ≤ s.eval (bP lx m) := + le_trans (hs _) (eval_mono s hpairlen) + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [TM.pairInputWorkTime, bB] + omega + · rw [bHb] + omega + · have := bP_lt_bH lx m (s.eval (bP lx m)) + omega + · have := binaryEqTime_le' m j N hNdef hj + rw [bB] + omega + · have := bP_le_bG lx m (s.eval (bP lx m)) + omega + +end Final + +/-- **The enumerator decides the bounded existential.** -/ +theorem enumTM_decides (M : TM k) {L' : Language} {f : ℕ → ℕ} (s : Polynomial ℕ) + (hs : ∀ n, f n ≤ s.eval n) (hdecS : M.DecidesInSpace L' f) + (hdec : M.DecidesInTime L' (TM.spaceTimeBound M f)) + (p : Polynomial ℕ) (x : List Bool) (N H B Hb bBody bTest : ℕ) + (hNdef : N = 2 ^ (p.eval x.length + 1) - 1) + (hHdef : H = bH x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length)))) + (hBdef : B = bB x.length (p.eval x.length)) + (hHbdef : Hb = bHb x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length)))) + (hbBody : ∀ v, v < N → bodyTime k x (TM.spaceTimeBound M f) H Hb B v + (NTM.tally (enumP L' x) v) (NTM.tally (fun u => !enumP L' x u) v) ≤ bBody) + (hbTest : ∀ v, v < N → testTime B N v ≤ bTest) : + ∃ c', (enumTM M p (bHPoly p s)).reaches ((enumTM M p (bHPoly p s)).initCfg x) c' ∧ + (enumTM M p (bHPoly p s)).halted c' ∧ + (x ∈ polyExistsLang p L' → c'.output.cells 1 = Γ.one) ∧ + (x ∉ polyExistsLang p L' → c'.output.cells 1 = Γ.zero) := by + have hN : 1 ≤ N := by + have h1 : 2 ≤ 2 ^ (p.eval x.length + 1) := by + calc (2 : ℕ) = 2 ^ 1 := by norm_num + _ ≤ 2 ^ (p.eval x.length + 1) := Nat.pow_le_pow_right (by norm_num) (by omega) + omega + have hbounds : ∀ v, v < N → + 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B ∧ + (pair x (dropTop (v + 1))).length + f (pair x (dropTop (v + 1))).length + 2 ≤ Hb ∧ + (pair x (dropTop (v + 1))).length + 1 ≤ H ∧ + 1 + 1 + TM.binaryEqTime (v + 1).bits N.bits ≤ B := by + intro v hv + have hv' : v < 2 ^ (p.eval x.length + 1) - 1 := by rw [← hNdef]; exact hv + obtain ⟨h1, h2, h3, h4, -⟩ := enum_bounds s hs p x v hv' + refine ⟨by rw [hBdef]; exact h1, by rw [hHbdef]; exact h2, by rw [hHdef]; exact h3, ?_⟩ + rw [hBdef, hNdef] + exact h4 + obtain ⟨c', t, -, hreach, hhalt, hout⟩ := + enumTM_hoareTime M hdec hdecS p (bHPoly p s) x N H B Hb bBody bTest hNdef + (by rw [hHdef, bHPoly_eval]) hN + (by rw [hBdef]; exact one_le_bB _ _) + (by rw [hBdef, bB]; omega) + (by rw [hHbdef]; exact one_le_bHb _ _ _) + (fun v hv => (hbounds v hv).1) (fun v hv => (hbounds v hv).2.1) + (by rw [hHbdef, hHdef]; exact bHb_lt_bH _ _ _) + (fun v hv => (hbounds v hv).2.2.1) hbBody + (fun v hv => (hbounds v hv).2.2.2) hbTest + (Tape.init (x.map Γ.ofBool)) (fun _ => Tape.init ([] : List Γ)) + (Tape.init ([] : List Γ)) ⟨rfl, rfl, rfl⟩ + refine ⟨c', TM.reaches_of_reachesIn hreach, hhalt, ?_, ?_⟩ + · intro hmem + have hb : decide (0 < NTM.tally (enumP L' x) N) = true := + decide_eq_true ((tally_pos_iff_mem L' p x N hNdef).mpr hmem) + rw [hout, NTM.outSlot_cells_one, hb] + rfl + · intro hmem + have hb : decide (0 < NTM.tally (enumP L' x) N) = false := + decide_eq_false (fun hc => hmem ((tally_pos_iff_mem L' p x N hNdef).mp hc)) + rw [hout, NTM.outSlot_cells_one, hb] + rfl + +/-- **The enumerator keeps a polynomial window.** -/ +theorem enumTM_space (M : TM k) {L' : Language} {f : ℕ → ℕ} (s : Polynomial ℕ) + (hs : ∀ n, f n ≤ s.eval n) (hdecS : M.DecidesInSpace L' f) + (hdec : M.DecidesInTime L' (TM.spaceTimeBound M f)) (hne : M.qstart ≠ M.qhalt) + (p : Polynomial ℕ) (x : List Bool) (N H B Hb G W bBody bTest : ℕ) + (hNdef : N = 2 ^ (p.eval x.length + 1) - 1) + (hHdef : H = bH x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length)))) + (hBdef : B = bB x.length (p.eval x.length)) + (hHbdef : Hb = bHb x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length)))) + (hGdef : G = bG x.length (p.eval x.length) (s.eval (bP x.length (p.eval x.length)))) + (hWdef : W = bW ((scratchTargets k).length) x.length (p.eval x.length) + (s.eval (bP x.length (p.eval x.length))) + ((proPoly p (bHPoly p s)).eval x.length) ((epiPoly p).eval x.length)) + (hbBody : ∀ v, v < N → bodyTime k x (TM.spaceTimeBound M f) H Hb B v + (NTM.tally (enumP L' x) v) (NTM.tally (fun u => !enumP L' x u) v) ≤ bBody) + (hbTest : ∀ v, v < N → testTime B N v ≤ bTest) : + ∀ c', (enumTM M p (bHPoly p s)).reaches ((enumTM M p (bHPoly p s)).initCfg x) c' → + c'.WithinDecisionSpace x.length W := by + have hN : 1 ≤ N := by + have h1 : 2 ≤ 2 ^ (p.eval x.length + 1) := by + calc (2 : ℕ) = 2 ^ 1 := by norm_num + _ ≤ 2 ^ (p.eval x.length + 1) := Nat.pow_le_pow_right (by norm_num) (by omega) + omega + have hbounds : ∀ v, v < N → + 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B ∧ + (pair x (dropTop (v + 1))).length + f (pair x (dropTop (v + 1))).length + 2 ≤ Hb ∧ + (pair x (dropTop (v + 1))).length + 1 ≤ H ∧ + 1 + 1 + TM.binaryEqTime (v + 1).bits N.bits ≤ B ∧ + (pair x (dropTop (v + 1))).length + 1 ≤ G := by + intro v hv + have hv' : v < 2 ^ (p.eval x.length + 1) - 1 := by rw [← hNdef]; exact hv + obtain ⟨h1, h2, h3, h4, h5⟩ := enum_bounds s hs p x v hv' + exact ⟨by rw [hBdef]; exact h1, by rw [hHbdef]; exact h2, by rw [hHdef]; exact h3, + by rw [hBdef, hNdef]; exact h4, by rw [hGdef]; exact h5⟩ + have hlenw : ∀ v, v < N → (dropTop (v + 1)).length ≤ p.eval x.length := by + intro v hv + exact dropTop_length_le _ v _ hNdef hv + have hpairle : ∀ v, v < N → + (pair x (dropTop (v + 1))).length ≤ bP x.length (p.eval x.length) := by + intro v hv + rw [pair_length, bP] + have := hlenw v hv + omega + have hloopW := enumLoop_keepsWindowOn M hdec hdecS hne x N H hN (strTape x) + (strTape_parked x) (strTape_startInvariant x) rfl (strTape_startInvariant x).1 + B Hb G W (by rw [hBdef]; exact one_le_bB _ _) (by rw [hHbdef]; exact one_le_bHb _ _ _) + (by rw [hHbdef, hHdef]; exact bHb_lt_bH _ _ _) + (fun v hv => (hbounds v hv).1) (fun v hv => (hbounds v hv).2.1) + (fun v hv => (hbounds v hv).2.2.1) (fun v hv => (hbounds v hv).2.2.2.1) + (by rw [hGdef]; exact one_le_bG _ _ _) (by rw [hGdef, hBdef]; exact bB_le_bG _ _ _) + (by rw [hGdef, hHbdef]; exact bHb_le_bG _ _ _) + (fun v hv => (hbounds v hv).2.2.2.2) + (by rw [hGdef, hWdef]; exact bW_stage1 _ _ _ _ _ _) + (fun v hv => by + rw [hGdef, hWdef] + exact bW_stage2 _ _ _ _ _ _ x (dropTop (v + 1)) rfl (hlenw v hv)) + (by rw [hGdef, hWdef, hBdef]; exact bW_stage3 _ _ _ _ _ _) + (fun v hv => by + rw [hGdef, hWdef] + exact bW_stage4 _ _ _ _ _ _ _ (hpairle v hv)) + (by rw [hGdef, hWdef, hHbdef]; exact bW_stage6 _ _ _ _ _ _) + (fun v hv => by + rw [hGdef, hWdef] + refine bW_stage8 _ _ _ _ _ _ _ _ _ ?_ ?_ ?_ + · exact binarySuccTime_le' _ _ N hNdef + (le_trans (tally_le _ v) (by omega)) + · exact binarySuccTime_le' _ _ N hNdef + (le_trans (tally_le _ v) (by omega)) + · exact binarySuccTime_le' _ _ N hNdef (by omega)) + (fun v hv => by + rw [hGdef, hWdef] + exact bW_stage9 _ _ _ _ _ _ _ (binaryBumpTime_le' _ v N hNdef (by omega))) + (by + rw [hGdef, hWdef, hHdef] + exact bW_stage10 _ _ _ _ _ _ _ rfl) + (fun v hv => by + rw [hGdef, hWdef, hBdef] + exact bW_test _ _ _ _ _ _ N v (binaryEqTime_le' _ v N hNdef (by omega))) + have hloopC := enumLoop_hoareTime M hdec hdecS x N H hN (strTape x) + (strTape_parked x) (strTape_startInvariant x) rfl (strTape_startInvariant x).1 + B Hb bBody bTest (by rw [hBdef]; exact one_le_bB _ _) + (by rw [hHbdef]; exact one_le_bHb _ _ _) + (fun v hv => (hbounds v hv).1) (fun v hv => (hbounds v hv).2.1) + (by rw [hHbdef, hHdef]; exact bHb_lt_bH _ _ _) + (fun v hv => (hbounds v hv).2.2.1) hbBody + (fun v hv => (hbounds v hv).2.2.2.1) hbTest + refine enumTM_keepsWindowOn M p (bHPoly p s) x N H + (NTM.tally (enumP L' x) N) (NTM.tally (fun u => !enumP L' x u) N) W + (fun c hc c' hreach => by + obtain ⟨hst, hpre⟩ := hc + refine hloopW c.input c.work c.output hpre c' ?_ + have hce : (⟨((bodyTM M).loopTM + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, + c.input, c.work, c.output⟩ : Cfg _ _) = c := by + cases c; subst hst; rfl + rw [hce] + exact hreach) + (hloopC.strengthen_post (fun inp work out h => ⟨h.1, h.2.1, by rw [h.2.2, if_pos rfl]⟩)) + (by + have := prologueTM_hoareTime k p (bHPoly p s) x + rw [← hNdef, show (bHPoly p s).eval x.length = H from by rw [hHdef, bHPoly_eval]] at this + exact this) + B (by rw [hBdef, bB]; omega) + (by rw [hWdef]; exact one_le_bW _ _ _ _ _ _) + (by rw [hWdef]; exact bW_copy _ _ _ _ _ _) + (by rw [hWdef, hBdef]; exact bW_rewind _ _ _ _ _ _) + (by + rw [hWdef] + exact le_trans (by + have := prologueTime_le p (bHPoly p s) x.length + omega) (bW_prologue _ _ _ _ _ _)) + (by + rw [hWdef] + refine bW_epilogue _ _ _ _ _ _ _ ?_ + rw [epiPoly_eval] + exact epilogueTime_le (p.eval x.length) _ N hNdef (le_trans (tally_le _ N) (le_refl N))) + +/-- **The two loop budgets exist.** Both are finite suprema over the counter range — they need +not be polynomial, since the loop's *time* never enters the space accounting. -/ +theorem exists_loop_bounds (M : TM k) (f : ℕ → ℕ) (x : List Bool) (L' : Language) + (N H B Hb : ℕ) : + ∃ bBody bTest : ℕ, + (∀ v, v < N → bodyTime k x (TM.spaceTimeBound M f) H Hb B v + (NTM.tally (enumP L' x) v) (NTM.tally (fun u => !enumP L' x u) v) ≤ bBody) ∧ + (∀ v, v < N → testTime B N v ≤ bTest) := + ⟨(Finset.range N).sup (fun v => bodyTime k x (TM.spaceTimeBound M f) H Hb B v + (NTM.tally (enumP L' x) v) (NTM.tally (fun u => !enumP L' x u) v)), + (Finset.range N).sup (fun v => testTime B N v), + fun _ hv => Finset.le_sup (f := fun v => bodyTime k x (TM.spaceTimeBound M f) H Hb B v + (NTM.tally (enumP L' x) v) (NTM.tally (fun u => !enumP L' x u) v)) + (Finset.mem_range.mpr hv), + fun _ hv => Finset.le_sup (f := fun v => testTime B N v) (Finset.mem_range.mpr hv)⟩ + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHEmit.lean b/Complexitylib/Classes/Containments/Internal/PHEmit.lean new file mode 100644 index 00000000..97d4ac27 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHEmit.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHLayout +public import Complexitylib.Models.TuringMachine.Placement.Hoare +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import Complexitylib.Models.TuringMachine.Hoare.RetargetOutput + +/-! +# Building the pair the matrix machine reads + +⚠️ Unreviewed by Bolton + +`TM.pairInputWorkTM` emits `pair first second`, reading the first component off a work tape and +the second off its input tape. The enumerator needs `pair x w` with the witness second, so the +witness has to be what the emitter reads as an input — which `TM.retargetInput` arranges, since it +runs a machine with its input supplied on the last work tape. `TM.retargetOutput` then sends the +emitted pair to a work tape rather than the real output, which a loop body cannot write to. + +The emitter's own contract says only that the pair appears; it says nothing about the tapes it +read. `PolyExists.pairFrame_hoareTime` restates its exact-execution theorem as the contract that +does: both sources come back with their cells intact and their heads left past the content, which +the rewind that follows the stage puts back. + +## Main results + +- `PolyExists.pairFrame_hoareTime` — the emitter's contract, framed +- `PolyExists.emitCore`, `PolyExists.emitTM` — the emitter as a stage of the enumerator +- `PolyExists.emitCore_hoareTime` — the stage's contract, on the three tapes it uses +- `PolyExists.emitTM`, `PolyExists.emitTM_hoareTime` — the same, placed in the layout +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +/-- **The pair emitter, framed.** Beyond the pair, this records what the sources look like when +the stage ends: their cells are untouched and the first component is still readable, its head +having been left past the content. -/ +theorem pairFrame_hoareTime {n : ℕ} (firstIdx : Fin n) (first second : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinput : inp₀ = (Tape.init (second.map Γ.ofBool)).move Dir3.right) + (hsourceHead : (work₀ firstIdx).head = 1) + (hsourceOutput : (work₀ firstIdx).HasOutput first) + (hwork : ∀ i, (work₀ i).StartInvariant ∧ 1 ≤ (work₀ i).head) + (houtput : out₀ = (Tape.init []).move Dir3.right) : + (TM.pairInputWorkTM firstIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp.cells = inp₀.cells ∧ + (work firstIdx).cells = (work₀ firstIdx).cells ∧ + (work firstIdx).HasOutput first ∧ + (∀ i, i ≠ firstIdx → work i = work₀ i) ∧ + out.HasBinaryPrefix (pair first second)) + (TM.pairInputWorkTime first second) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + obtain ⟨c', hreach, hhalt, -, hinpc, -, hcells, hout, hother, hprefix⟩ := + TM.pairInputWorkTM_reachesIn firstIdx first second hinput hsourceHead hsourceOutput + hwork houtput + exact ⟨c', TM.pairInputWorkTime first second, le_refl _, hreach, hhalt, hinpc, hcells, hout, + hother, hprefix⟩ + +/-- The emitter as a three-tape machine: the input copy, the witness it reads as an input, and +the tape the pair is written to. -/ +def emitCore : TM 3 := (TM.retargetInput (TM.pairInputWorkTM (0 : Fin 1))).retargetOutput + +/-- **The emitter stage's contract.** Started with the input copy rewound, the witness in +virtual-input shape, and the target tape blank, it leaves the pair on the target tape and both +sources with their cells intact. -/ +theorem emitCore_hoareTime (x w : List Bool) (X : Tape) + (hXhead : X.head = 1) (hXout : X.HasOutput x) (hXSI : Tape.StartInvariant X) : + emitCore.HoareTime + (fun _inp work out => work 0 = X ∧ + work 1 = (Tape.init (w.map Γ.ofBool)).move Dir3.right ∧ + work 2 = TM.parkedBlank ∧ out = TM.parkedBlank) + (fun _inp work out => (work 0).cells = X.cells ∧ (work 0).HasOutput x ∧ + (work 1).cells = ((Tape.init (w.map Γ.ofBool)).move Dir3.right).cells ∧ + (work 2).HasBinaryPrefix (pair x w) ∧ out = TM.parkedBlank) + (TM.pairInputWorkTime x w) := by + set W : Tape := (Tape.init (w.map Γ.ofBool)).move Dir3.right with hWdef + have hWSI : Tape.StartInvariant W := (TM.startInvariant_initOfBool w).move Dir3.right + have hWhead : 1 ≤ W.head := by rw [hWdef]; exact le_of_eq rfl + have hsource := pairFrame_hoareTime (0 : Fin 1) x w W (fun _ => X) TM.parkedBlank rfl + hXhead hXout (fun _ => ⟨hXSI, le_of_eq hXhead.symm⟩) rfl + have hretarget := TM.retargetInput_hoareTime (TM.pairInputWorkTM (0 : Fin 1)) hsource + (fun inp _ _ hpre => by rw [hpre.1]; exact hWSI) + (fun _ _ _ hpre i => by rw [hpre.2.1]; exact hXSI) + (fun _ _ _ hpre => by + rw [hpre.2.2] + exact (TM.startInvariant_initNil).move Dir3.right) + have hout := TM.retargetOutput_hoareTime _ hretarget + rintro inp work out ⟨h0, h1, h2, ho⟩ + have hfun : (fun i : Fin 1 => work (Fin.castSucc (⟨i.val, by omega⟩ : Fin 2))) + = fun _ : Fin 1 => X := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + rw [hi] + exact h0 + obtain ⟨c', t, ht, hreach, hhalt, hpost, houtEq⟩ := + hout inp work out ⟨⟨h1, hfun, h2⟩, ho⟩ + obtain ⟨vin, innerWork, hpostSrc, hinner, hvin⟩ := hpost + have h00 : c'.work 0 = innerWork 0 := hinner 0 + have h11 : c'.work 1 = vin := hvin + refine ⟨c', t, ht, hreach, hhalt, ?_, ?_, ?_, ?_, houtEq⟩ + · rw [h00] + exact hpostSrc.2.1 + · rw [h00] + exact hpostSrc.2.2.1 + · rw [h11] + exact hpostSrc.1 + · exact hpostSrc.2.2.2.2 + +/-- The emitter placed in the enumerator's layout: it uses the first three tapes, which is where +the input copy, the witness, and the pair sit. -/ +def emitTM (k : ℕ) : TM (enumTapes k) := TM.placeWorkTM 0 (k + 9) emitCore + +theorem placeWorkIdx_zero (k : ℕ) : TM.placeWorkIdx (n := 3) 0 (k + 9) 0 = xIdx k := by + apply Fin.ext + show 0 + 0 = 0 + omega + +theorem placeWorkIdx_one (k : ℕ) : TM.placeWorkIdx (n := 3) 0 (k + 9) 1 = wIdx k := by + apply Fin.ext + show 0 + 1 = 1 + omega + +theorem placeWorkIdx_two (k : ℕ) : TM.placeWorkIdx (n := 3) 0 (k + 9) 2 = y1Idx k := by + apply Fin.ext + show 0 + 2 = 2 + omega + +/-- A tape of the layout is outside the emitter's block exactly when its index is at least +three. -/ +theorem not_inMiddle_iff (k : ℕ) (i : Fin (enumTapes k)) : + ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 i ↔ 3 ≤ i.val := by + constructor + · intro h + by_contra hlt + exact h ⟨Nat.zero_le _, by omega⟩ + · rintro h ⟨-, hlt⟩ + omega + +/-- **The placed emitter's contract.** The three tapes it uses come back as +`PolyExists.emitCore_hoareTime` describes them; every other tape of the layout is untouched. -/ +theorem emitTM_hoareTime (k : ℕ) (x w : List Bool) (X : Tape) + (hXhead : X.head = 1) (hXout : X.HasOutput x) (hXSI : Tape.StartInvariant X) + (extras : Fin (enumTapes k) → Tape) + (hinv : ∀ i, ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 i → 1 ≤ (extras i).head) : + (emitTM k).HoareTime + (fun _inp work out => + (∀ i, ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 i → work i = extras i) ∧ + work (xIdx k) = X ∧ + work (wIdx k) = (Tape.init (w.map Γ.ofBool)).move Dir3.right ∧ + work (y1Idx k) = TM.parkedBlank ∧ out = TM.parkedBlank) + (fun _inp work out => + (∀ i, ¬ TM.placeWorkInMiddle (post := k + 9) 0 3 i → work i = extras i) ∧ + (work (xIdx k)).cells = X.cells ∧ (work (xIdx k)).HasOutput x ∧ + (work (wIdx k)).cells = ((Tape.init (w.map Γ.ofBool)).move Dir3.right).cells ∧ + (work (y1Idx k)).HasBinaryPrefix (pair x w) ∧ out = TM.parkedBlank) + (TM.pairInputWorkTime x w) := by + have h := TM.placeWorkTM_hoareTime emitCore (emitCore_hoareTime x w X hXhead hXout hXSI) + 0 (k + 9) extras hinv hhead + rintro inp work out ⟨hframe, hX, hW, hY, ho⟩ + obtain ⟨c', t, ht, hreach, hhalt, hframe', hpost⟩ := + h inp work out ⟨hframe, + by show work (TM.placeWorkIdx (n := 3) 0 (k + 9) 0) = X + rw [placeWorkIdx_zero k]; exact hX, + by show work (TM.placeWorkIdx (n := 3) 0 (k + 9) 1) + = (Tape.init (w.map Γ.ofBool)).move Dir3.right + rw [placeWorkIdx_one k]; exact hW, + by show work (TM.placeWorkIdx (n := 3) 0 (k + 9) 2) = TM.parkedBlank + rw [placeWorkIdx_two k]; exact hY, ho⟩ + exact ⟨c', t, ht, hreach, hhalt, hframe', + by rw [← placeWorkIdx_zero k]; exact hpost.1, + by rw [← placeWorkIdx_zero k]; exact hpost.2.1, + by rw [← placeWorkIdx_one k]; exact hpost.2.2.1, + by rw [← placeWorkIdx_two k]; exact hpost.2.2.2.1, hpost.2.2.2.2⟩ + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHEpilogue.lean b/Complexitylib/Classes/Containments/Internal/PHEpilogue.lean new file mode 100644 index 00000000..cf400baa --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHEpilogue.lean @@ -0,0 +1,375 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHLoop +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub + +/-! +# The enumerator's epilogue + +⚠️ Unreviewed by Bolton + +The loop leaves the accepting tally on `PolyExists.aIdx`, and the answer is whether it is +positive. A machine has no `>`; it has subtraction and a test against zero. So the epilogue makes +a one on the permanently blank tape, subtracts the tally from it — the difference is zero exactly +when the tally is positive — and tests that difference against zero, publishing the answer. + +The two tapes it borrows for the test are the emitter's target and the matrix machine's input: +both are blank once the loop's last wipe has run, and nothing reads them again. + +## Main results + +- `PolyExists.epilogueTM` — the epilogue, and `PolyExists.epilogueTime` its running time +- `PolyExists.epilogueTM_hoareTime` — its contract: the slot ends holding `decide (0 < a)` +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- The epilogue's arithmetic: make a one, subtract the accepting tally from it. -/ +def epiloguePreTM (k : ℕ) : TM (enumTapes k) := + TM.bigSeqTM [TM.binarySuccTM (zIdx k), + TM.binaryRippleSubTM (zIdx k) (aIdx k) (resIdx k)] + +/-- The epilogue's tail: put the test's answer at cell one and publish it. -/ +def epiloguePostTM (k : ℕ) : TM (enumTapes k) := + TM.seqTM (TM.bigSeqTM ([yIdx k].map TM.rewindWorkTM)) (TM.writeOutputBitTM (yIdx k)) + +/-- **The enumerator's epilogue.** -/ +def epilogueTM (k : ℕ) : TM (enumTapes k) := + TM.seqTM (epiloguePreTM k) + (TM.seqTM (TM.binaryEqTM (resIdx k) (y1Idx k) (yIdx k)) (epiloguePostTM k)) + +/-- The bank the epilogue's arithmetic leaves behind. -/ +def epilogueBank (k : ℕ) (x : List Bool) (N H A R : ℕ) : Fin (enumTapes k) → Tape := + Function.update (Function.update (enumBank k x N H N A R) (zIdx k) (natTape 1)) + (resIdx k) (natTape (1 - A)) + +theorem epilogueBank_parked (k : ℕ) (x : List Bool) (N H A R : ℕ) (j : Fin (enumTapes k)) : + TM.Parked (epilogueBank k x N H A R j) := by + rw [epilogueBank] + by_cases h1 : j = resIdx k + · rw [h1, Function.update_self] + exact natTape_parked _ + · rw [Function.update_of_ne h1] + by_cases h2 : j = zIdx k + · rw [h2, Function.update_self] + exact natTape_parked _ + · rw [Function.update_of_ne h2] + exact enumBank_parked k x N H N A R j + +theorem epilogueBank_cells_zero (k : ℕ) (x : List Bool) (N H A R : ℕ) + (j : Fin (enumTapes k)) : (epilogueBank k x N H A R j).cells 0 = Γ.start := by + rw [epilogueBank] + by_cases h1 : j = resIdx k + · rw [h1, Function.update_self] + exact NTM.natTape_cells_zero _ + · rw [Function.update_of_ne h1] + by_cases h2 : j = zIdx k + · rw [h2, Function.update_self] + exact NTM.natTape_cells_zero _ + · rw [Function.update_of_ne h2] + exact (enumBank_startInvariant k x N H N A R j).1 + +/-- The state the epilogue's test leaves: every tape parked, and the answer bit sitting at cell +one of the register the test wrote to. -/ +def afterEq (k : ℕ) (b : Bool) (I : Tape) (B : ℕ) : TM.TapePred (enumTapes k) := + fun inp work out => inp = I ∧ out = NTM.outSlot Γw.one ∧ + (∀ j, TM.Parked (work j)) ∧ (∀ j, (work j).cells 0 = Γ.start) ∧ + (work (yIdx k)).head ≤ B ∧ (work (yIdx k)).cells 1 = Γ.ofBool b + +/-- **The epilogue's publication.** Rewind the register holding the test's answer and copy its +bit into the output slot, where the surrounding obligation reads it. -/ +theorem epiloguePostTM_hoareTime (k : ℕ) (b : Bool) (I : Tape) (B : ℕ) (hI : TM.Parked I) : + (epiloguePostTM k).HoareTime + (afterEq k b I B) + (fun _inp _work out => out = NTM.outSlot (TM.readBackWrite (Γ.ofBool b))) + (1 * (B + 3) + 1 + 1 + 1) := by + intro inp work out hpre + obtain ⟨hi, ho, hpark, hzero, hhead, hcell⟩ := hpre + have hIp : TM.Parked inp := by rw [hi]; exact hI + have hOp : TM.Parked out := by rw [ho]; exact NTM.outSlot_parked _ + set W' : Fin (enumTapes k) → Tape := + fun j => if j = yIdx k then (⟨1, (work (yIdx k)).cells⟩ : Tape) else work j with hW' + have hW'P : ∀ j, TM.Parked (W' j) := by + intro j + simp only [hW'] + split + · exact ⟨le_refl 1, fun i hi2 => (hpark (yIdx k)).2 i hi2⟩ + · exact hpark j + have hrew : (TM.bigSeqTM ([yIdx k].map TM.rewindWorkTM)).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => inp' = inp ∧ work' = W' ∧ out' = out) + (1 * (B + 3) + 1) := by + refine ((TM.rewindList_hoareTime [yIdx k] (by simp) B inp work out hIp hOp hpark + ?_).strengthen_post ?_).mono_bound (by simp) + · intro j hj + rw [List.mem_singleton.mp hj] + exact ⟨hzero (yIdx k), hhead⟩ + · rintro inp' work' out' ⟨rfl, rfl, hin, hout⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + by_cases hj : j = yIdx k + · rw [hj, hin (yIdx k) (by simp), hW'] + simp + · rw [hout j (by simpa using hj), hW'] + simp [hj] + have htrans : ∀ inp' work' out', (inp' = inp ∧ work' = W' ∧ out' = out) → + (TM.transitionInput inp' = inp ∧ (fun i => TM.transitionTape (work' i)) = W' ∧ + TM.transitionTape out' = out) := by + rintro inp' work' out' ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hIp.read_ne_start, + funext fun i => TM.transitionTape_eq_self (hW'P i).read_ne_start, + TM.transitionTape_eq_self hOp.read_ne_start⟩ + have hpub : (TM.writeOutputBitTM (yIdx k)).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = W' ∧ out' = out) + (fun _inp _work out' => out' = NTM.outSlot (TM.readBackWrite (Γ.ofBool b))) 1 := by + refine (TM.writeOutputBitTM_hoareTime_frame (yIdx k) inp W' out hIp hW'P hOp).strengthen_post + ?_ + rintro inp' work' out' ⟨-, -, hout'⟩ + rw [hout', ho, show (W' (yIdx k)).read = Γ.ofBool b from by + simp only [hW', if_pos rfl] + show (work (yIdx k)).cells 1 = _ + exact hcell] + exact NTM.outSlot_write Γw.one (TM.readBackWrite (Γ.ofBool b)) + exact TM.seqTM_hoareTime _ _ hrew htrans hpub inp work out ⟨rfl, rfl, rfl⟩ + + + +/-- A counter tape holding zero is the blank tape. -/ +theorem natTape_zero_eq : natTape 0 = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show ((Tape.init ((Nat.bits 0).map Γ.ofBool)).move Dir3.right).cells j + = ((Tape.init ([] : List Γ)).move Dir3.right).cells j + rw [show Nat.bits 0 = [] from by simp] + rfl + +/-- Strict order as a truncated subtraction, which is what a machine can test. -/ +theorem lt_iff_succ_sub_zero (r a : ℕ) : r < a ↔ (r + 1) - a = 0 := by omega + + +theorem epilogueBank_res (k : ℕ) (x : List Bool) (N H A R : ℕ) : + epilogueBank k x N H A R (resIdx k) = natTape (1 - A) := by + rw [epilogueBank, Function.update_self] + +theorem epilogueBank_y1 (k : ℕ) (x : List Bool) (N H A R : ℕ) : + epilogueBank k x N H A R (y1Idx k) = TM.blankTape := by + rw [epilogueBank, Function.update_of_ne (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 3 + k + 4; omega)), + Function.update_of_ne (Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 3 + k + 6; omega)), enumBank_y1] + +theorem epilogueBank_y (k : ℕ) (x : List Bool) (N H A R : ℕ) : + epilogueBank k x N H A R (yIdx k) = TM.blankTape := by + rw [epilogueBank, + Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k ≠ 3 + k + 4; omega)), + Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k ≠ 3 + k + 6; omega)), enumBank_y] + +/-- **The epilogue's test.** The difference is zero exactly when the accepting tally is +positive, so comparing it with zero decides the bounded existential. -/ +theorem epilogueEq_hoareTime (k : ℕ) (x : List Bool) (N H A R : ℕ) (I : Tape) (hI : TM.Parked I) + (hIsi : Tape.StartInvariant I) : + (TM.binaryEqTM (resIdx k) (y1Idx k) (yIdx k)).HoareTime + (fun inp work out => inp = I ∧ work = epilogueBank k x N H A R ∧ + out = NTM.outSlot Γw.one) + (afterEq k (decide (0 < A)) I 2) + (TM.binaryEqTime (1 - A).bits (0 : ℕ).bits) := by + have hsz : resIdx k ≠ y1Idx k := Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 2; omega) + have hsc : resIdx k ≠ yIdx k := Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k; omega) + have hzc : y1Idx k ≠ yIdx k := Fin.ne_of_val_ne (by show (2 : ℕ) ≠ 3 + k; omega) + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + set W := epilogueBank k x N H A R with hWdef + have hWP : ∀ j, TM.Parked (W j) := epilogueBank_parked k x N H A R + have hWz : ∀ j, (W j).cells 0 = Γ.start := epilogueBank_cells_zero k x N H A R + have hlhs : (W (resIdx k)).HasBinaryString (1 - A).bits := by + rw [hWdef, epilogueBank_res k x N H A R] + exact (Tape.init_move_right_hasBinaryNat _).2 + have hrhs : (W (y1Idx k)).HasBinaryString (0 : ℕ).bits := by + rw [hWdef, epilogueBank_y1 k x N H A R, + show TM.blankTape = natTape 0 from natTape_zero_eq.symm] + exact (Tape.init_move_right_hasBinaryNat 0).2 + have hres : (W (yIdx k)).HasBinaryPrefix [] := by + rw [hWdef, epilogueBank_y k x N H A R] + refine ⟨rfl, nofun, fun i _ => ?_⟩ + show ((Tape.init ([] : List Γ)).move Dir3.right).cells (i + 1) = Γ.blank + rw [Tape.move_cells, Tape.init_nil_cells_succ] + have hIp : TM.Parked inp := by rw [hi]; exact hI + have hOp : TM.Parked out := by rw [ho]; exact NTM.outSlot_parked _ + rw [hi, hw, ho] + obtain ⟨c', t, ht, hreach, hhalt, hinp', hres', hlhs', hlhsh, hrhs', hrhsh, hother', hout'⟩ := + TM.binaryEqTM_reachesIn_frame (resIdx k) (y1Idx k) (yIdx k) ⟨hsz, hsc, hzc⟩ + (1 - A).bits (0 : ℕ).bits I W (NTM.outSlot Γw.one) hlhs hrhs hres + (by rw [← hi]; exact hIp.read_ne_start) (fun i _ _ _ => (hWP i).read_ne_start) + (NTM.outSlot_parked _).read_ne_start + obtain ⟨-, hSI', -⟩ := TM.startInvariant_reachesIn _ hreach hIsi + (fun j => ⟨hWz j, fun i hi2 => (hWP j).2 i hi2⟩) + ⟨rfl, fun j hj => (NTM.outSlot_parked Γw.one).2 j hj⟩ + have hbits : (decide ((1 - A).bits = (0 : ℕ).bits)) = decide (0 < A) := by + refine decide_eq_decide.mpr ?_ + rw [show (1 - A) = (0 + 1) - A from by omega, lt_iff_succ_sub_zero] + exact ⟨fun h => bits_injective h, fun h => by rw [h]⟩ + refine ⟨c', t, ht, hreach, hhalt, hinp', hout', fun j => ?_, fun j => (hSI' j).1, ?_, ?_⟩ + · refine ⟨?_, fun i hi2 => (hSI' j).2 i hi2⟩ + by_cases h1 : j = yIdx k + · rw [h1, hres'.1]; omega + by_cases h2 : j = resIdx k + · rw [h2]; exact hlhsh + by_cases h3 : j = y1Idx k + · rw [h3]; exact hrhsh + · rw [hother' j h2 h3 h1]; exact (hWP j).1 + · rw [hres'.1] + simp + · rw [hres'.2.1 0 (by simp), ← hbits] + simp + +theorem enumBank_z_eq_natTape (k : ℕ) (x : List Bool) (N H v a r : ℕ) : + enumBank k x N H v a r (zIdx k) = natTape 0 := by + rw [enumBank_z, natTape_zero_eq] + +/-- **The epilogue's arithmetic.** Make a one on the blank tape, then subtract the accepting +tally from it; the difference is zero exactly when that tally is positive. -/ +theorem epiloguePreTM_hoareTime (k : ℕ) (x : List Bool) (N H A R : ℕ) (I : Tape) + (hI : TM.Parked I) : + (epiloguePreTM k).HoareTime + (fun inp work out => inp = I ∧ work = enumBank k x N H N A R ∧ + out = NTM.outSlot Γw.one) + (fun inp work out => inp = I ∧ work = epilogueBank k x N H A R ∧ + out = NTM.outSlot Γw.one) + (2 * (max (TM.binarySuccTime 0) (TM.binaryRippleSubTime 1 A) + 1) + 1) := by + set B0 := enumBank k x N H N A R with hB0 + set B1 := Function.update B0 (zIdx k) (natTape 1) with hB1 + have hB1P : ∀ i, TM.Parked (B1 i) := by + intro i + rw [hB1] + by_cases h : i = zIdx k + · rw [h, Function.update_self] + exact natTape_parked _ + · rw [Function.update_of_ne h] + exact enumBank_parked k x N H N A R i + have hstage : ∀ j, (hj : j < [TM.binarySuccTM (zIdx k), + TM.binaryRippleSubTM (zIdx k) (aIdx k) (resIdx k)].length) → + ([TM.binarySuccTM (zIdx k), + TM.binaryRippleSubTM (zIdx k) (aIdx k) (resIdx k)][j]).HoareTime + (fun inp work out => inp = I ∧ + work = (if j = 0 then B0 else B1) ∧ out = NTM.outSlot Γw.one) + (fun inp work out => inp = I ∧ + work = (if j + 1 = 0 then B0 else if j + 1 = 1 then B1 else + epilogueBank k x N H A R) ∧ out = NTM.outSlot Γw.one) + (max (TM.binarySuccTime 0) (TM.binaryRippleSubTime 1 A)) := by + intro j hj + match j, hj with + | 0, _ => + show (TM.binarySuccTM (zIdx k)).HoareTime _ _ _ + refine ((TM.binarySuccTM_hoareTime_pinned (zIdx k) 0 I B0 (NTM.outSlot Γw.one) + (enumBank_z_eq_natTape k x N H N A R) hI.read_ne_start + (fun i _ => (enumBank_parked k x N H N A R i).read_ne_start) + (NTM.outSlot_parked _).read_ne_start).consequence + (fun _ _ _ h => ⟨h.1, by rw [h.2.1]; rfl, h.2.2⟩) ?_ (le_max_left _ _)) + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw] + show Function.update B0 (zIdx k) (natTape (0 + 1)) = B1 + rw [hB1] + | 1, _ => + show (TM.binaryRippleSubTM (zIdx k) (aIdx k) (resIdx k)).HoareTime _ _ _ + have hdist : TM.BinaryRippleSubDistinct (zIdx k) (aIdx k) (resIdx k) := + ⟨Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 5; omega), + Fin.ne_of_val_ne (by show 3 + k + 6 ≠ 3 + k + 4; omega), + Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 4; omega)⟩ + have hz : B1 (zIdx k) = natTape 1 := by rw [hB1, Function.update_self] + have ha : B1 (aIdx k) = natTape A := by + rw [hB1, Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 5 ≠ 3 + k + 6; omega)), + hB0, enumBank_a] + have hres : (B1 (resIdx k)).HasBinaryNat 0 := by + rw [hB1, Function.update_of_ne (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 6; omega)), + hB0, enumBank_blank k x N H N A R _ (res_ne_regs k).1 (res_ne_regs k).2.1 + (res_ne_regs k).2.2 + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 0; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 1; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 3; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 7; omega)), + ← natTape_zero_eq] + exact Tape.init_move_right_hasBinaryNat 0 + refine ((TM.binaryRippleSubTM_hoareTime_pinned (zIdx k) (aIdx k) (resIdx k) hdist 1 A + I B1 (NTM.outSlot Γw.one) hz ha hres hI + (fun i _ _ _ => hB1P i) (NTM.outSlot_parked _)).consequence + (fun _ _ _ h => h) ?_ (le_max_right _ _)) + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw] + show Function.update B1 (resIdx k) (natTape (1 - A)) = epilogueBank k x N H A R + rw [epilogueBank, hB1] + have h := TM.bigSeqTM_hoareTime_pinned + [TM.binarySuccTM (zIdx k), TM.binaryRippleSubTM (zIdx k) (aIdx k) (resIdx k)] I + (fun j => if j = 0 then B0 else if j = 1 then B1 else epilogueBank k x N H A R) + (fun _ => NTM.outSlot Γw.one) (max (TM.binarySuccTime 0) (TM.binaryRippleSubTime 1 A)) + hI (fun j i => by + dsimp only + split + · exact enumBank_parked k x N H N A R i + · split + · exact hB1P i + · exact epilogueBank_parked k x N H A R i) + (fun _ => NTM.outSlot_parked _) + (fun j hj => by + have := hstage j hj + match j, hj with + | 0, _ => exact this + | 1, _ => exact this) + exact h + +/-- The state between the epilogue's test and its publication survives a phase boundary: every +tape it names is parked, so the boundary is the identity. -/ +theorem afterEq_trans (k : ℕ) (b : Bool) (I : Tape) (B : ℕ) (hI : TM.Parked I) + (inp : Tape) (work : Fin (enumTapes k) → Tape) (out : Tape) + (h : afterEq k b I B inp work out) : + afterEq k b I B (TM.transitionInput inp) (fun i => TM.transitionTape (work i)) + (TM.transitionTape out) := by + obtain ⟨hi, ho, hpark, hzero, hhead, hcell⟩ := h + have hid : ∀ j, TM.transitionTape (work j) = work j := + fun j => TM.transitionTape_eq_self (hpark j).read_ne_start + have hidI : TM.transitionInput inp = inp := by + rw [hi]; exact TM.transitionInput_eq_self hI.read_ne_start + have hidO : TM.transitionTape out = out := by + rw [ho]; exact TM.transitionTape_eq_self (NTM.outSlot_parked _).read_ne_start + rw [hidI, hidO, show (fun i => TM.transitionTape (work i)) = work from funext hid] + exact ⟨hi, ho, hpark, hzero, hhead, hcell⟩ + +/-- The epilogue's running time: its three stages and the two boundaries between them. -/ +def epilogueTime (A : ℕ) : ℕ := + (2 * (max (TM.binarySuccTime 0) (TM.binaryRippleSubTime 1 A) + 1) + 1) + 1 + + (TM.binaryEqTime (1 - A).bits (0 : ℕ).bits + 1 + (1 * (2 + 3) + 1 + 1 + 1)) + +/-- **The epilogue's contract.** From the bank the loop leaves, the machine writes `1` into the +verdict slot exactly when some witness was accepted. -/ +theorem epilogueTM_hoareTime (k : ℕ) (x : List Bool) (N H A R : ℕ) (I : Tape) + (hI : TM.Parked I) (hIsi : Tape.StartInvariant I) : + (epilogueTM k).HoareTime + (fun inp work out => inp = I ∧ work = enumBank k x N H N A R ∧ + out = NTM.outSlot Γw.one) + (fun _inp _work out => + out = NTM.outSlot (TM.readBackWrite (Γ.ofBool (decide (0 < A))))) + (epilogueTime A) := by + have htrans1 : ∀ inp work out, + (inp = I ∧ work = epilogueBank k x N H A R ∧ out = NTM.outSlot Γw.one) → + (TM.transitionInput inp = I ∧ + (fun i => TM.transitionTape (work i)) = epilogueBank k x N H A R ∧ + TM.transitionTape out = NTM.outSlot Γw.one) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hI.read_ne_start, + funext fun i => TM.transitionTape_eq_self (epilogueBank_parked k x N H A R i).read_ne_start, + TM.transitionTape_eq_self (NTM.outSlot_parked _).read_ne_start⟩ + exact TM.seqTM_hoareTime _ _ (epiloguePreTM_hoareTime k x N H A R I hI) htrans1 + (TM.seqTM_hoareTime _ _ (epilogueEq_hoareTime k x N H A R I hI hIsi) + (fun inp work out h => afterEq_trans k (decide (0 < A)) I 2 hI inp work out h) + (epiloguePostTM_hoareTime k (decide (0 < A)) I 2 hI)) + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHLayout.lean b/Complexitylib/Classes/Containments/Internal/PHLayout.lean new file mode 100644 index 00000000..86604eb6 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHLayout.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHParts +public import Complexitylib.Models.TuringMachine.Combinators.Apply +public import Complexitylib.Models.TuringMachine.Subroutines.CopyToVirtualInput +public import Complexitylib.Models.TuringMachine.Subroutines.WipeRewind +public import Complexitylib.Models.TuringMachine.Subroutines.ParkRewind +public import Complexitylib.Models.TuringMachine.Placement + +/-! +# The witness enumerator's tape layout + +⚠️ Unreviewed by Bolton + +Two placements fix where every tape sits, and they have to agree. The pair emitter is +`TM.pairInputWorkTM` on one work tape — the copy of the real input — wrapped so that it reads the +witness as a virtual input and writes onto a work tape; those wrappers append their tapes, so the +witness lands at index one and the emitted pair at index two. The matrix machine is `TM.applyTM` +placed by `TM.placeWorkTM 3 _`, which puts its own `k` scratch tapes at `3 … k + 2`, the input it +reads at `k + 3`, and the verdict it writes at `k + 4`. + +The emitted pair and the input the matrix machine reads are therefore *different* tapes — the two +placements cannot be made to share one — and `TM.copyToVirtualInputTM` moves the pair from the +first to the second, which is exactly the shape `TM.retargetInputStartedCfg` demands anyway. + +Seven registers follow: the counter, the horizon it is compared against, scratch for that +comparison, the two tallies the counting loop's state carries, a permanently blank tape to blank +slots from, and the unary register that drives the wipe. + +## Main results + +- `PolyExists.enumTapes` — the tape count, and the named indices into it +- `PolyExists.enumIdx_distinct` — the indices are pairwise distinct +- `PolyExists.matrixTapes` — the matrix machine's own scratch tapes +- `PolyExists.scratchTargets`, `PolyExists.scratchTargets_nodup` — the tapes the body blanks on + its way out +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- The enumerator's tape count: three for the emitter, the matrix machine's `k + 2`, and six +registers. -/ +abbrev enumTapes (k : ℕ) : ℕ := 3 + (k + 2) + 7 + +/-- The copy of the real input, which the emitter reads as the pair's first component. -/ +def xIdx (k : ℕ) : Fin (enumTapes k) := ⟨0, by show 0 < 3 + (k + 2) + 7; omega⟩ + +/-- The witness, which the emitter reads as the pair's second component. -/ +def wIdx (k : ℕ) : Fin (enumTapes k) := ⟨1, by show 1 < 3 + (k + 2) + 7; omega⟩ + +/-- The tape the emitter writes the pair onto. -/ +def y1Idx (k : ℕ) : Fin (enumTapes k) := ⟨2, by show 2 < 3 + (k + 2) + 7; omega⟩ + +/-- The tape the matrix machine reads its input from. -/ +def yIdx (k : ℕ) : Fin (enumTapes k) := ⟨3 + k, by show 3 + k < 3 + (k + 2) + 7; omega⟩ + +/-- The tape the matrix machine's verdict is redirected to. -/ +def vIdx (k : ℕ) : Fin (enumTapes k) := ⟨3 + k + 1, by show 3 + k + 1 < 3 + (k + 2) + 7; omega⟩ + +/-- The counter, whose value denotes the witness. -/ +def cIdx (k : ℕ) : Fin (enumTapes k) := ⟨3 + k + 2, by show 3 + k + 2 < 3 + (k + 2) + 7; omega⟩ + +/-- The horizon the counter is compared against. -/ +def nIdx (k : ℕ) : Fin (enumTapes k) := ⟨3 + k + 3, by show 3 + k + 3 < 3 + (k + 2) + 7; omega⟩ + +/-- Scratch space for that comparison. -/ +def resIdx (k : ℕ) : Fin (enumTapes k) := + ⟨3 + k + 4, by show 3 + k + 4 < 3 + (k + 2) + 7; omega⟩ + +/-- The latched answer: `1` once some witness has been accepted. -/ +def aIdx (k : ℕ) : Fin (enumTapes k) := ⟨3 + k + 5, by show 3 + k + 5 < 3 + (k + 2) + 7; omega⟩ + +/-- A permanently blank tape, read whenever a slot must be blanked. -/ +def zIdx (k : ℕ) : Fin (enumTapes k) := ⟨3 + k + 6, by show 3 + k + 6 < 3 + (k + 2) + 7; omega⟩ + +/-- The unary register that drives the wipe. -/ +def regIdx (k : ℕ) : Fin (enumTapes k) := + ⟨3 + k + 7, by show 3 + k + 7 < 3 + (k + 2) + 7; omega⟩ + +/-- The count of witnesses that failed, which the counting loop's state carries alongside the +count of those that succeeded. -/ +def rIdx (k : ℕ) : Fin (enumTapes k) := + ⟨3 + k + 8, by show 3 + k + 8 < 3 + (k + 2) + 7; omega⟩ + +/-- The matrix machine's own scratch tapes: the block `TM.placeWorkTM 3 _` puts them in. -/ +def matrixTapes (k : ℕ) : List (Fin (enumTapes k)) := + (List.finRange (enumTapes k)).filter (fun j => decide (3 ≤ j.val ∧ j.val < 3 + k)) + +@[simp] theorem mem_matrixTapes_iff (k : ℕ) (j : Fin (enumTapes k)) : + j ∈ matrixTapes k ↔ (3 ≤ j.val ∧ j.val < 3 + k) := by + simp [matrixTapes, List.mem_filter] + +theorem matrixTapes_nodup (k : ℕ) : (matrixTapes k).Nodup := + (List.nodup_finRange _).filter _ + +/-- The tapes one pass of the body leaves dirty, and must blank before the next: the emitted +pair, the matrix machine's scratch and its two placed tapes, and the verdict slot. -/ +def scratchTargets (k : ℕ) : List (Fin (enumTapes k)) := + y1Idx k :: matrixTapes k ++ [yIdx k, vIdx k] + +/-- The scratch block has no repeats, which the wipe requires of its targets. -/ +theorem scratchTargets_nodup (k : ℕ) : (scratchTargets k).Nodup := by + have hy : yIdx k ∉ matrixTapes k := by + intro h + have := ((mem_matrixTapes_iff k _).mp h).2 + simp only [yIdx] at this + omega + have hv : vIdx k ∉ matrixTapes k := by + intro h + have := ((mem_matrixTapes_iff k _).mp h).2 + simp only [vIdx] at this + omega + have hyv : yIdx k ≠ vIdx k := fun h => by + have h' := congrArg Fin.val h + simp only [yIdx, vIdx] at h' + omega + have h1 : y1Idx k ∉ matrixTapes k := by + intro h + have := ((mem_matrixTapes_iff k _).mp h).1 + simp only [y1Idx] at this + omega + refine List.nodup_cons.mpr ⟨?_, List.nodup_append.mpr ⟨matrixTapes_nodup k, ?_, ?_⟩⟩ + · intro hmem + rcases List.mem_append.mp hmem with h | h + · exact h1 h + · rcases List.mem_cons.mp h with h | h + · have h' := congrArg Fin.val h + simp only [y1Idx, yIdx] at h' + omega + · rcases List.mem_cons.mp h with h | h + · have h' := congrArg Fin.val h + simp only [y1Idx, vIdx] at h' + omega + · exact absurd h (List.not_mem_nil) + · refine List.nodup_cons.mpr ⟨?_, ?_⟩ + · simpa using hyv + · exact List.nodup_singleton _ + · intro a ha b hb hab + rcases List.mem_cons.mp hb with h | h + · exact hy (h ▸ hab ▸ ha) + · rcases List.mem_cons.mp h with h | h + · exact hv (h ▸ hab ▸ ha) + · exact absurd h (List.not_mem_nil) + +/-- Every tape the body wipes lies in the block between the emitter's target and the verdict +tape — which is exactly the part of the layout that rests blank. -/ +theorem scratchTargets_val (k : ℕ) (j : Fin (enumTapes k)) (h : j ∈ scratchTargets k) : + 2 ≤ j.val ∧ j.val < 3 + k + 2 := by + rw [scratchTargets] at h + rcases List.mem_cons.mp h with h | h + · rw [h] + exact ⟨by show (2 : ℕ) ≤ 2; omega, by show (2 : ℕ) < 3 + k + 2; omega⟩ + · rcases List.mem_append.mp h with h | h + · have := (mem_matrixTapes_iff k j).mp h + omega + · rcases List.mem_cons.mp h with h | h + · rw [h] + exact ⟨by show (2 : ℕ) ≤ 3 + k; omega, by show 3 + k < 3 + k + 2; omega⟩ + · rcases List.mem_cons.mp h with h | h + · rw [h] + exact ⟨by show (2 : ℕ) ≤ 3 + k + 1; omega, by show 3 + k + 1 < 3 + k + 2; omega⟩ + · exact absurd h (List.not_mem_nil) + + +/-- **The named indices are pairwise distinct.** Every frame lemma the assembly uses asks for +some of these disequalities; this states all of them at once. -/ +theorem enumIdx_distinct (k : ℕ) : + xIdx k ≠ wIdx k ∧ xIdx k ≠ y1Idx k ∧ xIdx k ≠ yIdx k ∧ xIdx k ≠ vIdx k ∧ + xIdx k ≠ cIdx k ∧ xIdx k ≠ nIdx k ∧ xIdx k ≠ resIdx k ∧ xIdx k ≠ aIdx k ∧ + xIdx k ≠ zIdx k ∧ xIdx k ≠ regIdx k ∧ + wIdx k ≠ y1Idx k ∧ wIdx k ≠ yIdx k ∧ wIdx k ≠ vIdx k ∧ wIdx k ≠ cIdx k ∧ + wIdx k ≠ nIdx k ∧ wIdx k ≠ resIdx k ∧ wIdx k ≠ aIdx k ∧ wIdx k ≠ zIdx k ∧ + wIdx k ≠ regIdx k ∧ + y1Idx k ≠ yIdx k ∧ y1Idx k ≠ vIdx k ∧ y1Idx k ≠ cIdx k ∧ y1Idx k ≠ nIdx k ∧ + y1Idx k ≠ resIdx k ∧ y1Idx k ≠ aIdx k ∧ y1Idx k ≠ zIdx k ∧ y1Idx k ≠ regIdx k ∧ + yIdx k ≠ vIdx k ∧ yIdx k ≠ cIdx k ∧ yIdx k ≠ nIdx k ∧ yIdx k ≠ resIdx k ∧ + yIdx k ≠ aIdx k ∧ yIdx k ≠ zIdx k ∧ yIdx k ≠ regIdx k ∧ + vIdx k ≠ cIdx k ∧ vIdx k ≠ nIdx k ∧ vIdx k ≠ resIdx k ∧ vIdx k ≠ aIdx k ∧ + vIdx k ≠ zIdx k ∧ vIdx k ≠ regIdx k ∧ + cIdx k ≠ nIdx k ∧ cIdx k ≠ resIdx k ∧ cIdx k ≠ aIdx k ∧ cIdx k ≠ zIdx k ∧ + cIdx k ≠ regIdx k ∧ + nIdx k ≠ resIdx k ∧ nIdx k ≠ aIdx k ∧ nIdx k ≠ zIdx k ∧ nIdx k ≠ regIdx k ∧ + resIdx k ≠ aIdx k ∧ resIdx k ≠ zIdx k ∧ resIdx k ≠ regIdx k ∧ + aIdx k ≠ zIdx k ∧ aIdx k ≠ regIdx k ∧ + zIdx k ≠ regIdx k ∧ + xIdx k ≠ rIdx k ∧ wIdx k ≠ rIdx k ∧ y1Idx k ≠ rIdx k ∧ yIdx k ≠ rIdx k ∧ + vIdx k ≠ rIdx k ∧ cIdx k ≠ rIdx k ∧ nIdx k ≠ rIdx k ∧ resIdx k ≠ rIdx k ∧ + aIdx k ≠ rIdx k ∧ zIdx k ≠ rIdx k ∧ regIdx k ≠ rIdx k := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, + ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, + ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, + ?_⟩ <;> + exact fun h => by + have h' := congrArg Fin.val h + simp only [xIdx, wIdx, y1Idx, yIdx, vIdx, cIdx, nIdx, resIdx, aIdx, zIdx, regIdx, + rIdx] at h' + omega + +/-- The registers and the input copy are outside the scratch block, so the wipe leaves them +alone. -/ +theorem not_mem_scratchTargets (k : ℕ) : + xIdx k ∉ scratchTargets k ∧ wIdx k ∉ scratchTargets k ∧ cIdx k ∉ scratchTargets k ∧ + nIdx k ∉ scratchTargets k ∧ resIdx k ∉ scratchTargets k ∧ aIdx k ∉ scratchTargets k ∧ + zIdx k ∉ scratchTargets k ∧ regIdx k ∉ scratchTargets k ∧ rIdx k ∉ scratchTargets k := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ <;> + simp +decide [scratchTargets, xIdx, wIdx, cIdx, nIdx, resIdx, aIdx, zIdx, regIdx, rIdx, + y1Idx, yIdx, vIdx, Fin.ext_iff] <;> omega + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHLoop.lean b/Complexitylib/Classes/Containments/Internal/PHLoop.lean new file mode 100644 index 00000000..e0b7380c --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHLoop.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHBody +public import Complexitylib.Classes.Containments.Internal.PPTest + +/-! +# The enumerator's loop + +⚠️ Unreviewed by Bolton + +The pass of `PolyExists.bodyTM` and the counting loop's own test are the two obligations of +`NTM.tallyLoop_hoareTime_of_hoare_indexed`. The test is the *same machine* the path-counting +machine of `PP ⊆ PSPACE` uses — `TM.tallyTestTM` compares the counter with the horizon and +publishes the answer, and its contract is generic in the bank — so only the body has to be +matched to the loop's state. + +That matching is an identity: the loop's state at index `v` names the counter `v` and the two +tallies of `PolyExists.enumP` below, over the bank `PolyExists.enumRest` at `v + 1`, which is +exactly `PolyExists.enumBank`. + +## Main results + +- `PolyExists.enumP` — the predicate the loop tallies: does the witness this count denotes work? +- `PolyExists.enumBody_hoareTime` — the pass, as the loop rule's body obligation +- `PolyExists.enumTest_hoareTime` — the test, as the loop rule's test obligation +- `PolyExists.enumLoop_hoareTime` — the two composed: the loop's contract +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +open Classical in +/-- The predicate the enumerator's loop tallies: whether the witness a count denotes puts the +pair in the matrix language. The count is shifted by one — the witness at count `v` is the one +`v + 1` denotes — which is what makes every witness of the admitted lengths appear. -/ +noncomputable def enumP (L' : Language) (x : List Bool) (v : ℕ) : Bool := + decide (pair x (dropTop (v + 1)) ∈ L') + +theorem enumP_iff (L' : Language) (x : List Bool) (v : ℕ) : + enumP L' x v = true ↔ pair x (dropTop (v + 1)) ∈ L' := by + classical + rw [enumP, decide_eq_true_iff] + +/-- One more tally step, in the shape the pass produces. -/ +theorem tally_succ_pos (P : ℕ → Bool) (v : ℕ) : + NTM.tally P v + (if P v then 1 else 0) = NTM.tally P (v + 1) := rfl + +/-- And the same for the failing tally, whose bump is the complementary one. -/ +theorem tally_succ_neg (P : ℕ → Bool) (v : ℕ) : + NTM.tally (fun u => !P u) v + (if P v then 0 else 1) + = NTM.tally (fun u => !P u) (v + 1) := by + show _ = NTM.tally (fun u => !P u) v + (if !P v then 1 else 0) + cases hp : P v <;> simp + +/-- **The pass, as the loop rule's body obligation.** The loop's state at index `v` *is* the bank +the pass starts from, and the state the pass leaves is the loop's state at `v + 1`. -/ +theorem enumBody_hoareTime (M : TM k) {L' : Language} {T S : ℕ → ℕ} + (hdec : M.DecidesInTime L' T) (hdecS : M.DecidesInSpace L' S) + (x : List Bool) (N H v : ℕ) (I : Tape) (hI : TM.Parked I) (hISI : Tape.StartInvariant I) + (hIhead : I.head = 1) (hIz : I.cells 0 = Γ.start) + (B Hb : ℕ) (hB : 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) (hB1 : 1 ≤ B) + (hHb1 : 1 ≤ Hb) + (hHS : (pair x (dropTop (v + 1))).length + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) + (hHbH : Hb + 1 ≤ H) (hpairH : (pair x (dropTop (v + 1))).length + 1 ≤ H) : + (bodyTM M).HoareTime + (NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H (v + 1)) (enumP L' x) v) + (fun inp work out => inp = I ∧ + work = enumBank k x N H (v + 1) (NTM.tally (enumP L' x) (v + 1)) + (NTM.tally (fun u => !enumP L' x u) (v + 1)) ∧ + out = TM.blankTape) + (bodyTime k x T H Hb B v (NTM.tally (enumP L' x) v) + (NTM.tally (fun u => !enumP L' x u) v)) := by + have h := bodyTM_hoareTime M hdec hdecS x N H v (NTM.tally (enumP L' x) v) + (NTM.tally (fun u => !enumP L' x u) v) I hI hISI hIhead hIz B Hb hB hB1 hHb1 hHS + hHbH hpairH (enumP L' x v) (enumP_iff L' x v) + refine h.consequence (fun _ _ _ hp => hp) (fun inp work out hp => ?_) (le_refl _) + obtain ⟨hi, hw, ho⟩ := hp + refine ⟨hi, ?_, ho⟩ + rw [hw, tally_succ_pos, tally_succ_neg] + +theorem enumRest_cells_zero (k : ℕ) (x : List Bool) (N H v : ℕ) (i : Fin (enumTapes k)) : + (enumRest k x N H v i).cells 0 = Γ.start := by + rw [enumRest] + split + · exact strTape_cells_zero x + · split + · exact strTape_cells_zero _ + · split + · exact NTM.natTape_cells_zero N + · split + · rfl + · exact TM.blankTape_startInvariant.1 + +@[simp] theorem enumRest_res (k : ℕ) (x : List Bool) (N H v : ℕ) : + enumRest k x N H v (resIdx k) = TM.blankTape := + enumRest_blank k x N H v _ + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 0; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 1; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 3; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 7; omega)) + +/-- **The test, as the loop rule's test obligation.** The counting machine's own test serves the +enumerator unchanged: its contract is generic in the bank, and the enumerator's bank meets it. -/ +theorem enumTest_hoareTime {L' : Language} (k : ℕ) (x : List Bool) (N H v : ℕ) (I : Tape) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) (B : ℕ) + (hB : 1 + 1 + TM.binaryEqTime (v + 1).bits N.bits ≤ B) : + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).HoareTime + (fun inp work out => inp = I ∧ + work = enumBank k x N H (v + 1) (NTM.tally (enumP L' x) (v + 1)) + (NTM.tally (fun u => !enumP L' x u) (v + 1)) ∧ + out = TM.blankTape) + (NTM.tallyPost (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H (v + 1 + 1)) + (enumP L' x) N (v + 1)) + (TM.binaryEqTime (v + 1).bits N.bits + 1 + + (3 * (max (3 * (B + 3) + 1) (TM.resetBinaryWorkTime B 1) + 1) + 1)) := by + have hd : TM.BinaryEqDistinct (cIdx k) (nIdx k) (resIdx k) := + ⟨Fin.ne_of_val_ne (by show 3 + k + 2 ≠ 3 + k + 3; omega), + Fin.ne_of_val_ne (by show 3 + k + 2 ≠ 3 + k + 4; omega), + Fin.ne_of_val_ne (by show 3 + k + 3 ≠ 3 + k + 4; omega)⟩ + refine (NTM.tallyTestTM_hoareTime_tallyPost (cIdx k) (aIdx k) (rIdx k) (nIdx k) (resIdx k) + hd + (Fin.ne_of_val_ne (by show 3 + k + 3 ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 3 ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 3 ≠ 3 + k + 8; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 2; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 5; omega)) + (Fin.ne_of_val_ne (by show 3 + k + 4 ≠ 3 + k + 8; omega)) + I (enumRest k x N H (v + 1 + 1)) (enumP L' x) N (v + 1) B 1 hI hIz + (enumRest_parked k x N H (v + 1 + 1)) (enumRest_cells_zero k x N H (v + 1 + 1)) + (enumRest_head k x N H (v + 1 + 1)) (enumRest_n k x N H (v + 1 + 1)) + (by rw [enumRest_res]; rfl) hB).consequence ?_ (fun _ _ _ hp => hp) (le_refl _) + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, hw, by rw [ho, NTM.outSlot_blank_eq_blankTape]⟩ + +/-- The test's running time at one index. -/ +def testTime (B N v : ℕ) : ℕ := + TM.binaryEqTime (v + 1).bits N.bits + 1 + + (3 * (max (3 * (B + 3) + 1) (TM.resetBinaryWorkTime B 1) + 1) + 1) + +/-- **The enumerator's loop.** Every count below the horizon is tested, the tallies come out as +the two counts of `PolyExists.enumP`, and the loop's state ends at the horizon. -/ +theorem enumLoop_hoareTime (M : TM k) {L' : Language} {T S : ℕ → ℕ} + (hdec : M.DecidesInTime L' T) (hdecS : M.DecidesInSpace L' S) + (x : List Bool) (N H : ℕ) (hN : 1 ≤ N) (I : Tape) + (hI : TM.Parked I) (hISI : Tape.StartInvariant I) (hIhead : I.head = 1) + (hIz : I.cells 0 = Γ.start) (B Hb bBody bTest : ℕ) (hB1 : 1 ≤ B) (hHb1 : 1 ≤ Hb) + (hpair : ∀ v, v < N → 1 + TM.pairInputWorkTime x (dropTop (v + 1)) ≤ B) + (hspace : ∀ v, v < N → (pair x (dropTop (v + 1))).length + + S (pair x (dropTop (v + 1))).length + 2 ≤ Hb) + (hHbH : Hb + 1 ≤ H) + (hlenH : ∀ v, v < N → (pair x (dropTop (v + 1))).length + 1 ≤ H) + (hbodyB : ∀ v, v < N → bodyTime k x T H Hb B v (NTM.tally (enumP L' x) v) + (NTM.tally (fun u => !enumP L' x u) v) ≤ bBody) + (heqB : ∀ v, v < N → 1 + 1 + TM.binaryEqTime (v + 1).bits N.bits ≤ B) + (htestB : ∀ v, v < N → testTime B N v ≤ bTest) : + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).HoareTime + (NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H 1) (enumP L' x) 0) + (NTM.tallyPost (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H (N + 1)) (enumP L' x) N N) + (N * (bBody + bTest + 5)) := + NTM.tallyLoop_hoareTime_of_hoare_indexed (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) (cIdx k) (aIdx k) (rIdx k) I + (fun j => enumRest k x N H (j + 1)) (enumP L' x) + (fun v inp work out => inp = I ∧ + work = enumBank k x N H (v + 1) (NTM.tally (enumP L' x) (v + 1)) + (NTM.tally (fun u => !enumP L' x u) (v + 1)) ∧ + out = TM.blankTape) + N bBody bTest hN hI (fun j i => enumRest_parked k x N H (j + 1) i) + (fun v hv => (enumBody_hoareTime M hdec hdecS x N H v I hI hISI hIhead hIz B Hb + (hpair v hv) hB1 hHb1 (hspace v hv) hHbH (hlenH v hv)).mono_bound (hbodyB v hv)) + (fun v inp work out h => by + obtain ⟨hi, hw, ho⟩ := h + exact ⟨by rw [hi]; exact hI, fun i => by + rw [hw]; exact enumBank_parked k x N H (v + 1) _ _ i, + by rw [ho]; exact TM.blankTape_parked, + by rw [ho]; exact TM.blankTape_startInvariant.1, + by rw [ho]; rfl⟩) + (fun v hv => (enumTest_hoareTime (L' := L') k x N H v I hI hIz B + (heqB v hv)).mono_bound (htestB v hv)) + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHLoopWindow.lean b/Complexitylib/Classes/Containments/Internal/PHLoopWindow.lean new file mode 100644 index 00000000..a4cc9dad --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHLoopWindow.lean @@ -0,0 +1,394 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHBodyWindow +public import Complexitylib.Classes.Containments.Internal.PHLoop + +/-! +# The enumerator's loop, in space + +⚠️ Unreviewed by Bolton + +The loop runs exponentially many iterations, so no bound derived from its total running time can +be polynomial. What is polynomial is one iteration, and every state the loop returns to has all +its heads at cell one — that is what `TM.loopTM_keepsWindowOn_phases` turns into a window for the +whole run. + +## Main results + +- `PolyExists.enumTest_keepsWindowOn` — the test's window, straight from its running time +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- **The loop's test keeps a window.** Unlike the body, the test is short: its window is read +off its running time. -/ +theorem enumTest_keepsWindowOn {L' : Language} (k : ℕ) (x : List Bool) (N H v : ℕ) (I : Tape) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) (hIhead : I.head = 1) (B G : ℕ) + (hB : 1 + 1 + TM.binaryEqTime (v + 1).bits N.bits ≤ B) (hG1 : 1 ≤ G) : + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).KeepsWindowOn + (fun c => c.state = (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qstart ∧ + (c.input = I ∧ + c.work = enumBank k x N H (v + 1) (NTM.tally (enumP L' x) (v + 1)) + (NTM.tally (fun u => !enumP L' x u) (v + 1)) ∧ + c.output = TM.blankTape)) + x.length (G + testTime B N v) := + TM.keepsWindowOn_of_hoareTime (h₀ := G) + (enumTest_hoareTime (L' := L') k x N H v I hI hIz B hB) + (fun inp work out hpre i => by + rw [hpre.2.1] + exact enumBank_head_le k x N H (v + 1) _ _ G hG1 i) + (fun inp work out hpre => by rw [hpre.1, hIhead]; omega) + (fun inp work out hpre => by + rw [hpre.2.2] + show (1 : ℕ) ≤ G + 1 + omega) + +open Classical in +/-- The tapes the loop's body is entered on: the counting state at some count below the +horizon. -/ +noncomputable def loopPB (L' : Language) (k : ℕ) (x : List Bool) (N H : ℕ) (I : Tape) : + TM.TapePred (enumTapes k) := fun inp work out => + ∃ j, j < N ∧ NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H (j + 1)) + (enumP L' x) j inp work out + +open Classical in +/-- The tapes the loop's test is entered on: what one pass leaves. -/ +noncomputable def loopPT (L' : Language) (k : ℕ) (x : List Bool) (N H : ℕ) (I : Tape) : + TM.TapePred (enumTapes k) := fun inp work out => + ∃ j, j < N ∧ inp = I ∧ + work = enumBank k x N H (j + 1) (NTM.tally (enumP L' x) (j + 1)) + (NTM.tally (fun u => !enumP L' x u) (j + 1)) ∧ out = TM.blankTape + +open Classical in +/-- The tapes of the rewind-and-check phases: the same bank, with the verdict slot's head on its +way back to cell one. -/ +noncomputable def loopPL (L' : Language) (k : ℕ) (x : List Bool) (N H : ℕ) (I : Tape) : + TM.LoopPhase → TM.TapePred (enumTapes k) := fun ph inp work out => + ∃ j, j ≤ N ∧ inp = I ∧ + work = enumBank k x N H j (NTM.tally (enumP L' x) j) (NTM.tally (fun u => !enumP L' x u) j) ∧ + out.cells = (NTM.outSlot (if j = N then Γw.one else Γw.zero)).cells ∧ + (if ph = TM.LoopPhase.check then out.head = 1 else out.head ≤ 1) + +/-- **Leaving the body.** When the pass halts, the tapes are the ones the test is entered on. -/ +theorem loop_hBT (M : TM k) {L' : Language} {T S : ℕ → ℕ} (hdec : M.DecidesInTime L' T) + (hdecS : M.DecidesInSpace L' S) (x : List Bool) (N H : ℕ) (I : Tape) (hI : TM.Parked I) + (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (hIz : I.cells 0 = Γ.start) + (B Hb : ℕ) (hB1 : 1 ≤ B) (hHb1 : 1 ≤ Hb) (hHbH : Hb + 1 ≤ H) + (hpair : ∀ j, j < N → 1 + TM.pairInputWorkTime x (dropTop (j + 1)) ≤ B) + (hspace : ∀ j, j < N → (pair x (dropTop (j + 1))).length + + S (pair x (dropTop (j + 1))).length + 2 ≤ Hb) + (hlenH : ∀ j, j < N → (pair x (dropTop (j + 1))).length + 1 ≤ H) : + ∀ (c c' : Cfg (enumTapes k) + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).Q), + c.state = Sum.inl (bodyTM M).qhalt → + (∃ d : Cfg (enumTapes k) (bodyTM M).Q, d.state = (bodyTM M).qstart ∧ + loopPB L' k x N H I d.input d.work d.output ∧ + (bodyTM M).reaches d ⟨(bodyTM M).qhalt, c.input, c.work, c.output⟩) → + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).step c = some c' → + TM.LoopTapeInv (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + (loopPB L' k x N H I) (loopPT L' k x N H I) (loopPL L' k x N H I) c' := by + rintro c c' hstate ⟨d, hd0, ⟨j, hj, hpre⟩, hreach⟩ hstep + have hbody := enumBody_hoareTime M hdec hdecS x N H j I hI hIsi hIhead hIz B Hb + (hpair j hj) hB1 hHb1 (hspace j hj) hHbH (hlenH j hj) + obtain ⟨e, t, -, hreachE, hhaltE, hpostE⟩ := hbody d.input d.work d.output hpre + have hd : (⟨(bodyTM M).qstart, d.input, d.work, d.output⟩ : + Cfg (enumTapes k) (bodyTM M).Q) = d := Cfg.ext hd0.symm rfl rfl rfl + rw [hd] at hreachE + obtain ⟨s, hreachS⟩ := TM.reaches_to_reachesIn _ hreach + have hhalt2 : (bodyTM M).halted + (⟨(bodyTM M).qhalt, c.input, c.work, c.output⟩ : Cfg (enumTapes k) (bodyTM M).Q) := rfl + have heq := TM.reachesIn_halted_unique hreachE hreachS hhaltE hhalt2 + rw [heq] at hpostE + obtain ⟨hi, hw, ho⟩ := hpostE + have hc : c = TM.loopBodyWrap (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + ⟨(bodyTM M).qhalt, c.input, c.work, c.output⟩ := Cfg.ext hstate rfl rfl rfl + rw [hc, TM.loopTM_body_to_test (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + rfl] at hstep + rw [← Option.some_inj.mp hstep] + refine ⟨fun hcon => absurd hcon (by nofun), fun _ => ⟨j, hj, ?_, ?_, ?_⟩, + fun ph hph => absurd hph (by nofun)⟩ + · show TM.transitionInput c.input = I + rw [hi] + exact TM.transitionInput_eq_self hI.read_ne_start + · show (fun i => TM.transitionTape (c.work i)) = _ + rw [hw] + exact funext fun i => TM.transitionTape_eq_self + (enumBank_parked k x N H (j + 1) _ _ i).read_ne_start + · show TM.transitionTape c.output = TM.blankTape + rw [ho] + exact TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start + +/-- **Leaving the test.** Its verdict sits in the slot, and the loop begins rewinding it. -/ +theorem loop_hTL (M : TM k) {L' : Language} (x : List Bool) (N H : ℕ) (I : Tape) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) (B : ℕ) + (hB : ∀ j, j < N → 1 + 1 + TM.binaryEqTime (j + 1).bits N.bits ≤ B) : + ∀ (c c' : Cfg (enumTapes k) + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).Q), + c.state = Sum.inr (Sum.inr (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qhalt) → + (∃ d : Cfg (enumTapes k) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).Q, + d.state = (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qstart ∧ + loopPT L' k x N H I d.input d.work d.output ∧ + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).reaches d + ⟨(TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qhalt, c.input, c.work, c.output⟩) → + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).step c = some c' → + TM.LoopTapeInv (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + (loopPB L' k x N H I) (loopPT L' k x N H I) (loopPL L' k x N H I) c' := by + rintro c c' hstate ⟨d, hd0, ⟨j, hj, hi, hw, ho⟩, hreach⟩ hstep + have htest := enumTest_hoareTime (L' := L') k x N H j I hI hIz B (hB j hj) + obtain ⟨e, t, -, hreachE, hhaltE, hpostE⟩ := htest d.input d.work d.output ⟨hi, hw, ho⟩ + have hd : (⟨(TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qstart, d.input, d.work, d.output⟩ : + Cfg (enumTapes k) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).Q) = d := + Cfg.ext hd0.symm rfl rfl rfl + rw [hd] at hreachE + obtain ⟨s, hreachS⟩ := TM.reaches_to_reachesIn _ hreach + have hhalt2 : (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).halted + (⟨(TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qhalt, c.input, c.work, c.output⟩ : + Cfg (enumTapes k) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).Q) := rfl + have heq := TM.reachesIn_halted_unique hreachE hreachS hhaltE hhalt2 + rw [heq] at hpostE + obtain ⟨hi', hw', ho'⟩ := hpostE + have hc : c = TM.loopTestWrap (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + ⟨(TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qhalt, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + rw [hc, TM.loopTM_test_to_rewind (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + rfl] at hstep + rw [← Option.some_inj.mp hstep] + refine ⟨fun hcon => absurd hcon (by nofun), fun hcon => absurd hcon (by nofun), + fun ph hph => Or.inr ?_⟩ + have hph' : ph = TM.LoopPhase.rewindOut := by + injection hph with h + injection h with h' + exact h'.symm + refine ⟨j + 1, by omega, ?_, ?_, ?_, ?_⟩ + · show TM.transitionInput c.input = I + rw [hi'] + exact TM.transitionInput_eq_self hI.read_ne_start + · show (fun i => TM.transitionTape (c.work i)) = _ + rw [hw'] + exact funext fun i => TM.transitionTape_eq_self + (enumBank_parked k x N H (j + 1) _ _ i).read_ne_start + · show (TM.transitionTape c.output).cells = _ + rw [ho', TM.transitionTape_eq_self (NTM.outSlot_parked _).read_ne_start] + · rw [hph'] + show (TM.transitionTape c.output).head ≤ 1 + rw [ho', TM.transitionTape_eq_self (NTM.outSlot_parked _).read_ne_start] + exact le_of_eq rfl + +theorem outSlot_cells_startInvariant (s : Γw) (t : Tape) + (hcells : t.cells = (NTM.outSlot s).cells) : Tape.StartInvariant t := by + rw [Tape.StartInvariant, hcells] + exact ⟨rfl, fun j hj => (NTM.outSlot_parked s).2 j hj⟩ + +/-- **The bookkeeping phases.** The rewind moves only the output head; the check either halts the +loop or starts the next pass on the very same tapes. -/ +theorem loop_hLL (M : TM k) {L' : Language} (x : List Bool) (N H : ℕ) (I : Tape) + (hI : TM.Parked I) : + ∀ (c c' : Cfg (enumTapes k) + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).Q) + (ph : TM.LoopPhase), + c.state = Sum.inr (Sum.inl ph) → loopPL L' k x N H I ph c.input c.work c.output → + (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).step c = some c' → + TM.LoopTapeInv (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + (loopPB L' k x N H I) (loopPT L' k x N H I) (loopPL L' k x N H I) c' := by + rintro c c' ph hstate ⟨j, hjN, hi, hw, hcells, hhead⟩ hstep + have hoSI : Tape.StartInvariant c.output := outSlot_cells_startInvariant _ c.output hcells + have hwP : ∀ i, TM.Parked (c.work i) := by + rw [hw] + exact enumBank_parked k x N H j _ _ + have hIp : TM.Parked c.input := by rw [hi]; exact hI + cases ph with + | done => + exact absurd hstep (by + simp only [TM.step, show c.state = (TM.loopTM (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qhalt from hstate, ↓reduceIte] + nofun) + | rewindOut => + rw [if_neg (by nofun : ¬ (TM.LoopPhase.rewindOut = TM.LoopPhase.check))] at hhead + obtain ⟨hin', hwork', hcells', hhead'⟩ := + TM.loop_phase_step_tapes (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + hstate (by nofun) hoSI hstep + obtain ⟨hto, hstay⟩ := TM.loop_rewind_step_state (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) hstate hstep + have hbase : c'.input = I ∧ c'.work = enumBank k x N H j + (NTM.tally (enumP L' x) j) (NTM.tally (fun u => !enumP L' x u) j) ∧ + c'.output.cells = (NTM.outSlot (if j = N then Γw.one else Γw.zero)).cells := by + refine ⟨?_, ?_, by rw [hcells', hcells]⟩ + · rw [hin', hi] + exact TM.transitionInput_eq_self hI.read_ne_start + · funext i + rw [hwork' i, hw] + exact TM.transitionTape_eq_self (enumBank_parked k x N H j _ _ i).read_ne_start + refine ⟨fun hcon => ?_, fun hcon => ?_, fun ph' hph' => Or.inr ?_⟩ + · by_cases hread : c.output.read = Γ.start + · rw [(hto hread).1] at hcon + exact absurd hcon (by nofun) + · rw [hstay hread] at hcon + exact absurd hcon (by nofun) + · by_cases hread : c.output.read = Γ.start + · rw [(hto hread).1] at hcon + exact absurd hcon (by nofun) + · rw [hstay hread] at hcon + exact absurd hcon (by nofun) + · refine ⟨j, hjN, hbase.1, hbase.2.1, hbase.2.2, ?_⟩ + by_cases hread : c.output.read = Γ.start + · have hph2 : ph' = TM.LoopPhase.check := by + rw [(hto hread).1] at hph' + injection hph' with h + injection h with h' + exact h'.symm + rw [hph2] + show c'.output.head = 1 + have hhead0 : c.output.head = 0 := by + by_contra hc0 + exact absurd hread (hoSI.2 c.output.head (by omega)) + have hh := (hto hread).2 + omega + · have hph2 : ph' = TM.LoopPhase.rewindOut := by + rw [hstay hread] at hph' + injection hph' with h + injection h with h' + exact h'.symm + rw [hph2] + show c'.output.head ≤ 1 + have := hhead' + omega + | check => + rw [if_pos rfl] at hhead + have hhead1 : c.output.head = 1 := hhead + have hread : c.output.read ≠ Γ.start := by + show c.output.cells c.output.head ≠ Γ.start + rw [hhead1, hcells] + exact (NTM.outSlot_parked _).2 1 (by omega) + obtain ⟨hin', hwork', hout'⟩ := + TM.loop_check_step_tapes (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) + hstate hread hstep + have hbase : c'.input = I ∧ c'.work = enumBank k x N H j + (NTM.tally (enumP L' x) j) (NTM.tally (fun u => !enumP L' x u) j) ∧ + c'.output = c.output := by + refine ⟨?_, ?_, hout'⟩ + · rw [hin', hi] + exact TM.transitionInput_eq_self hI.read_ne_start + · funext i + rw [hwork' i, hw] + exact TM.transitionTape_eq_self (enumBank_parked k x N H j _ _ i).read_ne_start + by_cases hone : c.output.cells 1 = Γ.one + · obtain ⟨d, hd, hdstate, -⟩ := TM.loopTM_check_halt (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) c hstate hhead1 hone + rw [hd] at hstep + have hc'eq : c' = d := Option.some_inj.mp hstep.symm + refine ⟨fun hcon => absurd (hc'eq ▸ hcon) (by rw [hdstate]; nofun), + fun hcon => absurd (hc'eq ▸ hcon) (by rw [hdstate]; nofun), fun ph' hph' => Or.inl ?_⟩ + rw [hc'eq, hdstate] at hph' + injection hph' with h + injection h with h' + exact h'.symm + · have hnostart : ∀ i, i ≥ 1 → c.output.cells i ≠ Γ.start := by + intro i hi' + rw [hcells] + exact (NTM.outSlot_parked _).2 i hi' + obtain ⟨d, hd, hdstate, -⟩ := TM.loopTM_check_continue (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) c hstate hhead1 hone hnostart + rw [hd] at hstep + have hc'eq : c' = d := Option.some_inj.mp hstep.symm + have hjN' : j ≠ N := by + intro hjeq + rw [hjeq, if_pos rfl] at hcells + exact hone (by rw [hcells]; rfl) + refine ⟨fun _ => ⟨j, by omega, hbase.1, hbase.2.1, + ⟨if j = N then Γw.one else Γw.zero, by rw [if_neg hjN']; nofun, ?_⟩⟩, + fun hcon => absurd (hc'eq ▸ hcon) (by rw [hdstate]; nofun), + fun ph' hph' => absurd (hc'eq ▸ hph') (by rw [hdstate]; nofun)⟩ + rw [hbase.2.2] + exact Tape.ext hhead1 hcells + +/-- **The enumerator's loop keeps a window.** The loop runs exponentially many iterations; what +bounds its space is one iteration's width, and the fact that every state it returns to has all +its heads at cell one. -/ +theorem enumLoop_keepsWindowOn (M : TM k) {L' : Language} {T S : ℕ → ℕ} + (hdec : M.DecidesInTime L' T) (hdecS : M.DecidesInSpace L' S) (hne : M.qstart ≠ M.qhalt) + (x : List Bool) (N H : ℕ) (hN : 1 ≤ N) (I : Tape) (hI : TM.Parked I) + (hIsi : Tape.StartInvariant I) (hIhead : I.head = 1) (hIz : I.cells 0 = Γ.start) + (B Hb G W : ℕ) (hB1 : 1 ≤ B) (hHb1 : 1 ≤ Hb) (hHbH : Hb + 1 ≤ H) + (hpair : ∀ j, j < N → 1 + TM.pairInputWorkTime x (dropTop (j + 1)) ≤ B) + (hspace : ∀ j, j < N → (pair x (dropTop (j + 1))).length + + S (pair x (dropTop (j + 1))).length + 2 ≤ Hb) + (hlenH : ∀ j, j < N → (pair x (dropTop (j + 1))).length + 1 ≤ H) + (heqB : ∀ j, j < N → 1 + 1 + TM.binaryEqTime (j + 1).bits N.bits ≤ B) + (hG1 : 1 ≤ G) (hGB : B ≤ G) (hGHb : Hb + 1 ≤ G) + (hGpair : ∀ j, j < N → (pair x (dropTop (j + 1))).length + 1 ≤ G) + (hW1 : G + 1 ≤ W) + (hW2 : ∀ j, j < N → G + TM.pairInputWorkTime x (dropTop (j + 1)) ≤ W) + (hW3 : G + (1 + 1 + (2 * (max (B + 2) (3 * (B + 3) + 1) + 1) + 1)) ≤ W) + (hW4 : ∀ j, j < N → G + (2 * (pair x (dropTop (j + 1))).length + 5) ≤ W) + (hW6 : G + (1 + 1 + (2 * (max (Hb + 2) (1 * (Hb + 3) + 1) + 1) + 1)) ≤ W) + (hW8 : ∀ j, j < N → G + (3 * (max (1 + 1 + + max (TM.binarySuccTime (NTM.tally (enumP L' x) j)) + (TM.binarySuccTime (NTM.tally (fun u => !enumP L' x u) j)) + 5) + (TM.binarySuccTime j) + 1) + 1) ≤ W) + (hW9 : ∀ j, j < N → G + TM.binaryBumpTime (dropTop (j + 1)) ≤ W) + (hW10 : G + ((scratchTargets k).length * (H + 4) + H * 4 + 8 + 1 + + ((scratchTargets k).length * (H + 4) + 1)) ≤ W) + (hWtest : ∀ j, j < N → G + testTime B N j ≤ W) : + ∀ inp work out, + NTM.tallyPre (cIdx k) (aIdx k) (rIdx k) I (enumRest k x N H 1) (enumP L' x) 0 + inp work out → + ∀ c, (TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).reaches + ⟨(TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, + inp, work, out⟩ c → + c.WithinDecisionSpace x.length W := by + intro inp work out hpre c hreach + have hs : 1 ≤ W := by omega + have hbodyW : (bodyTM M).KeepsWindowOn + (fun d => d.state = (bodyTM M).qstart ∧ loopPB L' k x N H I d.input d.work d.output) + x.length W := by + intro d hd D hD + obtain ⟨j, hj, hpj⟩ := hd.2 + exact bodyTM_keepsWindowOn M hdec hdecS hne x N H j (NTM.tally (enumP L' x) j) + (NTM.tally (fun u => !enumP L' x u) j) I hI hIsi hIhead hIz B Hb G W (hpair j hj) hB1 + hHb1 (hspace j hj) hHbH (hlenH j hj) (enumP L' x j) (enumP_iff L' x j) hG1 hGB hGHb + (hGpair j hj) hW1 (hW2 j hj) hW3 (hW4 j hj) hW6 (hW8 j hj) (hW9 j hj) hW10 + d ⟨hd.1, hpj.1, hpj.2.1, hpj.2.2⟩ D hD + have htestW : (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).KeepsWindowOn + (fun d => d.state = (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)).qstart ∧ + loopPT L' k x N H I d.input d.work d.output) x.length W := by + intro d hd D hD + obtain ⟨j, hj, hpj⟩ := hd.2 + exact ((enumTest_keepsWindowOn (L' := L') k x N H j I hI hIz hIhead B G (heqB j hj) + hG1).mono_space (hWtest j hj)) d ⟨hd.1, hpj.1, hpj.2.1, hpj.2.2⟩ D hD + refine TM.loopTM_keepsWindowOn_phases (bodyTM M) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) hs + (loopPB L' k x N H I) (loopPT L' k x N H I) (loopPL L' k x N H I) hbodyW htestW + (loop_hBT M hdec hdecS x N H I hI hIsi hIhead hIz B Hb hB1 hHb1 hHbH hpair hspace hlenH) + (loop_hTL M x N H I hI hIz B heqB) + (loop_hLL M x N H I hI) + ⟨(TM.loopTM (bodyTM M) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, inp, work, out⟩ + rfl ⟨0, hN, hpre⟩ ?_ ?_ c hreach + · obtain ⟨hi, hw, sy, -, ho⟩ := hpre + exact ⟨⟨fun i => by + rw [hw] + show (enumBank k x N H 0 _ _ i).head ≤ W + rw [enumBank_head] + omega, + by rw [hi, hIhead]; omega⟩, by rw [ho]; show (1 : ℕ) ≤ W + 1; omega⟩ + · obtain ⟨hi, hw, sy, -, ho⟩ := hpre + exact ⟨by rw [hi]; exact hIsi, + fun i => by + rw [hw] + exact enumBank_startInvariant k x N H 0 _ _ i, + by + rw [ho] + exact ⟨rfl, fun j hj => (NTM.outSlot_parked sy).2 j hj⟩⟩ + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHMatrix.lean b/Complexitylib/Classes/Containments/Internal/PHMatrix.lean new file mode 100644 index 00000000..e45402a7 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHMatrix.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHLayout +public import Complexitylib.Models.TuringMachine.Combinators.ApplyDecide +public import Complexitylib.Models.TuringMachine.Hoare.SpaceFrame +public import Complexitylib.Models.TuringMachine.Placement.Window + +/-! +# Running the matrix machine inside the enumerator + +⚠️ Unreviewed by Bolton + +One iteration of the enumerator runs the machine deciding the matrix language on the pair it has +just built. `TM.applyTM` reads that pair off a work tape and writes the verdict onto another, and +`TM.placeWorkTM 3 7` puts the whole thing where the layout says: the matrix machine's own tapes at +`3 … k + 2`, the pair it reads at `PolyExists.yIdx`, the verdict at `PolyExists.vIdx`, and the +enumerator's own tapes untouched on either side. + +The contract below is the placed form of `TM.applyTM_hoareTime_decide_space_frame` — the +space-bounded one, since the width it reports is what the body's wipe has to clear. Besides the +verdict it records what the next iteration needs: the registers came through unchanged, and every +tape of the block is parked inside a window of width `H` with nothing written beyond it — which +is what makes the wipe that follows finite. + +## Main results + +- `PolyExists.matrixTM` — the placed evaluator, and `PolyExists.matrixEntry` the tapes it starts on +- `PolyExists.matrixTM_hoareTime` — its contract, with the frame the loop body needs +- `PolyExists.matrixTM_keepsWindowOn` — its window, from the matrix machine's space bound +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {k : ℕ} + +/-- The matrix machine, reading its input from a work tape and writing its verdict onto another, +placed where the enumerator's layout wants it. -/ +def matrixTM (M : TM k) : TM (enumTapes k) := TM.placeWorkTM 3 7 (TM.applyTM M) + +/-- The tapes the placed evaluator is entered with: its own block loaded with the pair `y`, and +the enumerator's own tapes carried through as they are. -/ +def matrixEntry (M : TM k) (extras : Fin (enumTapes k) → Tape) (y : List Bool) (I : Tape) : + Fin (enumTapes k) → Tape := fun i => + if h : TM.placeWorkInMiddle 3 (k + 2) i then + TM.applyPre M y I (TM.placeWorkCoord 3 (k + 2) i h) + else extras i + +/-- The verdict tape is the placed image of the evaluator's result tape. -/ +theorem placeWorkCoord_vIdx (k : ℕ) (h : TM.placeWorkInMiddle 3 (k + 2) (vIdx k)) : + TM.placeWorkCoord 3 (k + 2) (vIdx k) h = Fin.last (k + 1) := by + apply Fin.ext + show (vIdx k).val - 3 = k + 1 + show 3 + k + 1 - 3 = k + 1 + omega + +theorem vIdx_inMiddle (k : ℕ) : TM.placeWorkInMiddle 3 (k + 2) (vIdx k) := by + constructor + · show 3 ≤ 3 + k + 1 + omega + · show 3 + k + 1 < 3 + (k + 2) + omega + +theorem yIdx_inMiddle (k : ℕ) : TM.placeWorkInMiddle 3 (k + 2) (yIdx k) := by + constructor + · show 3 ≤ 3 + k + omega + · show 3 + k < 3 + (k + 2) + omega + +/-- **One evaluation of the matrix machine, contracted.** From the placed entry tapes the stage +halts inside the matrix machine's own time bound, publishes its verdict on `y` in cell one of the +verdict tape, returns every tape outside its block untouched, and leaves its own block parked +inside a window of width `H`. -/ +theorem matrixTM_hoareTime (M : TM k) {L : Language} {T S : ℕ → ℕ} (hdec : M.DecidesInTime L T) + (hdecS : M.DecidesInSpace L S) + (y : List Bool) (I : Tape) (hI : TM.Parked I) (hISI : Tape.StartInvariant I) + (extras : Fin (enumTapes k) → Tape) + (hinv : ∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → 1 ≤ (extras i).head) + (H : ℕ) (hHS : y.length + S y.length + 2 ≤ H) : + (matrixTM M).HoareTime + (fun inp work out => inp = I ∧ work = matrixEntry M extras y I ∧ out = TM.parkedBlank) + (fun inp work out => inp = I ∧ out = TM.parkedBlank ∧ + (y ∈ L → (work (vIdx k)).cells 1 = Γ.one) ∧ + (y ∉ L → (work (vIdx k)).cells 1 = Γ.zero) ∧ + (∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → work i = extras i) ∧ + (∀ i, TM.placeWorkInMiddle 3 (k + 2) i → + Tape.StartInvariant (work i) ∧ (work i).head ≤ H ∧ + ∀ j, H < j → (work i).cells j = Γ.blank)) + (T y.length) := by + rintro inp work out ⟨hi, hw, ho⟩ + obtain ⟨c', t, ht, hreach, hhalt, hinpEq, houtEq, hverdict, hframe⟩ := + TM.applyTM_hoareTime_decide_space_frame M hdec hdecS y I hI hISI H hHS + I (TM.applyPre M y I) TM.parkedBlank ⟨rfl, rfl, rfl⟩ + refine ⟨TM.placeWorkCfg (TM.applyTM M) 3 7 extras c', t, ht, ?_, hhalt, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · have hstart : (⟨(matrixTM M).qstart, inp, work, out⟩ : + Cfg (enumTapes k) (matrixTM M).Q) = + TM.placeWorkCfg (TM.applyTM M) 3 7 extras + (⟨(TM.applyTM M).qstart, I, TM.applyPre M y I, TM.parkedBlank⟩ : + Cfg (k + 2) (TM.applyTM M).Q) := by + refine Cfg.ext rfl hi (funext fun j => ?_) ho + rw [hw] + show matrixEntry M extras y I j = _ + rw [matrixEntry] + rfl + rw [hstart] + exact TM.placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant (TM.applyTM M) 3 7 extras + hreach hinv hhead + · show c'.input = I + exact hinpEq + · show c'.output = TM.parkedBlank + exact houtEq + · intro hy + show (if h : TM.placeWorkInMiddle 3 (k + 2) (vIdx k) then + c'.work (TM.placeWorkCoord 3 (k + 2) (vIdx k) h) else extras (vIdx k)).cells 1 = Γ.one + rw [dif_pos (vIdx_inMiddle k), placeWorkCoord_vIdx k (vIdx_inMiddle k)] + exact hverdict.1 hy + · intro hy + show (if h : TM.placeWorkInMiddle 3 (k + 2) (vIdx k) then + c'.work (TM.placeWorkCoord 3 (k + 2) (vIdx k) h) else extras (vIdx k)).cells 1 = Γ.zero + rw [dif_pos (vIdx_inMiddle k), placeWorkCoord_vIdx k (vIdx_inMiddle k)] + exact hverdict.2 hy + · intro j hj + show (if h : TM.placeWorkInMiddle 3 (k + 2) j then _ else extras j) = extras j + rw [dif_neg hj] + · intro j hj + have heq : (TM.placeWorkCfg (TM.applyTM M) 3 7 extras c').work j + = c'.work (TM.placeWorkCoord 3 (k + 2) j hj) := by + show (if h : TM.placeWorkInMiddle 3 (k + 2) j then + c'.work (TM.placeWorkCoord 3 (k + 2) j h) else extras j) = _ + rw [dif_pos hj] + rw [heq] + exact hframe _ + +/-- **The evaluating stage's window.** The matrix machine's own space bound is what limits it — +its running time is exponential and would limit nothing. -/ +theorem matrixTM_keepsWindowOn (M : TM k) {L : Language} {S : ℕ → ℕ} + (hdecS : M.DecidesInSpace L S) (hne : M.qstart ≠ M.qhalt) + (y : List Bool) (I : Tape) (hISI : Tape.StartInvariant I) + (extras : Fin (enumTapes k) → Tape) + (hinv : ∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → 1 ≤ (extras i).head) + {inputLength space : ℕ} + (hextraW : ∀ i, ¬ TM.placeWorkInMiddle 3 (k + 2) i → (extras i).head ≤ space) + (hspace : y.length + S y.length + 2 ≤ space) + (hIhead : max I.head 1 ≤ inputLength + (y.length + S y.length + 1) + 1) : + (matrixTM M).KeepsWindowOn + (fun c => c.state = (matrixTM M).qstart ∧ c.input = I ∧ + c.work = matrixEntry M extras y I ∧ c.output = TM.parkedBlank) + inputLength space := by + intro c hc D hD + obtain ⟨hst, hi, hw, ho⟩ := hc + have hentry : c = TM.placeWorkCfg (TM.applyTM M) 3 7 extras + (⟨(TM.applyTM M).qstart, I, TM.applyPre M y I, TM.parkedBlank⟩ : + Cfg (k + 2) (TM.applyTM M).Q) := by + refine Cfg.ext hst hi (funext fun j => ?_) ho + rw [hw] + show matrixEntry M extras y I j = _ + rw [matrixEntry] + rfl + rw [hentry] at hD + refine TM.placeWorkTM_keepsWindow_of_reaches (TM.applyTM M) 3 7 extras _ hinv hhead + hextraW (fun e he => ?_) D hD + have hwin := TM.applyTM_keepsWindow_of_decidesInSpace M hdecS hne y I hISI + (inputLength := inputLength) (space := y.length + S y.length + 1) (le_refl _) hIhead e + (by rw [← TM.applyTM_entry_eq M y I]; exact he) + obtain ⟨⟨hw', hi'⟩, ho'⟩ := hwin + exact ⟨⟨fun i => by have := hw' i; omega, by omega⟩, by omega⟩ + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHParts.lean b/Complexitylib/Classes/Containments/Internal/PHParts.lean new file mode 100644 index 00000000..f9ecaf20 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHParts.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.RetargetWindow +public import Complexitylib.Models.TuringMachine.Subroutines.CopyOutput +public import Complexitylib.Models.TuringMachine.Subroutines.ResetTapes +public import Complexitylib.Models.TuringMachine.Subroutines.PairEmit +public import Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryBump +public import Complexitylib.Classes.Containments.Internal.WitnessEnum + +/-! +# Parts of the witness-enumerating machine + +⚠️ Unreviewed by Bolton + +The machine that will witness `polyExistsClass PSPACE ⊆ PSPACE` copies its input onto a work +tape, then loops over witnesses, building `pair x w` and running the matrix machine on it. This +file records the window contracts of the individual parts, obtained from their existing time +contracts by `TM.keepsWindowOn_of_haltsIn` — no new tape analysis is needed for any of them. + +## Main results + +- `TM.copyInputToOutputTM_keepsWindowOn` — the input-to-output copy stays inside a linear window +- `TM.copyInputToWork_keepsWindow` — and so does its retargeting onto a work tape +- `TM.resetTapes_keepsWindowOn` — the clear-scratch stage keeps a window +- `TM.pairEmitPre`, `TM.pairInputWork_keepsWindowOn` — and so does the pair emitter +- `TM.binarySucc_keepsWindowOn` — and the counter increment +- `bump_eq_bumpLE` — the witness-advancing machine computes the witness enumeration's step +- `TM.binaryBump_keepsWindowOn` — and it keeps a window +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **The input-to-output copy keeps a linear window.** Started on its initial configuration it +halts in `|x| + 2` steps, and a head moves at most one cell per step, so nothing travels past +cell `|x| + 2`. -/ +theorem copyInputToOutputTM_keepsWindowOn (n : ℕ) (x : List Bool) : + (copyInputToOutputTM (n := n)).KeepsWindowOn + (fun c => c = (copyInputToOutputTM (n := n)).initCfg x) + x.length (0 + (x.length + 2)) := by + refine keepsWindowOn_of_haltsIn (fun c hc i => ?_) (fun c hc => ?_) (fun c hc => ?_) + (fun c hc => ?_) + · subst hc + exact Nat.le_of_eq rfl + · subst hc + exact Nat.zero_le _ + · subst hc + exact Nat.zero_le _ + · subst hc + obtain ⟨c', t, hle, hreach, hhalt, -⟩ := copyInputToOutputTM_computesInTime n x + exact ⟨c', t, hle, hreach, hhalt⟩ + +/-- **Redirecting that copy onto a work tape keeps a window too.** This is the stage that puts a +copy of the real input where the pair emitter can delimit it. -/ +theorem copyInputToWork_keepsWindow (n : ℕ) (x : List Bool) : + ∀ D, (copyInputToOutputTM (n := n)).retargetOutput.reaches + ((copyInputToOutputTM (n := n)).retargetCfg + ((copyInputToOutputTM (n := n)).initCfg x)) D → + D.WithinDecisionSpace x.length (0 + (x.length + 2) + 1) := + retargetOutput_keepsWindow_of_reaches _ _ + (fun c hreach => copyInputToOutputTM_keepsWindowOn n x _ rfl c hreach) + + +/-- **The clear-scratch stage keeps a window.** `TM.resetTapesTM` blanks its targets regardless of +their contents, in time linear in the wipe height and the number of targets; converting its +halting bound gives the window directly. This is the stage that makes a loop body robust enough +for `TM.seqTM_keepsWindow_of_post`. -/ +theorem resetTapes_keepsWindowOn {n : ℕ} (targets : List (Fin n)) (hnodup : targets.Nodup) + (r : Fin n) (hr : r ∉ targets) (H : ℕ) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinpSI : Tape.StartInvariant inp₀) (hinpP : Parked inp₀) + (hout0 : out₀ = (Tape.init []).move Dir3.right) + (hworkSI : ∀ j, j ≠ r → Tape.StartInvariant (work₀ j)) + (htargetHead : ∀ j, j ∈ targets → (work₀ j).head ≤ H) + (hworkR : work₀ r = regTape H) + (hother : ∀ j, j ≠ r → j ∉ targets → Parked (work₀ j)) + {inputLength h₀ : ℕ} + (hheads : ∀ i, (work₀ i).head ≤ h₀) + (hinputHead : inp₀.head ≤ inputLength + h₀ + 1) + (houtputHead : out₀.head ≤ h₀ + 1) : + (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)).KeepsWindowOn + (fun c => c.state = (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)).qstart ∧ + (c.input = inp₀ ∧ c.work = work₀ ∧ c.output = out₀)) + inputLength (h₀ + (targets.length * (H + 4) + H * 4 + 8)) := + keepsWindowOn_of_hoareTime_pinned + (resetTapes_hoareTime targets hnodup r hr H inp₀ work₀ out₀ hinpSI hinpP hout0 hworkSI + htargetHead hworkR hother) + hheads hinputHead houtputHead + + +/-- The pair emitter's precondition, strengthened with the head bound its own contract omits. -/ +def pairEmitPre {n : ℕ} (firstIdx : Fin n) (first second : List Bool) (h₀ : ℕ) : + TapePred n := fun inp work out => + (inp = (Tape.init (second.map Γ.ofBool)).move Dir3.right ∧ + (work firstIdx).head = 1 ∧ + (work firstIdx).HasOutput first ∧ + (∀ i, (work i).StartInvariant ∧ 1 ≤ (work i).head) ∧ + out = (Tape.init []).move Dir3.right) ∧ + (∀ i, (work i).head ≤ h₀) + +/-- **The pair emitter keeps a window.** Its own precondition parks the input and output tapes at +cell one but says nothing about how far the other work heads have travelled, so `pairEmitPre` +adds that bound; everything else comes from the emitter's halting time. -/ +theorem pairInputWork_keepsWindowOn {n : ℕ} (firstIdx : Fin n) (first second : List Bool) + (inputLength h₀ : ℕ) : + (pairInputWorkTM firstIdx).KeepsWindowOn + (fun c => c.state = (pairInputWorkTM firstIdx).qstart ∧ + pairEmitPre firstIdx first second h₀ c.input c.work c.output) + inputLength (h₀ + pairInputWorkTime first second) := by + refine keepsWindowOn_of_hoareTime (pre := pairEmitPre firstIdx first second h₀) + (post := fun _inp _work out => out.HasOutput (pair first second)) + (fun inp work out hpre => + pairInputWorkTM_hoareTime firstIdx first second inp work out hpre.1) + (fun _ _ _ hpre i => hpre.2 i) (fun inp _ _ hpre => ?_) (fun _ _ out hpre => ?_) + · rw [hpre.1.1] + show 0 + 1 ≤ inputLength + h₀ + 1 + omega + · rw [hpre.1.2.2.2.2] + show 0 + 1 ≤ h₀ + 1 + omega + + +/-- **The counter increment keeps a window.** `TM.binarySuccTM` advances the little-endian +counter that carries the witness; its framed contract already pins every tape, so the window +follows from the head bounds and its running time. -/ +theorem binarySucc_keepsWindowOn {n : ℕ} (idx : Fin n) (value : ℕ) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hvalue : (work₀ idx).HasBinaryNat value) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) + {inputLength h₀ : ℕ} + (hwork : ∀ i, (work₀ i).head ≤ h₀) + (hinputHead : inp₀.head ≤ inputLength + h₀ + 1) + (houtputHead : out₀.head ≤ h₀ + 1) : + (binarySuccTM idx).KeepsWindowOn + (fun c => c.state = (binarySuccTM idx).qstart ∧ + (c.input = inp₀ ∧ c.work = work₀ ∧ c.output = out₀)) + inputLength (h₀ + binarySuccTime value) := + keepsWindowOn_of_hoareTime_pinned + (binarySuccTM_hoareTimeSpace_frame idx value inputLength h₀ inp₀ work₀ out₀ hvalue hinp + hother hout ⟨hwork, hinputHead⟩).1 + hwork hinputHead houtputHead + +/-- **The witness-advancing machine keeps a window.** Like the counter increment beside it, its +framed contract pins every tape, so the window follows from the head bounds and its running +time. -/ +theorem binaryBump_keepsWindowOn {n : ℕ} (idx : Fin n) (bits : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hbits : (work₀ idx).HasBinaryString bits) + (hcell0 : (work₀ idx).cells 0 = Γ.start) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) + {inputLength h₀ : ℕ} + (hwork : ∀ i, (work₀ i).head ≤ h₀) + (hinputHead : inp₀.head ≤ inputLength + h₀ + 1) + (houtputHead : out₀.head ≤ h₀ + 1) : + (binaryBumpTM idx).KeepsWindowOn + (fun c => c.state = (binaryBumpTM idx).qstart ∧ + (c.input = inp₀ ∧ c.work = work₀ ∧ c.output = out₀)) + inputLength (h₀ + binaryBumpTime bits) := + keepsWindowOn_of_hoareTime_pinned + (binaryBumpTM_hoareTime_frame idx bits inp₀ work₀ out₀ hbits hcell0 hinp hother hout) + hwork hinputHead houtputHead + +end TM + +/-- **The witness-advancing machine computes the enumeration's step.** `BinaryBump.bump` is +defined on the tape's bit string and `bumpLE` on the witness the counter denotes; they are the +same function, which is what lets `dropTop_succ` serve as the loop invariant of a machine that +carries its witness on a tape. -/ +theorem bump_eq_bumpLE : ∀ w : List Bool, BinaryBump.bump w = bumpLE w + | [] => rfl + | false :: _ => rfl + | true :: w => by rw [BinaryBump.bump, bumpLE, bump_eq_bumpLE w] + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHPrologue.lean b/Complexitylib/Classes/Containments/Internal/PHPrologue.lean new file mode 100644 index 00000000..778803e6 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHPrologue.lean @@ -0,0 +1,561 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PHBody +public import Complexitylib.Models.TuringMachine.Subroutines.Internal +public import Complexitylib.Models.TuringMachine.Subroutines.ParkRewind +public import Complexitylib.Models.TuringMachine.Registers.InputLen +public import Complexitylib.Models.TuringMachine.Registers.Horner +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import Complexitylib.Models.TuringMachine.Registers.EmitSeq + +/-! +# The enumerator's prologue + +⚠️ Unreviewed by Bolton + +Before the loop can start, three tapes have to be filled: a copy of the real input, for the pair +emitter to read; the horizon the counter is compared against; and the unary register that drives +each pass's wipe. + +`TM.copyInputToWorkTM`'s own contract says nothing about the tapes it does not write, and it is +used here beside a dozen that must survive. It does not disturb them: every tape but its target +is written `blank` and moved by `TM.idleDir`, so a blank tape comes back blank — which is what +the frame below records, by induction along the run. + +## Main results + +- `PolyExists.blankTape_idle` — an idled blank tape is unchanged +- `PolyExists.copyInputToWorkTM_blank_frame` — the copier leaves every other blank tape blank +- `PolyExists.copyX_hoareTime` — the copy stage's contract, frame included +-/ + +@[expose] public section + +namespace Complexity + +namespace PolyExists + +variable {n : ℕ} + +/-- **An idled blank tape is unchanged.** Writing a blank under the head of a blank tape changes +nothing, and `TM.idleDir` does not move a head that is off the marker. -/ +theorem blankTape_idle : + TM.blankTape.writeAndMove Γw.blank.toΓ (TM.idleDir TM.blankTape.read) = TM.blankTape := by + have hread : TM.blankTape.read = Γ.blank := Tape.init_nil_move_right_read + rw [hread] + show (TM.blankTape.write Γ.blank).move (TM.idleDir Γ.blank) = TM.blankTape + rw [TM.idleDir, if_neg (by decide)] + refine Tape.ext ?_ ?_ + · show (TM.blankTape.write Γ.blank).head = TM.blankTape.head + rw [Tape.write_head] + · show (TM.blankTape.write Γ.blank).cells = TM.blankTape.cells + rw [Tape.write, if_neg (by show ¬ ((1 : ℕ) = 0); omega)] + funext j + show Function.update TM.blankTape.cells TM.blankTape.head Γ.blank j = TM.blankTape.cells j + by_cases hj : j = TM.blankTape.head + · rw [hj, Function.update_self] + show Γ.blank = TM.blankTape.cells 1 + exact hread.symm + · rw [Function.update_of_ne hj] + +/-- **One step of the copier leaves a blank tape blank.** -/ +theorem copyStep_blank (idx : Fin n) {c c' : Cfg n (TM.copyInputToWorkTM idx).Q} + (hstep : (TM.copyInputToWorkTM idx).step c = some c') (i : Fin n) (hi : i ≠ idx) + (h : c.work i = TM.blankTape) : c'.work i = TM.blankTape := by + rw [TM.step] at hstep + split at hstep + · exact absurd hstep (by simp) + · rw [← Option.some_inj.mp hstep] + show (c.work i).writeAndMove + (((TM.copyInputToWorkTM idx).δ c.state c.input.read (fun j => (c.work j).read) + c.output.read).2.1 i).toΓ + (((TM.copyInputToWorkTM idx).δ c.state c.input.read (fun j => (c.work j).read) + c.output.read).2.2.2.2.1 i) = TM.blankTape + have hwrite : ∀ (s : TM.CopyPhase) (iH : Γ) (wH : Fin n → Γ) (oH : Γ), + ((TM.copyInputToWorkTM idx).δ s iH wH oH).2.1 i = Γw.blank ∧ + ((TM.copyInputToWorkTM idx).δ s iH wH oH).2.2.2.2.1 i = TM.idleDir (wH i) := by + intro s iH wH oH + cases s with + | copying => + show (if iH = Γ.blank then TM.allIdle _ iH wH oH else _).2.1 i = _ ∧ + (if iH = Γ.blank then TM.allIdle _ iH wH oH else _).2.2.2.2.1 i = _ + split + · exact ⟨rfl, rfl⟩ + · exact ⟨if_neg hi, if_neg hi⟩ + | done => exact ⟨rfl, rfl⟩ + obtain ⟨hw, hd⟩ := hwrite c.state c.input.read (fun j => (c.work j).read) c.output.read + rw [hw, hd, h] + exact blankTape_idle + +/-- **The copier leaves every other blank tape blank**, which is the frame its own contract does +not record. -/ +theorem copyInputToWorkTM_blank_frame (idx : Fin n) : + ∀ {t : ℕ} {c c' : Cfg n (TM.copyInputToWorkTM idx).Q}, + (TM.copyInputToWorkTM idx).reachesIn t c c' → + ∀ i, i ≠ idx → c.work i = TM.blankTape → c'.work i = TM.blankTape := by + intro t + induction t with + | zero => + intro c c' hreach i hi h + cases hreach + exact h + | succ t ih => + intro c c' hreach i hi h + cases hreach with + | step hstep hrest => exact ih hrest i hi (copyStep_blank idx hstep i hi h) + +/-- **One step of the copier leaves the real output blank**, for the same reason. -/ +theorem copyStep_blank_out (idx : Fin n) {c c' : Cfg n (TM.copyInputToWorkTM idx).Q} + (hstep : (TM.copyInputToWorkTM idx).step c = some c') + (h : c.output = TM.blankTape) : c'.output = TM.blankTape := by + rw [TM.step] at hstep + split at hstep + · exact absurd hstep (by simp) + · rw [← Option.some_inj.mp hstep] + show c.output.writeAndMove + (((TM.copyInputToWorkTM idx).δ c.state c.input.read (fun j => (c.work j).read) + c.output.read).2.2.1).toΓ + (((TM.copyInputToWorkTM idx).δ c.state c.input.read (fun j => (c.work j).read) + c.output.read).2.2.2.2.2) = TM.blankTape + have hwrite : ∀ (s : TM.CopyPhase) (iH : Γ) (wH : Fin n → Γ) (oH : Γ), + ((TM.copyInputToWorkTM idx).δ s iH wH oH).2.2.1 = Γw.blank ∧ + ((TM.copyInputToWorkTM idx).δ s iH wH oH).2.2.2.2.2 = TM.idleDir oH := by + intro s iH wH oH + cases s with + | copying => + show (if iH = Γ.blank then TM.allIdle _ iH wH oH else _).2.2.1 = _ ∧ + (if iH = Γ.blank then TM.allIdle _ iH wH oH else _).2.2.2.2.2 = _ + split + · exact ⟨rfl, rfl⟩ + · exact ⟨rfl, rfl⟩ + | done => exact ⟨rfl, rfl⟩ + obtain ⟨hw, hd⟩ := hwrite c.state c.input.read (fun j => (c.work j).read) c.output.read + rw [hw, hd, h] + exact blankTape_idle + +theorem copyInputToWorkTM_blank_frame_out (idx : Fin n) : + ∀ {t : ℕ} {c c' : Cfg n (TM.copyInputToWorkTM idx).Q}, + (TM.copyInputToWorkTM idx).reachesIn t c c' → + c.output = TM.blankTape → c'.output = TM.blankTape := by + intro t + induction t with + | zero => + intro c c' hreach h + cases hreach + exact h + | succ t ih => + intro c c' hreach h + cases hreach with + | step hstep hrest => exact ih hrest (copyStep_blank_out idx hstep h) + +/-- The blank tape carries the empty binary prefix. -/ +theorem blankTape_hasBinaryPrefix_nil : TM.blankTape.HasBinaryPrefix [] := by + refine ⟨rfl, nofun, fun i _ => ?_⟩ + show ((Tape.init ([] : List Γ)).move Dir3.right).cells (i + 1) = Γ.blank + rw [Tape.move_cells, Tape.init_nil_cells_succ] + +/-- **The input copy, contracted with its frame.** -/ +theorem copyX_hoareTime (k : ℕ) (x : List Bool) : + (TM.copyInputToWorkTM (xIdx k)).HoareTime + (fun inp work out => inp = strTape x ∧ work = (fun _ => TM.blankTape) ∧ + out = TM.blankTape) + (fun inp work out => inp.cells = (strTape x).cells ∧ inp.head = x.length + 1 ∧ + (∀ i, i ≠ xIdx k → work i = TM.blankTape) ∧ + (work (xIdx k)).HasBinaryPrefix x ∧ (work (xIdx k)).cells 0 = Γ.start ∧ + out = TM.blankTape) + (x.length + 1) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + obtain ⟨c', t, ht, hreach, hhalt, hcells, hhead, hprefix⟩ := + TM.copyInputToWorkTM_started_hoareTime (xIdx k) x (strTape x) (fun _ => TM.blankTape) + TM.blankTape ⟨rfl, blankTape_hasBinaryPrefix_nil⟩ + have hSI := TM.reachesIn_startInvariant hreach (strTape_startInvariant x) + (fun _ => TM.blankTape_startInvariant) TM.blankTape_startInvariant + exact ⟨c', t, ht, hreach, hhalt, hcells, hhead, + fun i hi => copyInputToWorkTM_blank_frame (xIdx k) hreach i hi rfl, + hprefix, (hSI.2.1 (xIdx k)).1, copyInputToWorkTM_blank_frame_out (xIdx k) hreach rfl⟩ + +/-- The register subroutines state their contracts with an output accumulator; with nothing +emitted that is just the blank tape. -/ +theorem outAcc_nil_iff (out : Tape) : TM.OutAcc [] out ↔ out = TM.blankTape := by + constructor + · intro h + refine TM.OutAcc.eq h ?_ + show TM.OutAcc [] TM.blankTape + exact TM.outAcc_nil_init + · intro h + rw [h] + exact TM.outAcc_nil_init + +/-- A pinned contract with a blank output is an emit contract with nothing emitted. -/ +theorem hoareTime_emit_of_pinned {m : ℕ} {tm : TM m} {inp₀ : Tape} + {W W' : Fin m → Tape} {b : ℕ} + (h : tm.HoareTime (fun inp work out => inp = inp₀ ∧ work = W ∧ out = TM.blankTape) + (fun inp work out => inp = inp₀ ∧ work = W' ∧ out = TM.blankTape) b) : + tm.HoareTime (TM.EmitPred inp₀ W []) (TM.EmitPred inp₀ W' []) b := by + intro inp work out hpre + obtain ⟨hi, hw, hout⟩ := hpre + obtain ⟨c', t, ht, hreach, hhalt, hi', hw', ho'⟩ := + h inp work out ⟨hi, hw, (outAcc_nil_iff out).mp hout⟩ + exact ⟨c', t, ht, hreach, hhalt, hi', hw', (outAcc_nil_iff _).mpr ho'⟩ + +/-- **A unary register of `T` ones is the binary numeral `2 ^ T - 1`.** The two encodings agree +cell for cell, which is what lets the prologue produce the horizon without a doubling loop. -/ +theorem bits_two_pow_sub_one' : ∀ T : ℕ, (2 ^ T - 1).bits = List.replicate T true := by + intro T + induction T with + | zero => simp + | succ T ih => + have hrw : 2 ^ (T + 1) - 1 = 2 * (2 ^ T - 1) + 1 := by + have h : 1 ≤ 2 ^ T := Nat.one_le_two_pow + have : 2 ^ (T + 1) = 2 * 2 ^ T := by ring + omega + rw [hrw, Nat.bit1_bits, ih, List.replicate_succ] + +theorem regTape_eq_natTape' (T : ℕ) : TM.regTape T = natTape (2 ^ T - 1) := by + refine Tape.ext rfl (funext fun j => ?_) + have hbits := bits_two_pow_sub_one' T + have hlen : (2 ^ T - 1).bits.length = T := by rw [hbits, List.length_replicate] + show TM.regCells T j = (natTape (2 ^ T - 1)).cells j + rw [natTape, Tape.move_cells] + by_cases hj : j = 0 + · rw [hj] + show (if (0 : ℕ) = 0 then Γ.start else _) = _ + rw [if_pos rfl, Tape.init_cells_zero] + · obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_cells_succ] + show (if i + 1 = 0 then Γ.start else if i + 1 ≤ T then Γ.one else Γ.blank) + = (((2 ^ T - 1).bits.map Γ.ofBool)[i]?).getD Γ.blank + rw [if_neg (by omega), hbits] + by_cases hi : i < T + · rw [if_pos (by omega)] + simp [hi, Γ.ofBool] + · rw [if_neg (by omega)] + simp [hi] + + +/-- A unary register holding zero is the blank tape. -/ +theorem regTape_zero' : TM.regTape 0 = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show TM.regCells 0 j = ((Tape.init ([] : List Γ)).move Dir3.right).cells j + rw [Tape.move_cells] + by_cases hj : j = 0 + · rw [hj] + show (if (0 : ℕ) = 0 then Γ.start else _) = _ + rw [if_pos rfl, Tape.init_cells_zero] + · show (if j = 0 then Γ.start else if j ≤ 0 then Γ.one else Γ.blank) = _ + rw [if_neg hj, if_neg (by omega), show j = (j - 1) + 1 from by omega, + Tape.init_nil_cells_succ] + +/-- And so is a counter tape holding zero. -/ +theorem natTape_zero_eq' : natTape 0 = TM.blankTape := by + rw [← regTape_zero', regTape_eq_natTape' 0] + norm_num + + +/-- **The enumerator's prologue.** Measure the input, evaluate the horizon's exponent and the +wipe height on unary registers, bump the exponent — a register of `m + 1` ones *is* the binary +numeral `2 ^ (m + 1) - 1` — and clear the scratch. -/ +def prologueTM (k : ℕ) (p q : Polynomial ℕ) : TM (enumTapes k) := + TM.bigSeqTM + [TM.inputLenRegTM (resIdx k), + TM.polyEvalTM (resIdx k) (nIdx k) (y1Idx k) p, + TM.incRegTM (nIdx k), + TM.polyEvalTM (resIdx k) (regIdx k) (yIdx k) q, + TM.clearRegTM (resIdx k), + TM.clearRegTM (y1Idx k), + TM.clearRegTM (yIdx k)] + +/-- The bank the copy stage leaves: the input on its tape, everything else blank. -/ +def copiedBank (k : ℕ) (x : List Bool) : Fin (enumTapes k) → Tape := + Function.update (fun _ => TM.blankTape) (xIdx k) (strTape x) + +theorem copiedBank_parked (k : ℕ) (x : List Bool) (j : Fin (enumTapes k)) : + TM.Parked (copiedBank k x j) := by + rw [copiedBank] + by_cases h : j = xIdx k + · rw [h, Function.update_self] + exact strTape_parked x + · rw [Function.update_of_ne h] + exact TM.blankTape_parked + +theorem copiedBank_of_ne (k : ℕ) (x : List Bool) (j : Fin (enumTapes k)) (h : j ≠ xIdx k) : + copiedBank k x j = TM.blankTape := by + rw [copiedBank, Function.update_of_ne h] +/-- The cap the Horner evaluation stays under. -/ +def prologueCap (p : Polynomial ℕ) (lx : ℕ) : ℕ := + ((TM.polyCoeffs p).sum + 1) * (lx + 1) ^ (TM.polyCoeffs p).length + +theorem le_prologueCap (p : Polynomial ℕ) (lx : ℕ) : lx ≤ prologueCap p lx := by + have hlen : 1 ≤ (TM.polyCoeffs p).length := + List.length_pos_iff.mpr (TM.polyCoeffs_ne_nil p) + have h1 : lx + 1 ≤ (lx + 1) ^ (TM.polyCoeffs p).length := + Nat.le_self_pow (by omega) _ + have h2 : (lx + 1) ^ (TM.polyCoeffs p).length + ≤ ((TM.polyCoeffs p).sum + 1) * (lx + 1) ^ (TM.polyCoeffs p).length := + Nat.le_mul_of_pos_left _ (by omega) + unfold prologueCap + omega + +/-- The prologue's per-stage budget. -/ +def prologueBnd (p q : Polynomial ℕ) (lx : ℕ) : ℕ := + max (max (max (2 * lx + 4) + (TM.opBudget (prologueCap p lx) + 1 + + ((p.natDegree + 1) * (TM.layerBudget (prologueCap p lx) + 1) + 1))) + (max (2 * p.eval lx + 4) + (TM.opBudget (prologueCap q lx) + 1 + + ((q.natDegree + 1) * (TM.layerBudget (prologueCap q lx) + 1) + 1)))) + (max (2 * lx + 4) (max (2 * p.eval lx + 4) (2 * q.eval lx + 4))) + +/-- The prologue's running time. -/ +def prologueTime (p q : Polynomial ℕ) (lx : ℕ) : ℕ := 7 * (prologueBnd p q lx + 1) + 1 + +/-- **The prologue's contract.** From the bank the copy stage leaves it lands on the loop's +starting bank: the horizon on `PolyExists.nIdx`, the wipe height on `PolyExists.regIdx`, the +input copy where the emitter reads it, and everything else blank. -/ +theorem prologueTM_hoareTime (k : ℕ) (p q : Polynomial ℕ) (x : List Bool) : + (prologueTM k p q).HoareTime + (fun inp work out => inp = strTape x ∧ work = copiedBank k x ∧ out = TM.blankTape) + (fun inp work out => inp = strTape x ∧ + work = enumBank k x (2 ^ (p.eval x.length + 1) - 1) (q.eval x.length) 0 0 0 ∧ + out = TM.blankTape) + (prologueTime p q x.length) := by + set lx := x.length with hlx + set m := p.eval lx with hm + set Hq := q.eval lx with hHq + set I : Tape := strTape x with hI + have hIp : TM.Parked I := strTape_parked x + have hne : ∀ (i i' : Fin (enumTapes k)), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + have hsn : resIdx k ≠ nIdx k := hne _ _ (by show 3 + k + 4 ≠ 3 + k + 3; omega) + have hsy1 : resIdx k ≠ y1Idx k := hne _ _ (by show 3 + k + 4 ≠ 2; omega) + have hny1 : nIdx k ≠ y1Idx k := hne _ _ (by show 3 + k + 3 ≠ 2; omega) + have hsg : resIdx k ≠ regIdx k := hne _ _ (by show 3 + k + 4 ≠ 3 + k + 7; omega) + have hsy : resIdx k ≠ yIdx k := hne _ _ (by show 3 + k + 4 ≠ 3 + k; omega) + have hgy : regIdx k ≠ yIdx k := hne _ _ (by show 3 + k + 7 ≠ 3 + k; omega) + set V0 : Fin (enumTapes k) → Tape := copiedBank k x with hV0 + set V1 := Function.update V0 (resIdx k) (TM.regTape lx) with hV1 + set V2 := Function.update (Function.update V1 (y1Idx k) (TM.regTape m)) (nIdx k) + (TM.regTape m) with hV2 + set V3 := Function.update V2 (nIdx k) (TM.regTape (m + 1)) with hV3 + set V4 := Function.update (Function.update V3 (yIdx k) (TM.regTape Hq)) (regIdx k) + (TM.regTape Hq) with hV4 + set V5 := Function.update V4 (resIdx k) (TM.regTape 0) with hV5 + set V6 := Function.update V5 (y1Idx k) (TM.regTape 0) with hV6 + set V7 := Function.update V6 (yIdx k) (TM.regTape 0) with hV7 + have hupd : ∀ (W : Fin (enumTapes k) → Tape) (i : Fin (enumTapes k)) (t : Tape), + (∀ j, TM.Parked (W j)) → TM.Parked t → ∀ j, TM.Parked (Function.update W i t j) := by + intro W i t hW ht j + by_cases hj : j = i + · rw [hj, Function.update_self]; exact ht + · rw [Function.update_of_ne hj]; exact hW j + have hreg : ∀ v : ℕ, TM.Parked (TM.regTape v) := fun v => by + rw [regTape_eq_natTape']; exact natTape_parked _ + have hV0P : ∀ j, TM.Parked (V0 j) := copiedBank_parked k x + have hV1P : ∀ j, TM.Parked (V1 j) := hupd _ _ _ hV0P (hreg _) + have hV2P : ∀ j, TM.Parked (V2 j) := hupd _ _ _ (hupd _ _ _ hV1P (hreg _)) (hreg _) + have hV3P : ∀ j, TM.Parked (V3 j) := hupd _ _ _ hV2P (hreg _) + have hV4P : ∀ j, TM.Parked (V4 j) := hupd _ _ _ (hupd _ _ _ hV3P (hreg _)) (hreg _) + have hV5P : ∀ j, TM.Parked (V5 j) := hupd _ _ _ hV4P (hreg _) + have hV6P : ∀ j, TM.Parked (V6 j) := hupd _ _ _ hV5P (hreg _) + have hV7P : ∀ j, TM.Parked (V7 j) := hupd _ _ _ hV6P (hreg _) + have hV0s : V0 (resIdx k) = TM.regTape 0 := by + rw [hV0, copiedBank_of_ne k x _ (hne _ _ (by show 3 + k + 4 ≠ 0; omega)), regTape_zero'] + have hV1s : V1 (resIdx k) = TM.regTape lx := by rw [hV1, Function.update_self] + have hV1n : V1 (nIdx k) = TM.regTape 0 := by + rw [hV1, Function.update_of_ne (Ne.symm hsn), hV0, + copiedBank_of_ne k x _ (hne _ _ (by show 3 + k + 3 ≠ 0; omega)), regTape_zero'] + have hV1y1 : V1 (y1Idx k) = TM.regTape 0 := by + rw [hV1, Function.update_of_ne (Ne.symm hsy1), hV0, + copiedBank_of_ne k x _ (hne _ _ (by show (2 : ℕ) ≠ 0; omega)), regTape_zero'] + have hV2n : V2 (nIdx k) = TM.regTape m := by rw [hV2, Function.update_self] + have hV3s : V3 (resIdx k) = TM.regTape lx := by + rw [hV3, Function.update_of_ne hsn, hV2, Function.update_of_ne hsn, + Function.update_of_ne hsy1, hV1s] + have hV3g : V3 (regIdx k) = TM.regTape 0 := by + rw [hV3, Function.update_of_ne (hne _ _ (by show 3 + k + 7 ≠ 3 + k + 3; omega)), hV2, + Function.update_of_ne (hne _ _ (by show 3 + k + 7 ≠ 3 + k + 3; omega)), + Function.update_of_ne (hne _ _ (by show 3 + k + 7 ≠ 2; omega)), hV1, + Function.update_of_ne (Ne.symm hsg), hV0, + copiedBank_of_ne k x _ (hne _ _ (by show 3 + k + 7 ≠ 0; omega)), regTape_zero'] + have hV3y : V3 (yIdx k) = TM.regTape 0 := by + rw [hV3, Function.update_of_ne (hne _ _ (by show 3 + k ≠ 3 + k + 3; omega)), hV2, + Function.update_of_ne (hne _ _ (by show 3 + k ≠ 3 + k + 3; omega)), + Function.update_of_ne (hne _ _ (by show 3 + k ≠ 2; omega)), hV1, + Function.update_of_ne (Ne.symm hsy), hV0, + copiedBank_of_ne k x _ (hne _ _ (by show 3 + k ≠ 0; omega)), regTape_zero'] + have hV4s : V4 (resIdx k) = TM.regTape lx := by + rw [hV4, Function.update_of_ne hsg, Function.update_of_ne hsy, hV3s] + have hV5y1 : V5 (y1Idx k) = TM.regTape m := by + rw [hV5, Function.update_of_ne (Ne.symm hsy1), hV4, + Function.update_of_ne (hne _ _ (by show (2 : ℕ) ≠ 3 + k + 7; omega)), + Function.update_of_ne (hne _ _ (by show (2 : ℕ) ≠ 3 + k; omega)), hV3, + Function.update_of_ne (hne _ _ (by show (2 : ℕ) ≠ 3 + k + 3; omega)), hV2, + Function.update_of_ne (hne _ _ (by show (2 : ℕ) ≠ 3 + k + 3; omega)), + Function.update_self] + have hV6y : V6 (yIdx k) = TM.regTape Hq := by + rw [hV6, Function.update_of_ne (hne _ _ (by show 3 + k ≠ 2; omega)), hV5, + Function.update_of_ne (Ne.symm hsy), hV4, Function.update_of_ne hgy.symm, + Function.update_self] + refine (TM.bigSeqTM_hoareTime + [TM.inputLenRegTM (resIdx k), + TM.polyEvalTM (resIdx k) (nIdx k) (y1Idx k) p, + TM.incRegTM (nIdx k), + TM.polyEvalTM (resIdx k) (regIdx k) (yIdx k) q, + TM.clearRegTM (resIdx k), + TM.clearRegTM (y1Idx k), + TM.clearRegTM (yIdx k)] + I + (fun j => if j = 0 then V0 else if j = 1 then V1 else if j = 2 then V2 + else if j = 3 then V3 else if j = 4 then V4 else if j = 5 then V5 + else if j = 6 then V6 else V7) + (fun _ => []) (prologueBnd p q lx) hIp ?_ ?_).consequence ?_ ?_ (le_refl _) + · intro j i + dsimp only + split + · exact hV0P i + · split + · exact hV1P i + · split + · exact hV2P i + · split + · exact hV3P i + · split + · exact hV4P i + · split + · exact hV5P i + · split + · exact hV6P i + · exact hV7P i + · intro j hj + match j, hj with + | 0, _ => + show (TM.inputLenRegTM (resIdx k)).HoareTime (TM.EmitPred I V0 []) _ _ + refine ((TM.inputLenRegTM_hoareTime (resIdx k) x V0 [] (fun i _ => hV0P i) + hV0s).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV1] + norm_num + · exact le_trans (le_max_left _ _) (le_trans (le_max_left _ _) (le_max_left _ _)) + | 1, _ => + show (TM.polyEvalTM (resIdx k) (nIdx k) (y1Idx k) p).HoareTime (TM.EmitPred I V1 []) _ _ + refine ((TM.polyEvalTM_hoareTime (resIdx k) (nIdx k) (y1Idx k) hsn hsy1 hny1 p + (prologueCap p lx) lx 0 0 (le_prologueCap p lx) (Nat.zero_le _) (Nat.zero_le _) + (fun j _ => TM.hornerFold_take_le lx (TM.polyCoeffs p) j) + I V1 [] hIp hV1P hV1s hV1n hV1y1).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV2] + norm_num + · exact le_trans (le_max_right _ _) (le_trans (le_max_left _ _) (le_max_left _ _)) + | 2, _ => + show (TM.incRegTM (nIdx k)).HoareTime (TM.EmitPred I V2 []) _ _ + refine ((TM.incRegTM_hoareTime (nIdx k) m I V2 [] hIp (fun i _ => hV2P i) + hV2n).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV3] + norm_num + · exact le_trans (le_max_left _ _) (le_trans (le_max_right _ _) (le_max_left _ _)) + | 3, _ => + show (TM.polyEvalTM (resIdx k) (regIdx k) (yIdx k) q).HoareTime (TM.EmitPred I V3 []) _ _ + refine ((TM.polyEvalTM_hoareTime (resIdx k) (regIdx k) (yIdx k) hsg hsy hgy q + (prologueCap q lx) lx 0 0 (le_prologueCap q lx) (Nat.zero_le _) (Nat.zero_le _) + (fun j _ => TM.hornerFold_take_le lx (TM.polyCoeffs q) j) + I V3 [] hIp hV3P hV3s hV3g hV3y).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV4] + norm_num + · exact le_trans (le_max_right _ _) (le_trans (le_max_right _ _) (le_max_left _ _)) + | 4, _ => + show (TM.clearRegTM (resIdx k)).HoareTime (TM.EmitPred I V4 []) _ _ + refine ((TM.clearRegTM_hoareTime (resIdx k) lx I V4 [] hIp (fun i _ => hV4P i) + hV4s).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV5] + norm_num + · exact le_trans (le_max_left _ _) (le_max_right _ _) + | 5, _ => + show (TM.clearRegTM (y1Idx k)).HoareTime (TM.EmitPred I V5 []) _ _ + refine ((TM.clearRegTM_hoareTime (y1Idx k) m I V5 [] hIp (fun i _ => hV5P i) + hV5y1).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV6] + norm_num + · exact le_trans (le_trans (le_max_left _ _) (le_max_right _ _)) (le_max_right _ _) + | 6, _ => + show (TM.clearRegTM (yIdx k)).HoareTime (TM.EmitPred I V6 []) _ _ + refine ((TM.clearRegTM_hoareTime (yIdx k) Hq I V6 [] hIp (fun i _ => hV6P i) + hV6y).consequence (fun _ _ _ h => h) ?_ ?_) + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, ← hV7] + norm_num + · exact le_trans (le_trans (le_max_right _ _) (le_max_right _ _)) (le_max_right _ _) + · rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, hw, (outAcc_nil_iff out).mpr ho⟩ + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, (outAcc_nil_iff out).mp ho⟩ + rw [hw] + show V7 = enumBank k x (2 ^ (m + 1) - 1) Hq 0 0 0 + funext j + by_cases hy : j = yIdx k + · rw [hy, hV7, Function.update_self, regTape_zero', enumBank_y] + · rw [hV7, Function.update_of_ne hy] + by_cases hy1 : j = y1Idx k + · rw [hy1, hV6, Function.update_self, regTape_zero', enumBank_y1] + · rw [hV6, Function.update_of_ne hy1] + by_cases hs : j = resIdx k + · rw [hs, hV5, Function.update_self, regTape_zero', + enumBank_blank k x (2 ^ (m + 1) - 1) Hq 0 0 0 _ (res_ne_regs k).1 + (res_ne_regs k).2.1 (res_ne_regs k).2.2 + (hne _ _ (by show 3 + k + 4 ≠ 0; omega)) + (hne _ _ (by show 3 + k + 4 ≠ 1; omega)) + (hne _ _ (by show 3 + k + 4 ≠ 3 + k + 3; omega)) + (hne _ _ (by show 3 + k + 4 ≠ 3 + k + 7; omega))] + · rw [hV5, Function.update_of_ne hs] + by_cases hg : j = regIdx k + · rw [hg, hV4, Function.update_self, + enumBank_of_ne k x (2 ^ (m + 1) - 1) Hq 0 0 0 _ (reg_ne_regs k).1 + (reg_ne_regs k).2.1 (reg_ne_regs k).2.2, enumRest, + if_neg (hne _ _ (by show 3 + k + 7 ≠ 0; omega)), + if_neg (hne _ _ (by show 3 + k + 7 ≠ 1; omega)), + if_neg (hne _ _ (by show 3 + k + 7 ≠ 3 + k + 3; omega)), if_pos rfl] + · rw [hV4, Function.update_of_ne hg, Function.update_of_ne hy] + by_cases hn : j = nIdx k + · rw [hn, hV3, Function.update_self, regTape_eq_natTape', + enumBank_of_ne k x (2 ^ (m + 1) - 1) Hq 0 0 0 _ (n_ne_regs k).1 + (n_ne_regs k).2.1 (n_ne_regs k).2.2, enumRest, + if_neg (hne _ _ (by show 3 + k + 3 ≠ 0; omega)), + if_neg (hne _ _ (by show 3 + k + 3 ≠ 1; omega)), if_pos rfl] + · rw [hV3, Function.update_of_ne hn, hV2, Function.update_of_ne hn, + Function.update_of_ne hy1, hV1, Function.update_of_ne hs, hV0] + by_cases hx : j = xIdx k + · rw [hx, copiedBank, Function.update_self, + enumBank_x] + · rw [copiedBank_of_ne k x j hx] + by_cases hw' : j = wIdx k + · rw [hw', enumBank_w] + rfl + · by_cases hc : j = cIdx k + · rw [hc, enumBank_c] + exact natTape_zero_eq'.symm + · by_cases ha : j = aIdx k + · rw [ha, enumBank_a] + exact natTape_zero_eq'.symm + · by_cases hr : j = rIdx k + · rw [hr, enumBank_r] + exact natTape_zero_eq'.symm + · rw [enumBank_blank k x (2 ^ (m + 1) - 1) Hq 0 0 0 j hc ha hr hx hw' hn + hg] + +end PolyExists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PHSubsetPSPACE.lean b/Complexitylib/Classes/Containments/Internal/PHSubsetPSPACE.lean new file mode 100644 index 00000000..ab84364f --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PHSubsetPSPACE.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH +public import Complexitylib.Classes.Containments +public import Complexitylib.Classes.Containments.Internal.ComplementSpace +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Window +public import Complexitylib.Classes.Containments.Internal.PolyWindow +public import Complexitylib.Classes.Containments.Internal.PHParts +public import Complexitylib.Classes.Containments.Internal.PHLayout +public import Complexitylib.Classes.Containments.Internal.PHMatrix +public import Complexitylib.Classes.Containments.Internal.PHEmit +public import Complexitylib.Classes.Containments.Internal.PHBody +public import Complexitylib.Classes.Containments.Internal.PHLoop +public import Complexitylib.Classes.Containments.Internal.PHEpilogue +public import Complexitylib.Classes.Containments.Internal.PHPrologue +public import Complexitylib.Classes.Containments.Internal.PHBodyWindow +public import Complexitylib.Classes.Containments.Internal.PHLoopWindow +public import Complexitylib.Classes.Containments.Internal.PHAssemble +public import Complexitylib.Classes.Containments.Internal.PHAssembleWindow +public import Complexitylib.Classes.Containments.Internal.PHBounds +public import Complexitylib.Classes.Containments.Internal.WitnessEnum + +/-! +# `PH ⊆ PSPACE` — the induction on the level + +⚠️ Unreviewed by Bolton + +The hierarchy is built one quantifier at a time: `SigmaP 0 = P` and +`SigmaP (n+1) = polyExistsClass (complClass (SigmaP n))`. So an induction on the level reduces +the containment to two closure properties of `PSPACE`, and nothing else: closure under +complement, and closure under a polynomially bounded existential quantifier. The base case is +already available as `P_subset_PSPACE`. + +Closure under complement is now proved — see +`Complexitylib.Classes.Containments.Internal.ComplementSpace` — so only the existential +quantifier is left, and `PH_subset_PSPACE_of_polyExists_internal` states the containment with +that as its single remaining hypothesis. + +## The intended construction + +The machine that will discharge the remaining hypothesis enumerates witnesses in a loop. Its +space accounting is supplied by +`Complexitylib.Models.TuringMachine.Combinators.Internal.Window`: `TM.KeepsWindow` is a space +discipline that survives re-entry, `TM.loopTM_keepsWindow` shows a loop inherits it from its body +and test — so a loop may run as long as it likes without its bound growing — and +`TM.decidesInSpace_of_keepsWindow` turns the result into a `DSPACE` membership. + +The enumeration itself is a single loop. `mem_polyExistsLang_iff_count` replaces the two numeric +quantifiers by one counter below `2 ^ (p |x| + 1)`, a value denoting the witness `dropTop v` — its +canonical bits with the leading one removed. The machine never computes `dropTop`: it carries the +witness on a tape of its own and advances it in step with the counter, which `dropTop_succ` says +is the increment `bumpLE` — the ordinary binary increment, except that a carry off the end +*extends* the witness by a zero rather than writing a one. So the loop control is exactly the one +`NTM.ppMachine` already runs, and the witness tape is maintained by a variant of +`TM.binarySuccTM`. + +The body can be assembled from existing subroutines rather than built from scratch. The one +apparent obstacle is that `TM.pairInputWorkTM` emits `pair w x`, taking its *second* component +from the real input, whereas `polyExistsLang` needs `pair x w`. Retargeting resolves it: +`TM.retargetInputStarted` makes a machine read its input off a work tape, so the emitter can be +pointed at the witness tape as its "input" while the copy of `x` — produced by +`TM.copyInputToOutputTM` under `TM.retargetOutput` — sits on the work tape it delimits. No new +emitter is required. The space cost of that relocation is accounted for by +`TM.retargetInput_keepsWindow_of_reaches`: what was the machine's free input tape becomes a +charged work tape, so the window it needs is its own budget plus the virtual input's length. +`TM.resetTapesTM` clears the scratch between iterations, which is what makes the body robust +enough for `TM.seqTM_keepsWindow_of_post`. + +## Main results + +- `PH_subset_PSPACE_of_enumerator_internal` — the containment, modulo one machine +- `SigmaP_subset_PSPACE_of_internal` — every level, modulo the two closure properties +- `PH_subset_PSPACE_of_internal` — the induction, modulo the two closure properties +- `PH_subset_PSPACE_of_polyExists_internal` — the containment, modulo the existential alone +- `mem_polyExistsLang_iff_numeric` — what the enumerating machine has to decide +- `mem_polyExistsLang_iff_count` — the same, as a single count over one counter +- `PH_subset_PSPACE_of_polyExistsLang_internal` — the containment, modulo one concrete + language-level statement +- `PH_enumerator_exists` — the enumerating machine, with its window and its verdict +- `PH_subset_PSPACE_internal` — the containment +-/ + +@[expose] public section + +namespace Complexity + +/-- Every level of the hierarchy is in `PSPACE`, granted the two closure properties. -/ +theorem SigmaP_subset_PSPACE_of_internal + (hcompl : ∀ L ∈ PSPACE, Lᶜ ∈ PSPACE) + (hex : polyExistsClass PSPACE ⊆ PSPACE) : + ∀ n, SigmaP n ⊆ PSPACE := by + intro n + induction n with + | zero => exact P_subset_PSPACE + | succ n ih => + refine (polyExistsClass_mono ?_).trans hex + intro L hL + have h : Lᶜ ∈ PSPACE := ih hL + have h' : (Lᶜ)ᶜ ∈ PSPACE := hcompl _ h + rwa [compl_compl] at h' + +/-- **`PH ⊆ PSPACE`, modulo two closure properties of `PSPACE`.** The alternating prefix is +consumed one quantifier at a time; a complement flips the verdict and an existential is +evaluated by trying every witness in place. -/ +theorem PH_subset_PSPACE_of_internal + (hcompl : ∀ L ∈ PSPACE, Lᶜ ∈ PSPACE) + (hex : polyExistsClass PSPACE ⊆ PSPACE) : + PH ⊆ PSPACE := by + intro L hL + obtain ⟨n, hn⟩ := Set.mem_iUnion.mp hL + exact SigmaP_subset_PSPACE_of_internal hcompl hex n hn + +/-- **`PH ⊆ PSPACE`, modulo a single closure property.** Closure under complement is proved, so +only the polynomially bounded existential quantifier remains. -/ +theorem PH_subset_PSPACE_of_polyExists_internal (hex : polyExistsClass PSPACE ⊆ PSPACE) : + PH ⊆ PSPACE := + PH_subset_PSPACE_of_internal (fun _ h => PSPACE_compl h) hex + +/-- **Membership in a bounded existential, as two numeric quantifiers.** This is the condition the +enumerating machine decides: iterate a witness length and a witness value, and test the pair. -/ +theorem mem_polyExistsLang_iff_numeric (p : Polynomial ℕ) (L' : Language) (x : List Bool) : + x ∈ polyExistsLang p L' ↔ + ∃ ℓ ≤ p.eval x.length, ∃ v < 2 ^ ℓ, pair x (bitsOfLen ℓ v) ∈ L' := + exists_bounded_iff _ _ + +/-- **Membership in a bounded existential, as a single count.** The two numeric quantifiers above +collapse to one: a counter below `2 ^ (p |x| + 1)` denotes a witness through `dropTop`, every +witness of the admitted lengths being denoted. This is the form the enumerating machine runs — +one loop over one register, the same shape as the path-counting machine of `PP ⊆ PSPACE`. -/ +theorem mem_polyExistsLang_iff_count (p : Polynomial ℕ) (L' : Language) (x : List Bool) : + x ∈ polyExistsLang p L' ↔ + ∃ v < 2 ^ (p.eval x.length + 1), pair x (dropTop v) ∈ L' := + exists_bounded_iff_count _ _ + +/-- The class-level closure reduces to a statement about one language construction. -/ +theorem polyExistsClass_PSPACE_subset_PSPACE_of + (h : ∀ (p : Polynomial ℕ) (L' : Language), L' ∈ PSPACE → polyExistsLang p L' ∈ PSPACE) : + polyExistsClass PSPACE ⊆ PSPACE := by + rintro L ⟨p, L', hL', rfl⟩ + exact h p L' hL' + +/-- **`PH ⊆ PSPACE`, reduced to a single concrete obligation.** No class-level plumbing is left: +what remains is to exhibit, for one polynomial and one polynomially space-bounded language, a +machine deciding the bounded existential in polynomial space. Closure under complement is already +proved, and `mem_polyExistsLang_iff_numeric` says exactly what that machine has to decide. -/ +theorem PH_subset_PSPACE_of_polyExistsLang_internal + (h : ∀ (p : Polynomial ℕ) (L' : Language), L' ∈ PSPACE → polyExistsLang p L' ∈ PSPACE) : + PH ⊆ PSPACE := + PH_subset_PSPACE_of_polyExists_internal (polyExistsClass_PSPACE_subset_PSPACE_of h) + + +/-- **The last obligation, spelled out at the machine level.** `PH ⊆ PSPACE` now follows from the +existence of one machine: for each polynomial `p` and each polynomially space-bounded `L'`, a +machine that keeps a polynomial window and decides the bounded existential — whose membership +condition is the two numeric quantifiers of `mem_polyExistsLang_iff_numeric`. -/ +theorem PH_subset_PSPACE_of_enumerator_internal + (h : ∀ (p : Polynomial ℕ) (L' : Language), L' ∈ PSPACE → + ∃ (k : ℕ) (tm : TM k) (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k tm.Q), tm.reaches (tm.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ polyExistsLang p L' → c'.output.cells 1 = Γ.one) ∧ + (x ∉ polyExistsLang p L' → c'.output.cells 1 = Γ.zero))) : + PH ⊆ PSPACE := by + refine PH_subset_PSPACE_of_polyExistsLang_internal fun p L' hL' => ?_ + obtain ⟨k, tm, q, hwin, hdec⟩ := h p L' hL' + exact mem_PSPACE_of_polyWindow tm q hwin hdec + +/-- **The enumerating machine exists.** For every polynomial `p` and every polynomially +space-bounded `L'`, the witness enumerator `PolyExists.enumTM` decides the bounded existential +`polyExistsLang p L'` and keeps a polynomial window while doing so. Its space bound is +independent of the loop's running time: the counter and the witness are the only things that +grow, and both stay below `p |x| + 1` bits. -/ +theorem PH_enumerator_exists (p : Polynomial ℕ) (L' : Language) (hL' : L' ∈ PSPACE) : + ∃ (k' : ℕ) (tm : TM k') (Q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' tm.Q), tm.reaches (tm.initCfg x) c' → + c'.WithinDecisionSpace x.length (Q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ polyExistsLang p L' → c'.output.cells 1 = Γ.one) ∧ + (x ∉ polyExistsLang p L' → c'.output.cells 1 = Γ.zero)) := by + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp hL' + obtain ⟨k, M, f, hdecS, hf⟩ := hm + obtain ⟨s, hs⟩ := BigO.pow_polynomial_bound hf + have hdec : M.DecidesInTime L' (TM.spaceTimeBound M f) := + TM.decidesInTime_of_decidesInSpace hdecS + have hne : M.qstart ≠ M.qhalt := TM.qstart_ne_qhalt_of_decidesInTime M hdec + refine ⟨PolyExists.enumTapes k, PolyExists.enumTM M p (PolyExists.bHPoly p s), + PolyExists.bWPoly ((PolyExists.scratchTargets k).length) p s (PolyExists.bHPoly p s), ?_, ?_⟩ + · intro x c' hreach + obtain ⟨bBody, bTest, hb1, hb2⟩ := PolyExists.exists_loop_bounds M f x L' + (2 ^ (p.eval x.length + 1) - 1) + (PolyExists.bH x.length (p.eval x.length) + (s.eval (PolyExists.bP x.length (p.eval x.length)))) + (PolyExists.bB x.length (p.eval x.length)) + (PolyExists.bHb x.length (p.eval x.length) + (s.eval (PolyExists.bP x.length (p.eval x.length)))) + exact PolyExists.enumTM_space M s hs hdecS hdec hne p x _ _ _ _ _ _ bBody bTest + rfl rfl rfl rfl rfl (PolyExists.bWPoly_eval _ p s _ x.length) hb1 hb2 c' hreach + · intro x + obtain ⟨bBody, bTest, hb1, hb2⟩ := PolyExists.exists_loop_bounds M f x L' + (2 ^ (p.eval x.length + 1) - 1) + (PolyExists.bH x.length (p.eval x.length) + (s.eval (PolyExists.bP x.length (p.eval x.length)))) + (PolyExists.bB x.length (p.eval x.length)) + (PolyExists.bHb x.length (p.eval x.length) + (s.eval (PolyExists.bP x.length (p.eval x.length)))) + exact PolyExists.enumTM_decides M s hs hdecS hdec p x _ _ _ _ bBody bTest + rfl rfl rfl rfl hb1 hb2 + +/-- **`PH ⊆ PSPACE`.** The induction on the level leaves two closure properties of `PSPACE`; +complement is `PSPACE_compl`, and the bounded existential is discharged by the witness +enumerator of `PH_enumerator_exists`. -/ +theorem PH_subset_PSPACE_internal : PH ⊆ PSPACE := + PH_subset_PSPACE_of_enumerator_internal PH_enumerator_exists + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPAssemble.lean b/Complexitylib/Classes/Containments/Internal/PPAssemble.lean new file mode 100644 index 00000000..e65c42c8 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPAssemble.lean @@ -0,0 +1,2427 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PPLayout +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub +public import Complexitylib.Models.TuringMachine.Registers.InputLen +public import Complexitylib.Models.TuringMachine.Registers.Horner + +/-! +# Assembling the counting loop's body + +⚠️ Unreviewed by Bolton + +The loop invariant names every tape: the counter and the two tallies carry their numbers, the +horizon and the wipe's register carry theirs, and everything else rests blank. This file records +what that bank looks like at each named index and proves the body's stages against it. + +## Main results + +- `NTM.bodyBank` — the bank the loop invariant pins, with its value at every named index +- `NTM.blankSlot_hoareTime` — the body's first stage: blank the verdict slot +- `NTM.publish_hoareTime` — the stage that copies the verdict into the output slot +- `NTM.simCfg_entry` — the simulation stage is entered on exactly the loop's own bank +- `NTM.afterSim`, `NTM.simTM_hoareTime` — the tape state the simulation stage leaves the body in +- `NTM.afterPark`, `NTM.parkStage_hoareTime` — the cleanup stage that follows it +- `NTM.afterPublish`, `NTM.publishStage_hoareTime` — the stage that publishes the verdict +- `NTM.afterBump`, `NTM.bumpStage_hoareTime` — the arithmetic stage +- `NTM.wipeStage_hoareTime` — the wipe, which returns the bank to the loop invariant's shape +- `NTM.afterSim_trans`, `NTM.afterPark_trans`, `NTM.afterPublish_trans`, `NTM.afterBump_trans` — + the body's intermediate states survive a phase boundary +- `NTM.bodyTM`, `NTM.bodyTM_hoareTime`, `NTM.bodyTM_hoareTime_mid` — the loop's body, its + contract, and that contract in the shape the loop rule asks for +- `NTM.tallyLoop_full`, `NTM.tallyLoop_full_bounded` — body and test together, running the tally + to its horizon, with both running times written in terms of the horizon alone +- `NTM.tallyLoop_keepsWindow_bounded`, `NTM.tallyLoop_keepsWindowOn` — and the loop's space bound + at the same layout, packaged for composition +- `NTM.prologueTM`, `NTM.prologueTM_hoareTime` — the machine's prologue and its contract +- `NTM.ppPark_hoareTime`, `NTM.ppMachine`, `NTM.ppMachine_hoareTime` — the parking step, the whole + counting machine, and its contract +- `NTM.loopEpilogue_keepsWindowOn`, `NTM.prologueRest_keepsWindowOn`, + `NTM.ppMachine_keepsWindow` — the parts composed in space, and the whole machine's window +- `NTM.lt_iff_succ_sub_eq_zero`, `NTM.epilogueTM` — the comparison the machine ends with +- `NTM.epiloguePreTM_hoareTime` — the epilogue's arithmetic +- `NTM.epilogueEq_hoareTime` — its comparison +- `NTM.afterEq`, `NTM.epiloguePostTM_hoareTime` — its publication +- `NTM.epilogueTM_hoareTime`, `NTM.epilogueTM_keepsWindowOn` — the three chained, in time and space +- `NTM.binaryEqTime_le_of_le`, `NTM.bodyTime_le` — the two running times are uniform over the loop +- `NTM.bodyTM_keepsWindowOn` — one pass of the body stays inside a window of its own width +- `NTM.bodyBank_eq_of` — the bridge from the wipe's result back to the loop invariant +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} + +/-- The bank the loop invariant pins at count `v` with tallies `a` and `r`. -/ +def bodyBank (k N H v a r : ℕ) : Fin (bodyTapes k) → Tape := + tallyWork (cIdx k) (aIdx k) (rIdx k) (bodyRest k N H) (v, a, r) + +theorem bodyBank_cIdx (k N H v a r : ℕ) : bodyBank k N H v a r (cIdx k) = natTape v := by + simp only [bodyBank, tallyWork] + simp + +theorem bodyBank_aIdx (k N H v a r : ℕ) : bodyBank k N H v a r (aIdx k) = natTape a := by + obtain ⟨hca, -⟩ := bodyIdx_distinct k + simp only [bodyBank, tallyWork, if_neg (Ne.symm hca)] + simp + +theorem bodyBank_rIdx (k N H v a r : ℕ) : bodyBank k N H v a r (rIdx k) = natTape r := by + obtain ⟨-, hcr, har, -⟩ := bodyIdx_distinct k + simp only [bodyBank, tallyWork, if_neg (Ne.symm hcr), if_neg (Ne.symm har)] + simp + +theorem bodyBank_rest (k N H v a r : ℕ) (j : Fin (bodyTapes k)) + (hc : j ≠ cIdx k) (ha : j ≠ aIdx k) (hr : j ≠ rIdx k) : + bodyBank k N H v a r j = bodyRest k N H j := by + simp only [bodyBank, tallyWork, if_neg hc, if_neg ha, if_neg hr] + +theorem bodyBank_parked (k N H v a r : ℕ) : ∀ j, TM.Parked (bodyBank k N H v a r j) := by + intro j + simp only [bodyBank, tallyWork] + split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · exact bodyRest_parked k N H j + +theorem bodyBank_cells_zero (k N H v a r : ℕ) : + ∀ j, (bodyBank k N H v a r j).cells 0 = Γ.start := by + intro j + simp only [bodyBank, tallyWork] + split + · exact natTape_cells_zero _ + · split + · exact natTape_cells_zero _ + · split + · exact natTape_cells_zero _ + · exact bodyRest_cells_zero k N H j + +theorem bodyBank_startInvariant (k N H v a r : ℕ) : + ∀ j, Tape.StartInvariant (bodyBank k N H v a r j) := + fun j => ⟨bodyBank_cells_zero k N H v a r j, fun i hi => (bodyBank_parked k N H v a r j).2 i hi⟩ + +/-- Every tape the body wipes rests blank in the loop's bank. -/ +theorem bodyBank_wipeTarget (k N H v a r : ℕ) (j : Fin (bodyTapes k)) + (hj : j.val < k ∨ j = vIdx k) : bodyBank k N H v a r j = TM.blankTape := by + have hval : j.val < k ∨ j.val = k + 7 := by + rcases hj with h | h + · exact Or.inl h + · exact Or.inr (by rw [h]; rfl) + have hne : ∀ i' : Fin (bodyTapes k), j.val ≠ i'.val → j ≠ i' := + fun i' h hh => h (congrArg Fin.val hh) + rw [bodyBank_rest k N H v a r j + (hne (cIdx k) (by simp only [cIdx]; omega)) + (hne (aIdx k) (by simp only [aIdx]; omega)) + (hne (rIdx k) (by simp only [rIdx]; omega)), + bodyRest_other k N H j + (hne (nIdx k) (by simp only [nIdx]; omega)) + (hne (regIdx k) (by simp only [regIdx]; omega))] + +/-- The permanently blank register reads a blank, which is what makes it usable as the source of +a blanking write. -/ +theorem bodyBank_zIdx_read (k N H v a r : ℕ) : + (bodyBank k N H v a r (zIdx k)).read = Γ.blank := by + obtain ⟨-, -, -, -, -, -, -, -, -, -, hzc, hza, hzr, -⟩ := bodyIdx_distinct k + have hzn : zIdx k ≠ nIdx k := by + intro h; have := congrArg Fin.val h + simp only [zIdx, nIdx] at this; omega + have hzreg : zIdx k ≠ regIdx k := by + intro h; have := congrArg Fin.val h + simp only [zIdx, regIdx] at this; omega + rw [bodyBank_rest k N H v a r _ hzc hza hzr, bodyRest_other k N H _ hzn hzreg] + exact Tape.init_nil_move_right_read + +/-- **The body's first stage: blank the verdict slot.** The loop returns to its start state with +the previous check's verdict still in the slot; the wipe that ends the body needs it blank, and so +does the simulation, whose real output tape must start blank. -/ +theorem blankSlot_hoareTime (k N H v a r : ℕ) (I : Tape) (hI : TM.Parked I) : + (TM.writeOutputBitTM (zIdx k)).HoareTime + (fun inp work out => inp = I ∧ work = bodyBank k N H v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ out = outSlot s) + (fun inp work out => inp = I ∧ work = bodyBank k N H v a r ∧ out = outSlot Γw.blank) + 1 := by + intro inp work out hpre + obtain ⟨hi, hw, s, -, ho⟩ := hpre + refine (TM.writeOutputBitTM_hoareTime_frame (zIdx k) I (bodyBank k N H v a r) + (outSlot s) hI (bodyBank_parked k N H v a r) (outSlot_parked _)).strengthen_post + (post' := fun inp work out => inp = I ∧ work = bodyBank k N H v a r ∧ + out = outSlot Γw.blank) ?_ inp work out ⟨hi, hw, ho⟩ + rintro inp' work' out' ⟨hi', hw', ho'⟩ + refine ⟨hi', hw', ?_⟩ + rw [ho', bodyBank_zIdx_read] + show (outSlot s).write (TM.readBackWrite Γ.blank).toΓ = _ + exact outSlot_write s Γw.blank + + +/-- **The bridge back to the loop invariant.** After the body's wipe, a bank that carries the +right numbers on the named registers and rests blank elsewhere *is* the bank the loop invariant +pins at the next index. -/ +theorem bodyBank_eq_of (k N H v a r : ℕ) (W : Fin (bodyTapes k) → Tape) + (hc : W (cIdx k) = natTape v) (ha : W (aIdx k) = natTape a) (hr : W (rIdx k) = natTape r) + (hn : W (nIdx k) = natTape N) (hreg : W (regIdx k) = TM.regTape H) + (hrest : ∀ j, j ∉ wipeTargets k → j ≠ cIdx k → j ≠ aIdx k → j ≠ rIdx k → j ≠ nIdx k → + j ≠ regIdx k → W j = TM.blankTape) : + (fun j => if j ∈ wipeTargets k then TM.blankTape else W j) = bodyBank k N H v a r := by + have hsim : ∀ j : Fin (bodyTapes k), j ∈ wipeTargets k → + j ≠ cIdx k ∧ j ≠ aIdx k ∧ j ≠ rIdx k ∧ j ≠ nIdx k ∧ j ≠ regIdx k := by + intro j hj + rw [mem_wipeTargets_iff] at hj + refine ⟨?_, ?_, ?_, ?_, ?_⟩ <;> + · intro h + have hval := congrArg Fin.val h + simp only [cIdx, aIdx, rIdx, nIdx, regIdx] at hval + rcases hj with hj | hj + · omega + · have := congrArg Fin.val hj + simp only [vIdx] at this + omega + funext j + by_cases hj : j ∈ wipeTargets k + · obtain ⟨h1, h2, h3, h4, h5⟩ := hsim j hj + rw [if_pos hj, bodyBank_rest k N H v a r j h1 h2 h3, bodyRest_other k N H j h4 h5] + · rw [if_neg hj] + by_cases hjc : j = cIdx k + · rw [hjc, hc, bodyBank_cIdx] + by_cases hja : j = aIdx k + · rw [hja, ha, bodyBank_aIdx] + by_cases hjr : j = rIdx k + · rw [hjr, hr, bodyBank_rIdx] + by_cases hjn : j = nIdx k + · have h1 : nIdx k ≠ cIdx k := by + intro h; have := congrArg Fin.val h; simp only [nIdx, cIdx] at this; omega + have h2 : nIdx k ≠ aIdx k := by + intro h; have := congrArg Fin.val h; simp only [nIdx, aIdx] at this; omega + have h3 : nIdx k ≠ rIdx k := by + intro h; have := congrArg Fin.val h; simp only [nIdx, rIdx] at this; omega + rw [hjn, hn, bodyBank_rest k N H v a r _ h1 h2 h3, bodyRest_nIdx] + by_cases hjreg : j = regIdx k + · have h1 : regIdx k ≠ cIdx k := by + intro h; have := congrArg Fin.val h; simp only [regIdx, cIdx] at this; omega + have h2 : regIdx k ≠ aIdx k := by + intro h; have := congrArg Fin.val h; simp only [regIdx, aIdx] at this; omega + have h3 : regIdx k ≠ rIdx k := by + intro h; have := congrArg Fin.val h; simp only [regIdx, rIdx] at this; omega + rw [hjreg, hreg, bodyBank_rest k N H v a r _ h1 h2 h3, bodyRest_regIdx] + · rw [hrest j hj hjc hja hjr hjn hjreg, + bodyBank_rest k N H v a r j hjc hja hjr, bodyRest_other k N H j hjn hjreg] + + +/-- **The stage's entry configuration is the loop's own bank.** Placing the simulation beside the +registers and redirecting its output puts exactly the tapes the loop invariant names where the +stage expects them: the machine's own tapes blank, the counter at `v`, the registers untouched, +and the verdict tape blank. -/ +theorem simCfg_entry (tm : NTM k) (x : List Bool) (N H v a r : ℕ) + (extras : Fin (0 + (k + 1) + 6) → Tape) + (hex : ∀ j, extras j = bodyBank k N H v a r j.castSucc) : + simCfg tm 6 extras (simEntry tm x v) + = (⟨(simTM tm 6).qstart, (Tape.init (x.map Γ.ofBool)).move Dir3.right, + bodyBank k N H v a r, TM.blankTape⟩ : Cfg (bodyTapes k) (simTM tm 6).Q) := by + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + refine Cfg.ext rfl rfl (funext fun j => ?_) rfl + dsimp only + by_cases hj : j.val < 0 + (k + 1) + 6 + · rw [show (simCfg tm 6 extras (simEntry tm x v)).work j + = (TM.placeWorkCfg (simCore tm) 0 6 extras (simEntry tm x v)).work ⟨j.val, hj⟩ from + TM.retargetCfg_work_lt _ _ j hj] + by_cases hmid : j.val < 0 + (k + 1) + · rw [show (⟨j.val, hj⟩ : Fin (0 + (k + 1) + 6)) + = TM.placeWorkIdx 0 6 (⟨j.val, by omega⟩ : Fin (k + 1)) from + Fin.ext (by show j.val = 0 + j.val; omega), TM.placeWorkCfg_work_middle] + show (if j.val < k then TM.blankTape else natTape v) = _ + by_cases hjk : j.val < k + · rw [if_pos hjk, + bodyBank_rest k N H v a r j + (hne j (cIdx k) (by simp only [cIdx]; omega)) + (hne j (aIdx k) (by simp only [aIdx]; omega)) + (hne j (rIdx k) (by simp only [rIdx]; omega)), + bodyRest_other k N H j + (hne j (nIdx k) (by simp only [nIdx]; omega)) + (hne j (regIdx k) (by simp only [regIdx]; omega))] + · rw [if_neg hjk, show j = cIdx k from Fin.ext (by show j.val = k; omega), bodyBank_cIdx] + · rw [TM.placeWorkCfg_work_extra _ _ _ _ _ _ (fun hcon => hmid hcon.2), hex] + congr 1 + · have hlast : j = vIdx k := Fin.ext (by + have hlt := j.isLt + show j.val = k + 7 + omega) + rw [hlast, vIdx_eq_last, + show (simCfg tm 6 extras (simEntry tm x v)).work (Fin.last (0 + (k + 1) + 6)) + = (TM.placeWorkCfg (simCore tm) 0 6 extras (simEntry tm x v)).output from + TM.retargetCfg_work_last _ _, ← vIdx_eq_last] + show TM.blankTape = _ + rw [bodyBank_rest k N H v a r (vIdx k) + (hne _ (cIdx k) (by simp only [vIdx, cIdx]; omega)) + (hne _ (aIdx k) (by simp only [vIdx, aIdx]; omega)) + (hne _ (rIdx k) (by simp only [vIdx, rIdx]; omega)), + bodyRest_other k N H (vIdx k) + (hne _ (nIdx k) (by simp only [vIdx, nIdx]; omega)) + (hne _ (regIdx k) (by simp only [vIdx, regIdx]; omega))] + + +/-- Every tape of the loop's bank is parked at cell one. -/ +theorem bodyBank_head (k N H v a r : ℕ) : ∀ j, (bodyBank k N H v a r j).head = 1 := by + intro j + simp only [bodyBank, tallyWork] + split + · rfl + · split + · rfl + · split + · rfl + · simp only [bodyRest] + split + · rfl + · split + · rfl + · rfl + +/-- The real input tape, parked at cell one, with `x` on it. -/ +def bodyInput (x : List Bool) : Tape := (Tape.init (x.map Γ.ofBool)).move Dir3.right + +theorem bodyInput_startInvariant (x : List Bool) : Tape.StartInvariant (bodyInput x) := by + refine ⟨?_, fun j hj => ?_⟩ + · show ((Tape.init (x.map Γ.ofBool)).move Dir3.right).cells 0 = Γ.start + rw [Tape.move_cells] + exact Tape.init_cells_zero _ + · show ((Tape.init (x.map Γ.ofBool)).move Dir3.right).cells j ≠ Γ.start + rw [Tape.move_cells] + exact Tape.init_ofBool_cells_ne_start x j hj + +@[simp] theorem bodyInput_head (x : List Bool) : (bodyInput x).head = 1 := rfl + +theorem bodyInput_parked (x : List Bool) : TM.Parked (bodyInput x) := + ⟨le_refl 1, fun j hj => (bodyInput_startInvariant x).2 j hj⟩ + +/-- **The tape state the simulation stage leaves the body in.** Nothing is pinned but the +registers: the simulated machine's tapes and the verdict tape hold whatever the run put there, +and the heads are only bounded. What survives is enough — the counter's digits, the registers, +the verdict bit, and a blank real output. -/ +def afterSim (k N H v a r T : ℕ) (I : Tape) (b : Bool) : TM.TapePred (bodyTapes k) := + fun inp work out => + Tape.StartInvariant inp ∧ inp.cells = I.cells ∧ inp.head ≤ 1 + T ∧ + (∀ j, Tape.StartInvariant (work j)) ∧ (∀ j, (work j).head ≤ 1 + T) ∧ + (work (cIdx k)).cells = (natTape v).cells ∧ + (∀ j : Fin (bodyTapes k), ¬ (j.val < k) → j ≠ cIdx k → j ≠ vIdx k → + work j = bodyBank k N H v a r j) ∧ + (∀ j : Fin (bodyTapes k), (j.val < k ∨ j = vIdx k) → + ∀ i, 1 + T < i → (work j).cells i = Γ.blank) ∧ + decide ((work (vIdx k)).cells 1 = Γ.one) = b ∧ + out = TM.blankTape + + +/-- **The simulation stage's contract.** From the loop's bank with a blank output slot, the +stage halts within the horizon and leaves the body in `NTM.afterSim`, carrying the acceptance bit +of path `v`. -/ +theorem simTM_hoareTime (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T v : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (N H a r : ℕ) : + (simTM tm 6).HoareTime + (fun inp work out => inp = bodyInput x ∧ work = bodyBank k N H v a r ∧ + out = TM.blankTape) + (afterSim k N H v a r T (bodyInput x) (acceptsAt tm x T v)) + T := by + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + have hentry := simCfg_entry tm x N H v a r (fun j => bodyBank k N H v a r j.castSucc) + (fun _ => rfl) + obtain ⟨c', t, hle, hcore, hreach, hhalt, hverdict⟩ := + simTM_run tm x hne hall T v hT hfT 6 (fun j => bodyBank k N H v a r j.castSucc) + (fun i _ => bodyBank_startInvariant k N H v a r _) + (fun i _ => le_of_eq (bodyBank_head k N H v a r _).symm) + (simEntry tm x v) (simEntry_dropChoice tm x v) (simEntry_counter_hasBinaryNat tm x v) + obtain ⟨hInvI', hInvW', hcellsI', hheadI', hheadW'⟩ := + simTM_frame tm 6 (fun j => bodyBank k N H v a r j.castSucc) hreach + (by rw [hentry]; exact bodyInput_startInvariant x) + (by rw [hentry]; exact fun j => bodyBank_startInvariant k N H v a r j) + (by rw [hentry]; exact TM.blankTape_startInvariant) + (by rw [hentry]; exact le_of_eq rfl) + (by rw [hentry]; exact fun j => le_of_eq (bodyBank_head k N H v a r j)) + have hstart : (⟨(simTM tm 6).qstart, inp, work, out⟩ : Cfg (bodyTapes k) (simTM tm 6).Q) + = simCfg tm 6 (fun j => bodyBank k N H v a r j.castSucc) (simEntry tm x v) := by + rw [hentry, hi, hw, ho] + rfl + refine ⟨simCfg tm 6 (fun j => bodyBank k N H v a r j.castSucc) c', t, hle, + by rw [hstart]; exact hreach, hhalt, ?_⟩ + refine ⟨hInvI', ?_, ?_, hInvW', ?_, ?_, ?_, ?_, ?_, simTM_output tm 6 _ c'⟩ + · rw [hcellsI', hentry] + rfl + · exact le_trans hheadI' (by omega) + · exact fun j => le_trans (hheadW' j) (by omega) + · have hciv : ((simEntry tm x v).work (Fin.last k)).StartInvariant := by + rw [simEntry_counter] + exact hasBinaryNat_startInvariant (Tape.init_move_right_hasBinaryNat v) + have hcih : 1 ≤ ((simEntry tm x v).work (Fin.last k)).head := by + rw [simEntry_counter] + exact le_of_eq rfl + rw [simCfg_counter_cells tm 6 (fun j => bodyBank k N H v a r j.castSucc) hcore hciv hcih + (cIdx k) rfl, hentry] + show (bodyBank k N H v a r (cIdx k)).cells = _ + rw [bodyBank_cIdx] + · intro j h1 h2 h3 + have hne7 : j.val ≠ k + 7 := fun hc => h3 (Fin.ext (by rw [hc]; rfl)) + have hnek : j.val ≠ k := fun hc => h2 (Fin.ext (by rw [hc]; rfl)) + have hjlt : j.val < 0 + (k + 1) + 6 + 1 := j.isLt + have hlt : j.val < 0 + (k + 1) + 6 := by omega + have hmid : ¬ (j.val < 0 + (k + 1)) := by omega + rw [simCfg_work_extra tm 6 (fun j => bodyBank k N H v a r j.castSucc) c' j hmid hlt] + congr 1 + · intro j hj i hi + have hhead1 : ((simCfg tm 6 (fun j => bodyBank k N H v a r j.castSucc) + (simEntry tm x v)).work j).head = 1 := by + rw [hentry] + exact bodyBank_head k N H v a r j + rw [TM.reachesIn_work_cells_far hreach j i (by rw [hhead1]; omega), hentry] + show (bodyBank k N H v a r j).cells i = Γ.blank + rw [bodyBank_wipeTarget k N H v a r j hj] + show ((Tape.init ([] : List Γ)).move Dir3.right).cells i = Γ.blank + rw [Tape.move_cells, show i = (i - 1) + 1 from by omega, Tape.init_nil_cells_succ] + · rw [← hverdict, vIdx_eq_last] + + +/-- **The tape state after the body's cleanup.** Every head is parked, the counter has been +rewound and reads as `v` again, and the verdict tape is at cell one so its bit can be published. +The simulated machine's own tapes still hold whatever the run left; the wipe deals with them. -/ +def afterPark (k N H v a r T : ℕ) (I : Tape) (b : Bool) : TM.TapePred (bodyTapes k) := + fun inp work out => + inp = I ∧ + (∀ j, Tape.StartInvariant (work j)) ∧ (∀ j, TM.Parked (work j)) ∧ + (∀ j, (work j).head ≤ 1 + T) ∧ + work (cIdx k) = natTape v ∧ + (work (vIdx k)).head = 1 ∧ decide ((work (vIdx k)).cells 1 = Γ.one) = b ∧ + (∀ j : Fin (bodyTapes k), ¬ (j.val < k) → j ≠ cIdx k → j ≠ vIdx k → + work j = bodyBank k N H v a r j) ∧ + (∀ j : Fin (bodyTapes k), (j.val < k ∨ j = vIdx k) → + ∀ i, 1 + T < i → (work j).cells i = Γ.blank) ∧ + out = TM.blankTape + +/-- **The body's cleanup stage.** It asks only for start-invariance, which is all a halted +simulation guarantees, and returns the counter and the verdict tape at cell one. -/ +theorem parkStage_hoareTime (k N H v a r T : ℕ) (I : Tape) (b : Bool) + (hIhead : I.head = 1) (hcne : cIdx k ≠ vIdx k) : + (TM.parkRewindTM [cIdx k, vIdx k]).HoareTime + (afterSim k N H v a r T I b) + (afterPark k N H v a r T I b) + (1 + 1 + (2 * (max (1 + T + 2) (2 * (1 + T + 3) + 1) + 1) + 1)) := by + intro inp work out hpre + obtain ⟨hInvI, hcellsI, hheadI, hInvW, hheadW, hcnt, hreg, hfar, hverdict, hout⟩ := hpre + have hnodup : ([cIdx k, vIdx k] : List (Fin (bodyTapes k))).Nodup := by + simp [hcne] + have hOinv : Tape.StartInvariant out := by rw [hout]; exact TM.blankTape_startInvariant + refine ((TM.parkRewindTM_hoareTime [cIdx k, vIdx k] hnodup (1 + T) (by omega) inp work out + hInvI hInvW hOinv hheadI (fun j _ => hheadW j)).strengthen_post ?_) inp work out + ⟨rfl, rfl, rfl⟩ + rintro inp' work' out' ⟨hi', hw', ho'⟩ + have hw'' : ∀ j, work' j = if j ∈ [cIdx k, vIdx k] then (⟨1, (work j).cells⟩ : Tape) + else TM.parkTape (work j) := fun j => by rw [hw'] + have hIeq : (⟨1, inp.cells⟩ : Tape) = I := Tape.ext (by rw [hIhead]) hcellsI + have hcells : ∀ j, (work' j).cells = (work j).cells := by + intro j + rw [hw'' j] + split <;> rfl + have hInvW' : ∀ j, Tape.StartInvariant (work' j) := fun j => + ⟨by rw [hcells j]; exact (hInvW j).1, fun i hi => by rw [hcells j]; exact (hInvW j).2 i hi⟩ + have hpark : ∀ j, TM.Parked (work' j) := by + intro j + refine ⟨?_, fun i hi => (hInvW' j).2 i hi⟩ + rw [hw'' j] + split + · exact le_refl 1 + · exact le_max_right _ _ + refine ⟨hIeq ▸ hi', hInvW', hpark, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · intro j + rw [hw'' j] + split + · show (1 : ℕ) ≤ 1 + T + omega + · show max (work j).head 1 ≤ 1 + T + have := hheadW j + omega + · rw [hw'' (cIdx k), if_pos (by simp)] + exact Tape.ext (by rw [(show (natTape v).head = 1 from rfl)]) hcnt + · rw [hw'' (vIdx k), if_pos (by simp)] + · rw [hw'' (vIdx k), if_pos (by simp)] + exact hverdict + · intro j h1 h2 h3 + rw [hw'' j, if_neg (by simp [h2, h3]), hreg j h1 h2 h3] + refine Tape.ext ?_ rfl + show max (bodyBank k N H v a r j).head 1 = (bodyBank k N H v a r j).head + rw [bodyBank_head] + omega + · intro j hj i hi + rw [hcells j] + exact hfar j hj i hi + · rw [ho', hout] + exact Tape.ext rfl rfl + + +/-- **The tape state once the verdict is published.** The slot now holds a symbol that is `1` +exactly when the path accepted, which is what `TM.ifTM` branches on. -/ +def afterPublish (k N H v a r T : ℕ) (I : Tape) (b : Bool) : TM.TapePred (bodyTapes k) := + fun inp work out => + inp = I ∧ + (∀ j, Tape.StartInvariant (work j)) ∧ (∀ j, TM.Parked (work j)) ∧ + (∀ j, (work j).head ≤ 1 + T) ∧ + work (cIdx k) = natTape v ∧ + (∀ j : Fin (bodyTapes k), ¬ (j.val < k) → j ≠ cIdx k → j ≠ vIdx k → + work j = bodyBank k N H v a r j) ∧ + (∀ j : Fin (bodyTapes k), (j.val < k ∨ j = vIdx k) → + ∀ i, 1 + T < i → (work j).cells i = Γ.blank) ∧ + ∃ s : Γw, (s = Γw.one ↔ b = true) ∧ out = outSlot s + +/-- **The body's publishing stage.** One transition copies the verdict tape's cell into the +output slot; nothing else on any tape moves. -/ +theorem publishStage_hoareTime (k N H v a r T : ℕ) (I : Tape) (b : Bool) (hI : TM.Parked I) : + (TM.writeOutputBitTM (vIdx k)).HoareTime + (afterPark k N H v a r T I b) + (afterPublish k N H v a r T I b) + 1 := by + intro inp work out hpre + obtain ⟨hi, hInvW, hpark, hheadW, hcnt, hvhead, hverdict, hreg, hfar, hout⟩ := hpre + have hIp : TM.Parked inp := by rw [hi]; exact hI + obtain ⟨c', t, hle, hreach, hhalt, hi', hw', ho'⟩ := + publish_hoareTime (vIdx k) inp work hIp hpark hvhead inp work out ⟨rfl, rfl, hout⟩ + refine ⟨c', t, hle, hreach, hhalt, ?_⟩ + refine ⟨by rw [hi']; exact hi, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · intro j; rw [hw']; exact hInvW j + · intro j; rw [hw']; exact hpark j + · intro j; rw [hw']; exact hheadW j + · rw [hw']; exact hcnt + · intro j h1 h2 h3; rw [hw']; exact hreg j h1 h2 h3 + · intro j hj i hi2; rw [hw']; exact hfar j hj i hi2 + · refine ⟨TM.readBackWrite ((work (vIdx k)).cells 1), ?_, ho'⟩ + rw [readBackWrite_eq_one_iff, ← hverdict] + exact decide_eq_true_iff.symm + + +/-- **The tape state after the tallies are bumped.** The count has advanced, the chosen tally has +grown by one, and the verdict slot is blank again — ready for the wipe, which needs it so. -/ +def afterBump (k N H v a r T : ℕ) (I : Tape) (b : Bool) : TM.TapePred (bodyTapes k) := + fun inp work out => + inp = I ∧ + (∀ j, Tape.StartInvariant (work j)) ∧ (∀ j, TM.Parked (work j)) ∧ + (∀ j, (work j).head ≤ 1 + T) ∧ + work (cIdx k) = natTape (v + 1) ∧ + work (aIdx k) = natTape (a + if b then 1 else 0) ∧ + work (rIdx k) = natTape (r + if b then 0 else 1) ∧ + (∀ j : Fin (bodyTapes k), ¬ (j.val < k) → j ≠ cIdx k → j ≠ aIdx k → j ≠ rIdx k → + j ≠ vIdx k → work j = bodyBank k N H v a r j) ∧ + (∀ j : Fin (bodyTapes k), (j.val < k ∨ j = vIdx k) → + ∀ i, 1 + T < i → (work j).cells i = Γ.blank) ∧ + out = outSlot Γw.blank + +/-- **The body's arithmetic stage.** The verdict in the slot picks which tally grows; the count +grows too, and the slot is blanked on the way out. -/ +theorem bumpStage_hoareTime (k N H v a r T : ℕ) (I : Tape) (b : Bool) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) (hT : 1 ≤ T) : + (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)).HoareTime + (afterPublish k N H v a r T I b) + (afterBump k N H v a r T I b) + (3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1) := by + intro inp work out hpre + obtain ⟨hi, hInvW, hpark, hheadW, hcnt, hreg, hfar, s, hb, hout⟩ := hpre + obtain ⟨hca, hcr, har, hnc, hna, hnr, hsc, hsa, hsr, hsn, hzc, hza, hzr, -⟩ := + bodyIdx_distinct k + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + have hav : work (aIdx k) = natTape a := by + rw [hreg (aIdx k) (by simp only [aIdx]; omega) (Ne.symm hca) + (hne _ _ (by simp only [aIdx, vIdx]; omega)), bodyBank_aIdx] + have hrv : work (rIdx k) = natTape r := by + rw [hreg (rIdx k) (by simp only [rIdx]; omega) (Ne.symm hcr) + (hne _ _ (by simp only [rIdx, vIdx]; omega)), bodyBank_rIdx] + have hzread : (work (zIdx k)).read = Γ.blank := by + rw [hreg (zIdx k) (by simp only [zIdx]; omega) hzc + (hne _ _ (by simp only [zIdx, vIdx]; omega))] + exact bodyBank_zIdx_read k N H v a r + have hIp : TM.Parked inp := by rw [hi]; exact hI + have hIz' : inp.cells 0 = Γ.start := by rw [hi]; exact hIz + obtain ⟨c', t, hle, hreach, hhalt, hi', hw', ho'⟩ := + TM.tallyBumpTM_hoareTime (cIdx k) (aIdx k) (rIdx k) (zIdx k) hca hcr hzc hza hzr + v a r b s hb inp work hIp hIz' hpark (fun j => (hInvW j).1) hcnt hav hrv hzread + inp work out ⟨rfl, rfl, hout⟩ + refine ⟨c', t, hle, hreach, hhalt, ?_⟩ + have hwj : ∀ j : Fin (bodyTapes k), j ≠ cIdx k → j ≠ aIdx k → j ≠ rIdx k → + c'.work j = work j := by + intro j h1 h2 h3 + rw [hw', Function.update_of_ne h1] + cases b + · simp only [Bool.false_eq_true, if_false] + rw [Function.update_of_ne h3] + · simp only [if_true] + rw [Function.update_of_ne h2] + have hwc : c'.work (cIdx k) = natTape (v + 1) := by rw [hw', Function.update_self] + have hwa : c'.work (aIdx k) = natTape (a + if b then 1 else 0) := by + rw [hw', Function.update_of_ne (Ne.symm hca)] + cases b + · simp only [Bool.false_eq_true, if_false] + rw [Function.update_of_ne har, hav] + rfl + · simp only [if_true] + rw [Function.update_self] + have hwr : c'.work (rIdx k) = natTape (r + if b then 0 else 1) := by + rw [hw', Function.update_of_ne (Ne.symm hcr)] + cases b + · simp only [Bool.false_eq_true, if_false] + rw [Function.update_self] + · simp only [if_true] + rw [Function.update_of_ne (Ne.symm har), hrv] + rfl + have hInv' : ∀ j, Tape.StartInvariant (c'.work j) := by + intro j + by_cases h1 : j = cIdx k + · rw [h1, hwc]; exact hasBinaryNat_startInvariant (Tape.init_move_right_hasBinaryNat _) + by_cases h2 : j = aIdx k + · rw [h2, hwa]; exact hasBinaryNat_startInvariant (Tape.init_move_right_hasBinaryNat _) + by_cases h3 : j = rIdx k + · rw [h3, hwr]; exact hasBinaryNat_startInvariant (Tape.init_move_right_hasBinaryNat _) + · rw [hwj j h1 h2 h3]; exact hInvW j + refine ⟨by rw [hi']; exact hi, hInv', fun j => ⟨?_, fun i hi2 => (hInv' j).2 i hi2⟩, ?_, + hwc, hwa, hwr, ?_, ?_, by rw [ho']⟩ + · by_cases h1 : j = cIdx k + · rw [h1, hwc]; exact le_of_eq rfl + by_cases h2 : j = aIdx k + · rw [h2, hwa]; exact le_of_eq rfl + by_cases h3 : j = rIdx k + · rw [h3, hwr]; exact le_of_eq rfl + · rw [hwj j h1 h2 h3]; exact (hpark j).1 + · intro j + by_cases h1 : j = cIdx k + · rw [h1, hwc]; show (1 : ℕ) ≤ 1 + T; omega + by_cases h2 : j = aIdx k + · rw [h2, hwa]; show (1 : ℕ) ≤ 1 + T; omega + by_cases h3 : j = rIdx k + · rw [h3, hwr]; show (1 : ℕ) ≤ 1 + T; omega + · rw [hwj j h1 h2 h3]; exact hheadW j + · intro j h1 h2 h3 h4 h5 + rw [hwj j h2 h3 h4] + exact hreg j h1 h2 h5 + · intro j hj i hi2 + have h1 : j ≠ cIdx k := by + rcases hj with h | h + · exact hne _ _ (by simp only [cIdx]; omega) + · rw [h]; exact hne _ _ (by simp only [vIdx, cIdx]; omega) + have h2 : j ≠ aIdx k := by + rcases hj with h | h + · exact hne _ _ (by simp only [aIdx]; omega) + · rw [h]; exact hne _ _ (by simp only [vIdx, aIdx]; omega) + have h3 : j ≠ rIdx k := by + rcases hj with h | h + · exact hne _ _ (by simp only [rIdx]; omega) + · rw [h]; exact hne _ _ (by simp only [vIdx, rIdx]; omega) + rw [hwj j h1 h2 h3] + exact hfar j hj i hi2 + + +/-- **The body's last stage.** Blanking the simulated machine's tapes and the verdict tape +returns the bank to exactly the shape the loop invariant names — at the next index, with the +tallies advanced. This is where the body closes. -/ +theorem wipeStage_hoareTime (k N T v a r : ℕ) (I : Tape) (b : Bool) + (hIsi : Tape.StartInvariant I) (hIp : TM.Parked I) : + (TM.wipeRewindTM (wipeTargets k) (regIdx k)).HoareTime + (afterBump k N (1 + T) v a r T I b) + (fun inp work out => inp = I ∧ + work = bodyBank k N (1 + T) (v + 1) (a + if b then 1 else 0) + (r + if b then 0 else 1) ∧ + out = outSlot Γw.blank) + ((wipeTargets k).length * ((1 + T) + 4) + (1 + T) * 4 + 8 + 1 + + ((wipeTargets k).length * ((1 + T) + 4) + 1)) := by + intro inp work out hpre + obtain ⟨hi, hInvW, hpark, hheadW, hwc, hwa, hwr, hreg, hfar, hout⟩ := hpre + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + have hregNotTarget := regIdx_not_mem_wipeTargets k + have hregC : regIdx k ≠ cIdx k := hne _ _ (by simp only [regIdx, cIdx]; omega) + have hregA : regIdx k ≠ aIdx k := hne _ _ (by simp only [regIdx, aIdx]; omega) + have hregR : regIdx k ≠ rIdx k := hne _ _ (by simp only [regIdx, rIdx]; omega) + have hregV : regIdx k ≠ vIdx k := hne _ _ (by simp only [regIdx, vIdx]; omega) + have hnC : nIdx k ≠ cIdx k := hne _ _ (by simp only [nIdx, cIdx]; omega) + have hnA : nIdx k ≠ aIdx k := hne _ _ (by simp only [nIdx, aIdx]; omega) + have hnR : nIdx k ≠ rIdx k := hne _ _ (by simp only [nIdx, rIdx]; omega) + have hnV : nIdx k ≠ vIdx k := hne _ _ (by simp only [nIdx, vIdx]; omega) + have hwreg : work (regIdx k) = TM.regTape (1 + T) := by + rw [hreg (regIdx k) (by simp only [regIdx]; omega) hregC hregA hregR hregV, + bodyBank_rest k N (1 + T) v a r (regIdx k) hregC hregA hregR, bodyRest_regIdx] + have hwn : work (nIdx k) = natTape N := by + rw [hreg (nIdx k) (by simp only [nIdx]; omega) hnC hnA hnR hnV, + bodyBank_rest k N (1 + T) v a r (nIdx k) hnC hnA hnR, bodyRest_nIdx] + have hout' : out = TM.blankTape := by rw [hout, outSlot_blank_eq_blankTape] + obtain ⟨c', t, hle, hreach, hhalt, hi', hw', ho'⟩ := + TM.wipeRewindTM_hoareTime (wipeTargets k) (wipeTargets_nodup k) (regIdx k) hregNotTarget + (1 + T) inp work out (by rw [hi]; exact hIsi) (by rw [hi]; exact hIp) hout' + (fun j _ => hInvW j) + (fun j _ => hheadW j) + (fun j hj i hi2 => hfar j (by rwa [mem_wipeTargets_iff] at hj) i hi2) + hwreg (fun j hjr _ => hpark j) + inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', t, hle, hreach, hhalt, by rw [hi']; exact hi, ?_, by rw [ho']; exact hout⟩ + rw [hw'] + refine bodyBank_eq_of k N (1 + T) (v + 1) (a + if b then 1 else 0) (r + if b then 0 else 1) + work hwc hwa hwr hwn hwreg ?_ + intro j hj h1 h2 h3 h4 h5 + rw [mem_wipeTargets_iff] at hj + have hjk : ¬ (j.val < k) := fun hc => hj (Or.inl hc) + have hjv : j ≠ vIdx k := fun hc => hj (Or.inr hc) + rw [hreg j hjk h1 h2 h3 hjv, bodyBank_rest k N (1 + T) v a r j h1 h2 h3, + bodyRest_other k N (1 + T) j h4 h5] + + +/-- **The post-simulation state survives a phase boundary.** It is stated in terms of cells and +head *bounds* rather than exact tapes, which is what makes it stable: a transition preserves every +cell and never pushes a head outward. A predicate that pinned the tapes could not survive here, +because a halted simulation may leave a head on the marker, which the boundary then moves. -/ +theorem afterSim_trans (k N H v a r T : ℕ) (I : Tape) (b : Bool) + (inp : Tape) (work : Fin (bodyTapes k) → Tape) (out : Tape) + (h : afterSim k N H v a r T I b inp work out) : + afterSim k N H v a r T I b (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨hInvI, hcellsI, hheadI, hInvW, hheadW, hcnt, hreg, hfar, hverdict, hout⟩ := h + have hcells : ∀ j, (TM.transitionTape (work j)).cells = (work j).cells := + fun j => TM.transitionTape_cells _ (fun i hi => (hInvW j).2 i hi) + refine ⟨TM.startInvariant_transitionInput hInvI, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [TM.transitionInput_cells]; exact hcellsI + · exact le_trans (TM.head_transitionInput_le_max hInvI) (by omega) + · exact fun j => TM.startInvariant_transitionTape (hInvW j) + · intro j + exact le_trans (TM.head_transitionTape_le_max (hInvW j)) (by have := hheadW j; omega) + · show (TM.transitionTape (work (cIdx k))).cells = _ + rw [hcells]; exact hcnt + · intro j h1 h2 h3 + show TM.transitionTape (work j) = _ + rw [hreg j h1 h2 h3] + exact TM.transitionTape_eq_self (bodyBank_parked k N H v a r j).read_ne_start + · intro j hj i hi + show (TM.transitionTape (work j)).cells i = _ + rw [hcells]; exact hfar j hj i hi + · show decide ((TM.transitionTape (work (vIdx k))).cells 1 = Γ.one) = b + rw [hcells]; exact hverdict + · rw [hout] + exact TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start + + +/-- The pinned states between the body's later stages survive a phase boundary too, and for the +easy reason: every tape they name is parked, so the boundary is the identity. -/ +theorem afterPark_trans (k N H v a r T : ℕ) (I : Tape) (b : Bool) (hI : TM.Parked I) + (inp : Tape) (work : Fin (bodyTapes k) → Tape) (out : Tape) + (h : afterPark k N H v a r T I b inp work out) : + afterPark k N H v a r T I b (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨hi, hInvW, hpark, hheadW, hcnt, hvhead, hverdict, hreg, hfar, hout⟩ := h + have hid : ∀ j, TM.transitionTape (work j) = work j := + fun j => TM.transitionTape_eq_self (hpark j).read_ne_start + have hidI : TM.transitionInput inp = inp := by + rw [hi]; exact TM.transitionInput_eq_self hI.read_ne_start + have hidO : TM.transitionTape out = out := by + rw [hout]; exact TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start + rw [hidI, hidO, show (fun i => TM.transitionTape (work i)) = work from funext hid] + exact ⟨hi, hInvW, hpark, hheadW, hcnt, hvhead, hverdict, hreg, hfar, hout⟩ + +/-- The same, once the verdict is in the slot. -/ +theorem afterPublish_trans (k N H v a r T : ℕ) (I : Tape) (b : Bool) (hI : TM.Parked I) + (inp : Tape) (work : Fin (bodyTapes k) → Tape) (out : Tape) + (h : afterPublish k N H v a r T I b inp work out) : + afterPublish k N H v a r T I b (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨hi, hInvW, hpark, hheadW, hcnt, hreg, hfar, s, hb, hout⟩ := h + have hid : ∀ j, TM.transitionTape (work j) = work j := + fun j => TM.transitionTape_eq_self (hpark j).read_ne_start + have hidI : TM.transitionInput inp = inp := by + rw [hi]; exact TM.transitionInput_eq_self hI.read_ne_start + have hidO : TM.transitionTape out = out := by + rw [hout]; exact TM.transitionTape_eq_self (outSlot_parked s).read_ne_start + rw [hidI, hidO, show (fun i => TM.transitionTape (work i)) = work from funext hid] + exact ⟨hi, hInvW, hpark, hheadW, hcnt, hreg, hfar, s, hb, hout⟩ + +/-- The same, once the tallies have been bumped. -/ +theorem afterBump_trans (k N H v a r T : ℕ) (I : Tape) (b : Bool) (hI : TM.Parked I) + (inp : Tape) (work : Fin (bodyTapes k) → Tape) (out : Tape) + (h : afterBump k N H v a r T I b inp work out) : + afterBump k N H v a r T I b (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + obtain ⟨hi, hInvW, hpark, hheadW, hwc, hwa, hwr, hreg, hfar, hout⟩ := h + have hid : ∀ j, TM.transitionTape (work j) = work j := + fun j => TM.transitionTape_eq_self (hpark j).read_ne_start + have hidI : TM.transitionInput inp = inp := by + rw [hi]; exact TM.transitionInput_eq_self hI.read_ne_start + have hidO : TM.transitionTape out = out := by + rw [hout]; exact TM.transitionTape_eq_self (outSlot_parked Γw.blank).read_ne_start + rw [hidI, hidO, show (fun i => TM.transitionTape (work i)) = work from funext hid] + exact ⟨hi, hInvW, hpark, hheadW, hwc, hwa, hwr, hreg, hfar, hout⟩ + + +/-- **The counting loop's body.** Blank the verdict slot, simulate one path, put the heads back, +publish the verdict, bump the tallies and the count, and wipe the scratch tapes. -/ +def bodyTM (tm : NTM k) : TM (bodyTapes k) := + TM.seqTM (TM.writeOutputBitTM (zIdx k)) + (TM.seqTM (simTM tm 6) + (TM.seqTM (TM.parkRewindTM [cIdx k, vIdx k]) + (TM.seqTM (TM.writeOutputBitTM (vIdx k)) + (TM.seqTM (TM.tallyBumpTM (cIdx k) (aIdx k) (rIdx k) (zIdx k)) + (TM.wipeRewindTM (wipeTargets k) (regIdx k)))))) + +/-- The body's running time: the six stages plus the five transitions between them. -/ +def bodyTime (k T v a r : ℕ) : ℕ := + 1 + 1 + (T + 1 + + ((1 + 1 + (2 * (max (1 + T + 2) (2 * (1 + T + 3) + 1) + 1) + 1)) + 1 + + (1 + 1 + + ((3 * (max (1 + 1 + max (TM.binarySuccTime a) (TM.binarySuccTime r) + 5) + (TM.binarySuccTime v) + 1) + 1) + 1 + + ((wipeTargets k).length * ((1 + T) + 4) + (1 + T) * 4 + 8 + 1 + + ((wipeTargets k).length * ((1 + T) + 4) + 1)))))) + +/-- **The body's contract.** One pass advances the count by one and the accepting or rejecting +tally by one, according to whether the path selected by the counter accepts. -/ +theorem bodyTM_hoareTime (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T v : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (N a r : ℕ) : + (bodyTM tm).HoareTime + (fun inp work out => inp = bodyInput x ∧ work = bodyBank k N (1 + T) v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ out = outSlot s) + (fun inp work out => inp = bodyInput x ∧ + work = bodyBank k N (1 + T) (v + 1) + (a + if acceptsAt tm x T v then 1 else 0) + (r + if acceptsAt tm x T v then 0 else 1) ∧ + out = outSlot Γw.blank) + (bodyTime k T v a r) := by + set b := acceptsAt tm x T v with hb + set I := bodyInput x with hIdef + have hIp : TM.Parked I := bodyInput_parked x + have hIsi : Tape.StartInvariant I := bodyInput_startInvariant x + have hIz : I.cells 0 = Γ.start := hIsi.1 + have hcne : cIdx k ≠ vIdx k := fun h => by + have := congrArg Fin.val h + simp only [cIdx, vIdx] at this + omega + -- Stage one, with its post in the shape the simulation expects. + have h1 : (TM.writeOutputBitTM (zIdx k)).HoareTime + (fun inp work out => inp = I ∧ work = bodyBank k N (1 + T) v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ out = outSlot s) + (fun inp work out => inp = I ∧ work = bodyBank k N (1 + T) v a r ∧ + out = TM.blankTape) 1 := + (blankSlot_hoareTime k N (1 + T) v a r I hIp).strengthen_post + (fun _ _ _ h => ⟨h.1, h.2.1, by rw [h.2.2, outSlot_blank_eq_blankTape]⟩) + have htrans1 : ∀ inp work out, + (inp = I ∧ work = bodyBank k N (1 + T) v a r ∧ out = TM.blankTape) → + (TM.transitionInput inp = I ∧ + (fun i => TM.transitionTape (work i)) = bodyBank k N (1 + T) v a r ∧ + TM.transitionTape out = TM.blankTape) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hIp.read_ne_start, + funext fun i => TM.transitionTape_eq_self (bodyBank_parked k N (1 + T) v a r i).read_ne_start, + TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start⟩ + -- The five remaining stages, folded from the inside out. + have h6 := wipeStage_hoareTime k N T v a r I b hIsi hIp + have h5 := TM.seqTM_hoareTime _ _ (bumpStage_hoareTime k N (1 + T) v a r T I b hIp hIz hT) + (afterBump_trans k N (1 + T) v a r T I b hIp) h6 + have h4 := TM.seqTM_hoareTime _ _ (publishStage_hoareTime k N (1 + T) v a r T I b hIp) + (afterPublish_trans k N (1 + T) v a r T I b hIp) h5 + have h3 := TM.seqTM_hoareTime _ _ + (parkStage_hoareTime k N (1 + T) v a r T I b (bodyInput_head x) hcne) + (afterPark_trans k N (1 + T) v a r T I b hIp) h4 + have h2 := TM.seqTM_hoareTime _ _ (simTM_hoareTime tm x hne hall T v hT hfT N (1 + T) a r) + (afterSim_trans k N (1 + T) v a r T I b) h3 + exact TM.seqTM_hoareTime _ _ h1 htrans1 h2 + + +/-- The tape state the body hands to the test: the bank at the next index, verdict slot blank. -/ +def bodyMid (k N T : ℕ) (x : List Bool) (tm : NTM k) (v : ℕ) : TM.TapePred (bodyTapes k) := + fun inp work out => inp = bodyInput x ∧ + work = bodyBank k N (1 + T) (v + 1) (tally (acceptsAt tm x T) (v + 1)) + (tally (fun u => !acceptsAt tm x T u) (v + 1)) ∧ + out = outSlot Γw.blank + +/-- **The body meets the loop rule's obligation.** Its contract is the tally step: the count +advances and exactly one of the two tallies grows. -/ +theorem bodyTM_hoareTime_mid (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (N bBody : ℕ) (v : ℕ) + (hbound : bodyTime k T v (tally (acceptsAt tm x T) v) + (tally (fun u => !acceptsAt tm x T u) v) ≤ bBody) : + (bodyTM tm).HoareTime + (tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) v) + (bodyMid k N T x tm v) bBody := by + refine ((bodyTM_hoareTime tm x hne hall T v hT hfT N + (tally (acceptsAt tm x T) v) (tally (fun u => !acceptsAt tm x T u) v)).strengthen_post + ?_).mono_bound hbound + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw] + congr 1 + have hflip : (if !acceptsAt tm x T v then 1 else 0) + = (if acceptsAt tm x T v then 0 else 1) := by + cases acceptsAt tm x T v <;> simp + show tally (fun u => !acceptsAt tm x T u) v + (if acceptsAt tm x T v then 0 else 1) + = tally (fun u => !acceptsAt tm x T u) v + (if !acceptsAt tm x T v then 1 else 0) + rw [hflip] + + +/-- **The counting loop.** Body and test together run the tally to its horizon: the counter walks +from `0` to `N`, and the two tallies end holding how many of the paths accepted and how many +did not. -/ +theorem tallyLoop_full (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T N : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (hN : 1 ≤ N) (bBody bTest B : ℕ) + (hbBody : ∀ v, v < N → bodyTime k T v (tally (acceptsAt tm x T) v) + (tally (fun u => !acceptsAt tm x T u) v) ≤ bBody) + (hbTest : ∀ w, w ≤ N → TM.binaryEqTime w.bits N.bits + 1 + + (3 * (max (3 * (B + 3) + 1) (TM.resetBinaryWorkTime B 1) + 1) + 1) ≤ bTest) + (hBw : ∀ w, w ≤ N → 1 + 1 + TM.binaryEqTime w.bits N.bits ≤ B) : + (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).HoareTime + (tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) 0) + (tallyPost (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) N N) + (N * (bBody + bTest + 5)) := by + have hne' : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + obtain ⟨-, -, -, hnc, hna, hnr, hsc, hsa, hsr, hsn, -⟩ := bodyIdx_distinct k + have hd : TM.BinaryEqDistinct (cIdx k) (nIdx k) (resIdx k) := + ⟨Ne.symm hnc, Ne.symm hsc, Ne.symm hsn⟩ + refine tallyLoop_hoareTime_of_hoare (bodyTM tm) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) (cIdx k) (aIdx k) (rIdx k) (bodyInput x) + (bodyRest k N (1 + T)) (acceptsAt tm x T) (bodyMid k N T x tm) N bBody bTest hN + (bodyInput_parked x) (bodyRest_parked k N (1 + T)) ?_ ?_ ?_ + · intro v hv + exact bodyTM_hoareTime_mid tm x hne hall T hT hfT N bBody v (hbBody v hv) + · rintro v inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨bodyInput_parked x, bodyBank_parked k N (1 + T) _ _ _, outSlot_parked _, rfl, rfl⟩ + · intro v hv + refine (tallyTestTM_hoareTime_tallyPost (cIdx k) (aIdx k) (rIdx k) (nIdx k) (resIdx k) hd + hnc hna hnr hsc hsa hsr (bodyInput x) (bodyRest k N (1 + T)) (acceptsAt tm x T) N (v + 1) + B 1 (bodyInput_parked x) (bodyInput_startInvariant x).1 + (bodyRest_parked k N (1 + T)) (bodyRest_cells_zero k N (1 + T)) + (fun j => le_of_eq (bodyRest_head k N (1 + T) j)) + (bodyRest_nIdx k N (1 + T)) (bodyRest_other k N (1 + T) (resIdx k) hsn + (hne' _ _ (by simp only [resIdx, regIdx]; omega))) + (hBw (v + 1) (by omega))).mono_bound (hbTest (v + 1) (by omega)) + + +/-- **The comparison's running time is uniform over the loop.** Every count the loop compares is +at most the horizon, and a smaller number has no more binary digits, so one bound serves every +iteration — which is what the loop rule demands. -/ +theorem binaryEqTime_le_of_le (w N : ℕ) (h : w ≤ N) : + TM.binaryEqTime w.bits N.bits = N.bits.length + 1 := by + have hlen : w.bits.length ≤ N.bits.length := by + rw [Nat.size_eq_bits_len, Nat.size_eq_bits_len] + exact Nat.size_le_size h + show max w.bits.length N.bits.length + 1 = _ + omega + + +/-- A tally over `[0, v)` counts at most `v` things. -/ +theorem tally_le (P : ℕ → Bool) : ∀ v, tally P v ≤ v + | 0 => le_refl 0 + | v + 1 => by + show tally P v + (if P v then 1 else 0) ≤ v + 1 + have := tally_le P v + split <;> omega + +/-- The body's running time with every value-dependent part replaced by its bound at the +horizon. -/ +def bodyTimeBound (k T N : ℕ) : ℕ := + 1 + 1 + (T + 1 + + ((1 + 1 + (2 * (max (1 + T + 2) (2 * (1 + T + 3) + 1) + 1) + 1)) + 1 + + (1 + 1 + + ((3 * (max (1 + 1 + max (2 * N.size + 2) (2 * N.size + 2) + 5) + (2 * N.size + 2) + 1) + 1) + 1 + + ((wipeTargets k).length * ((1 + T) + 4) + (1 + T) * 4 + 8 + 1 + + ((wipeTargets k).length * ((1 + T) + 4) + 1)))))) + +/-- **The body's running time is uniform over the loop.** Only three parts of it depend on the +iteration — the three counter increments — and each is bounded by the width of the horizon, since +neither the count nor either tally ever exceeds it. -/ +theorem bodyTime_le (k T N v : ℕ) (P : ℕ → Bool) (hv : v ≤ N) : + bodyTime k T v (tally P v) (tally (fun u => !P u) v) ≤ bodyTimeBound k T N := by + have hb : ∀ w, w ≤ N → TM.binarySuccTime w ≤ 2 * N.size + 2 := by + intro w hw + have h1 := TM.binarySuccTime_le w + have h2 := Nat.size_le_size hw + omega + have hv' := hb v hv + have ha := hb (tally P v) (le_trans (tally_le P v) hv) + have hr := hb (tally (fun u => !P u) v) (le_trans (tally_le _ v) hv) + unfold bodyTime bodyTimeBound + gcongr + + +/-- The head bound the test's rewinds need: enough for the horizon's digits. -/ +def testB (N : ℕ) : ℕ := N.bits.length + 3 + +/-- The test's running time at the horizon. -/ +def testTimeBound (N : ℕ) : ℕ := + (N.bits.length + 1) + 1 + + (3 * (max (3 * (testB N + 3) + 1) (TM.resetBinaryWorkTime (testB N) 1) + 1) + 1) + +/-- **The counting loop with concrete bounds.** Both running times are now written in terms of +the horizon alone, which is what a polynomial space bound will need. -/ +theorem tallyLoop_full_bounded (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T N : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (hN : 1 ≤ N) : + (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).HoareTime + (tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) 0) + (tallyPost (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) N N) + (N * (bodyTimeBound k T N + testTimeBound N + 5)) := + tallyLoop_full tm x hne hall T N hT hfT hN (bodyTimeBound k T N) (testTimeBound N) (testB N) + (fun v hv => bodyTime_le k T N v (acceptsAt tm x T) (le_of_lt hv)) + (fun w hw => by + rw [binaryEqTime_le_of_le w N hw] + exact le_of_eq rfl) + (fun w hw => by + rw [binaryEqTime_le_of_le w N hw] + show 1 + 1 + (N.bits.length + 1) ≤ testB N + unfold testB + omega) + + +/-- **The body keeps a window.** Its running time bounds how far any head can drift during one +pass, and every tape it starts from is parked at cell one, so the whole pass stays inside a +window of that width — independent of which iteration it is. -/ +theorem bodyTM_keepsWindowOn (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T v : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (N a r : ℕ) : + (bodyTM tm).KeepsWindowOn + (fun c => c.state = (bodyTM tm).qstart ∧ + (c.input = bodyInput x ∧ c.work = bodyBank k N (1 + T) v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ c.output = outSlot s)) + x.length (1 + bodyTime k T v a r) := + TM.keepsWindowOn_of_hoareTime (bodyTM_hoareTime tm x hne hall T v hT hfT N a r) + (fun _ work _ hpre i => by rw [hpre.2.1]; exact le_of_eq (bodyBank_head k N (1 + T) v a r i)) + (fun inp _ _ hpre => by rw [hpre.1, bodyInput_head]; omega) + (fun _ _ out hpre => by + obtain ⟨-, -, s, -, ho⟩ := hpre + rw [ho] + show (1 : ℕ) ≤ 1 + 1 + omega) + + +/-- **The counting loop's space bound at the concrete layout.** Every configuration the loop ever +reaches fits inside a window one iteration wide — and one iteration's width is a polynomial in +the horizon, not in the exponentially many iterations. -/ +theorem tallyLoop_keepsWindow_bounded (tm : NTM k) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T N : ℕ) + (hT : 1 ≤ T) (hfT : f x.length ≤ T) (hN : 1 ≤ N) : + ∀ inp work out, + tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) 0 inp work out → + ∀ c, (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).reaches + ⟨(TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, + inp, work, out⟩ c → + c.WithinDecisionSpace x.length + (1 + (bodyTimeBound k T N + testTimeBound N + 5)) := by + have hne' : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + obtain ⟨-, -, -, hnc, hna, hnr, hsc, hsa, hsr, hsn, -⟩ := bodyIdx_distinct k + have hd : TM.BinaryEqDistinct (cIdx k) (nIdx k) (resIdx k) := + ⟨Ne.symm hnc, Ne.symm hsc, Ne.symm hsn⟩ + refine tallyLoop_keepsWindow_of_hoare (bodyTM tm) + (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k)) (cIdx k) (aIdx k) (rIdx k) (bodyInput x) + (bodyRest k N (1 + T)) (acceptsAt tm x T) (bodyMid k N T x tm) N + (bodyTimeBound k T N) (testTimeBound N) x.length hN + (bodyInput_parked x) (bodyRest_parked k N (1 + T)) + (by rw [bodyInput_head]; omega) (fun i => le_of_eq (bodyRest_head k N (1 + T) i)) ?_ ?_ ?_ + · intro v hv + exact bodyTM_hoareTime_mid tm x hne hall T hT hfT N (bodyTimeBound k T N) v + (bodyTime_le k T N v (acceptsAt tm x T) (le_of_lt hv)) + · rintro v inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨bodyInput_parked x, bodyBank_parked k N (1 + T) _ _ _, outSlot_parked _, rfl, rfl⟩ + · intro v hv + refine (tallyTestTM_hoareTime_tallyPost (cIdx k) (aIdx k) (rIdx k) (nIdx k) (resIdx k) hd + hnc hna hnr hsc hsa hsr (bodyInput x) (bodyRest k N (1 + T)) (acceptsAt tm x T) N (v + 1) + (testB N) 1 (bodyInput_parked x) (bodyInput_startInvariant x).1 + (bodyRest_parked k N (1 + T)) (bodyRest_cells_zero k N (1 + T)) + (fun j => le_of_eq (bodyRest_head k N (1 + T) j)) + (bodyRest_nIdx k N (1 + T)) (bodyRest_other k N (1 + T) (resIdx k) hsn + (hne' _ _ (by simp only [resIdx, regIdx]; omega))) + (by + rw [binaryEqTime_le_of_le (v + 1) N (by omega)] + show 1 + 1 + (N.bits.length + 1) ≤ testB N + unfold testB + omega)).mono_bound (by + rw [binaryEqTime_le_of_le (v + 1) N (by omega)] + exact le_of_eq rfl) + + +/-- **The comparison the epilogue actually performs.** Testing `r < a` directly would need a +strict comparator; testing `(r + 1) - a = 0` needs only truncated subtraction and an equality +test against zero, both of which the subroutine library already has — and it avoids having to +complement the verdict afterwards. -/ +theorem lt_iff_succ_sub_eq_zero (r a : ℕ) : r < a ↔ (r + 1) - a = 0 := by + rw [Nat.sub_eq_zero_iff_le] + omega + +/-- **The counting machine's epilogue.** Bump the rejecting tally, subtract the accepting one +from it, clear the counter to reuse as scratch, test the difference against zero, and publish the +answer. The counter's value is spent by this point, which is what frees a register for the test's +result. -/ +def epiloguePreTM (k : ℕ) : TM (bodyTapes k) := + TM.bigSeqTM + [TM.binarySuccTM (rIdx k), + TM.binaryRippleSubTM (rIdx k) (aIdx k) (resIdx k), + TM.resetBinaryWorkTM (cIdx k)] + +/-- The epilogue's tail: put the equality test's answer at cell one and publish it. -/ +def epiloguePostTM (k : ℕ) : TM (bodyTapes k) := + TM.seqTM (TM.bigSeqTM ([cIdx k].map TM.rewindWorkTM)) (TM.writeOutputBitTM (cIdx k)) + +/-- **The counting machine's epilogue.** Bump the rejecting tally, subtract the accepting one +from it, clear the counter to reuse as scratch, test the difference against zero, and publish the +answer. -/ +def epilogueTM (k : ℕ) : TM (bodyTapes k) := + TM.seqTM (epiloguePreTM k) + (TM.seqTM (TM.binaryEqTM (resIdx k) (zIdx k) (cIdx k)) (epiloguePostTM k)) + +/-- The bank the epilogue's arithmetic leaves behind. -/ +def epilogueBank (k N H a r : ℕ) : Fin (bodyTapes k) → Tape := + Function.update + (Function.update + (Function.update (bodyBank k N H N a r) (rIdx k) (natTape (r + 1))) + (resIdx k) (natTape ((r + 1) - a))) + (cIdx k) TM.blankTape + + +/-- **The epilogue's arithmetic, contracted.** Three pinned stages: bump the rejecting tally, +subtract the accepting one from it, and clear the counter — whose value is spent — to free a +register for the comparison that follows. -/ +theorem epiloguePreTM_hoareTime (k N H a r : ℕ) (I O : Tape) + (hI : TM.Parked I) (hO : TM.Parked O) : + (epiloguePreTM k).HoareTime + (fun inp work out => inp = I ∧ work = bodyBank k N H N a r ∧ out = O) + (fun inp work out => inp = I ∧ work = epilogueBank k N H a r ∧ out = O) + (3 * (max (max (TM.binarySuccTime r) (TM.binaryRippleSubTime (r + 1) a)) + (TM.resetBinaryWorkTime 1 N.bits.length) + 1) + 1) := by + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + obtain ⟨hca, hcr, har, -⟩ := bodyIdx_distinct k + have hsc : resIdx k ≠ cIdx k := hne _ _ (by simp only [resIdx, cIdx]; omega) + have hsa : resIdx k ≠ aIdx k := hne _ _ (by simp only [resIdx, aIdx]; omega) + have hsr : resIdx k ≠ rIdx k := hne _ _ (by simp only [resIdx, rIdx]; omega) + have hsn : resIdx k ≠ nIdx k := hne _ _ (by simp only [resIdx, nIdx]; omega) + have hsreg : resIdx k ≠ regIdx k := hne _ _ (by simp only [resIdx, regIdx]; omega) + set W0 := bodyBank k N H N a r with hW0 + set W1 := Function.update W0 (rIdx k) (natTape (r + 1)) with hW1 + set W2 := Function.update W1 (resIdx k) (natTape ((r + 1) - a)) with hW2 + set W3 := Function.update W2 (cIdx k) TM.blankTape with hW3 + have hW0P : ∀ j, TM.Parked (W0 j) := bodyBank_parked k N H N a r + have hupd : ∀ (W : Fin (bodyTapes k) → Tape) (i : Fin (bodyTapes k)) (t : Tape), + (∀ j, TM.Parked (W j)) → TM.Parked t → ∀ j, TM.Parked (Function.update W i t j) := by + intro W i t hW ht j + by_cases hj : j = i + · rw [hj, Function.update_self]; exact ht + · rw [Function.update_of_ne hj]; exact hW j + have hW1P : ∀ j, TM.Parked (W1 j) := hupd _ _ _ hW0P (natTape_parked _) + have hW2P : ∀ j, TM.Parked (W2 j) := hupd _ _ _ hW1P (natTape_parked _) + have hW3P : ∀ j, TM.Parked (W3 j) := hupd _ _ _ hW2P TM.blankTape_parked + have hW1r : W1 (rIdx k) = natTape (r + 1) := by rw [hW1, Function.update_self] + have hW1a : W1 (aIdx k) = natTape a := by + rw [hW1, Function.update_of_ne har, hW0, bodyBank_aIdx] + have hW1s : (W1 (resIdx k)).HasBinaryNat 0 := by + rw [hW1, Function.update_of_ne hsr, hW0, + bodyBank_rest k N H N a r (resIdx k) hsc hsa hsr, bodyRest_other k N H _ hsn hsreg] + exact Tape.init_move_right_hasBinaryNat 0 + have hW2c : W2 (cIdx k) = natTape N := by + rw [hW2, Function.update_of_ne (Ne.symm hsc), hW1, Function.update_of_ne hcr, + hW0, bodyBank_cIdx] + set bnd := max (max (TM.binarySuccTime r) (TM.binaryRippleSubTime (r + 1) a)) + (TM.resetBinaryWorkTime 1 N.bits.length) with hbnd + refine (TM.bigSeqTM_hoareTime_pinned + [TM.binarySuccTM (rIdx k), TM.binaryRippleSubTM (rIdx k) (aIdx k) (resIdx k), + TM.resetBinaryWorkTM (cIdx k)] + I (fun j => if j = 0 then W0 else if j = 1 then W1 else if j = 2 then W2 else W3) + (fun _ => O) bnd hI ?_ (fun _ => hO) ?_).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (le_refl _) + · intro j i + dsimp only + split + · exact hW0P i + · split + · exact hW1P i + · split + · exact hW2P i + · exact hW3P i + · intro j hj + match j, hj with + | 0, _ => + show (TM.binarySuccTM (rIdx k)).HoareTime _ _ _ + exact (TM.binarySuccTM_hoareTime_pinned (rIdx k) r I W0 O + (by rw [hW0, bodyBank_rIdx]) hI.read_ne_start + (fun i _ => (hW0P i).read_ne_start) hO.read_ne_start).mono_bound + (le_trans (le_max_left _ _) (le_max_left _ _)) + | 1, _ => + show (TM.binaryRippleSubTM (rIdx k) (aIdx k) (resIdx k)).HoareTime _ _ _ + exact (TM.binaryRippleSubTM_hoareTime_pinned (rIdx k) (aIdx k) (resIdx k) + ⟨Ne.symm har, Ne.symm hsr, Ne.symm hsa⟩ (r + 1) a I W1 O hW1r hW1a hW1s hI + (fun i _ _ _ => hW1P i) hO).mono_bound + (le_trans (le_max_right _ _) (le_max_left _ _)) + | 2, _ => + show (TM.resetBinaryWorkTM (cIdx k)).HoareTime _ _ _ + refine ((TM.resetBinaryWorkTM_hoareTime_frame (cIdx k) N.bits 1 I W2 O ?_ ?_ ?_ hI + (fun i _ => hW2P i) hO).strengthen_post ?_).mono_bound (le_max_right _ _) + · rw [hW2c] + exact (Tape.init_move_right_hasBinaryNat N).2.2 + · rw [hW2c] + exact (Tape.init_move_right_hasBinaryNat N).1 + · rw [hW2c] + exact ⟨le_of_eq rfl, le_of_eq rfl⟩ + · rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, by rw [hw]; rfl, ho⟩ + + +/-- The state between the epilogue's comparison and its publication: the answer sits on the +counter tape, which the comparison used as its result register. -/ +def afterEq (k : ℕ) (b : Bool) (I : Tape) (B : ℕ) : TM.TapePred (bodyTapes k) := + fun inp work out => inp = I ∧ out = outSlot Γw.one ∧ + (∀ j, TM.Parked (work j)) ∧ (∀ j, (work j).cells 0 = Γ.start) ∧ + (work (cIdx k)).head ≤ B ∧ (work (cIdx k)).cells 1 = Γ.ofBool b + +/-- **The epilogue's publication.** Rewind the register holding the comparison's answer and copy +its bit into the output slot, where the surrounding obligation reads it. -/ +theorem epiloguePostTM_hoareTime (k : ℕ) (b : Bool) (I : Tape) (B : ℕ) (hI : TM.Parked I) : + (epiloguePostTM k).HoareTime + (afterEq k b I B) + (fun _inp _work out => out = outSlot (TM.readBackWrite (Γ.ofBool b))) + (1 * (B + 3) + 1 + 1 + 1) := by + intro inp work out hpre + obtain ⟨hi, ho, hpark, hzero, hhead, hcell⟩ := hpre + have hIp : TM.Parked inp := by rw [hi]; exact hI + have hOp : TM.Parked out := by rw [ho]; exact outSlot_parked _ + set W' : Fin (bodyTapes k) → Tape := + fun j => if j = cIdx k then (⟨1, (work (cIdx k)).cells⟩ : Tape) else work j with hW' + have hW'P : ∀ j, TM.Parked (W' j) := by + intro j + simp only [hW'] + split + · exact ⟨le_refl 1, fun i hi2 => (hpark (cIdx k)).2 i hi2⟩ + · exact hpark j + have hrew : (TM.bigSeqTM ([cIdx k].map TM.rewindWorkTM)).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => inp' = inp ∧ work' = W' ∧ out' = out) + (1 * (B + 3) + 1) := by + refine ((TM.rewindList_hoareTime [cIdx k] (by simp) B inp work out hIp hOp hpark + ?_).strengthen_post ?_).mono_bound (by simp) + · intro j hj + rw [List.mem_singleton.mp hj] + exact ⟨hzero (cIdx k), hhead⟩ + · rintro inp' work' out' ⟨rfl, rfl, hin, hout⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + by_cases hj : j = cIdx k + · rw [hj, hin (cIdx k) (by simp), hW'] + simp + · rw [hout j (by simpa using hj), hW'] + simp [hj] + have htrans : ∀ inp' work' out', (inp' = inp ∧ work' = W' ∧ out' = out) → + (TM.transitionInput inp' = inp ∧ (fun i => TM.transitionTape (work' i)) = W' ∧ + TM.transitionTape out' = out) := by + rintro inp' work' out' ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hIp.read_ne_start, + funext fun i => TM.transitionTape_eq_self (hW'P i).read_ne_start, + TM.transitionTape_eq_self hOp.read_ne_start⟩ + have hpub : (TM.writeOutputBitTM (cIdx k)).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = W' ∧ out' = out) + (fun _inp _work out' => out' = outSlot (TM.readBackWrite (Γ.ofBool b))) 1 := by + refine (TM.writeOutputBitTM_hoareTime_frame (cIdx k) inp W' out hIp hW'P hOp).strengthen_post + ?_ + rintro inp' work' out' ⟨-, -, hout'⟩ + rw [hout', ho, show (W' (cIdx k)).read = Γ.ofBool b from by + simp only [hW', if_pos rfl] + show (work (cIdx k)).cells 1 = _ + exact hcell] + exact outSlot_write Γw.one (TM.readBackWrite (Γ.ofBool b)) + exact TM.seqTM_hoareTime _ _ hrew htrans hpub inp work out ⟨rfl, rfl, rfl⟩ + + +theorem epilogueBank_cIdx (k N H a r : ℕ) : epilogueBank k N H a r (cIdx k) = TM.blankTape := by + rw [epilogueBank, Function.update_self] + +theorem epilogueBank_resIdx (k N H a r : ℕ) (hsc : resIdx k ≠ cIdx k) : + epilogueBank k N H a r (resIdx k) = natTape ((r + 1) - a) := by + rw [epilogueBank, Function.update_of_ne hsc, Function.update_self] + +theorem epilogueBank_zIdx (k N H a r : ℕ) : epilogueBank k N H a r (zIdx k) = TM.blankTape := by + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + rw [epilogueBank, + Function.update_of_ne (hne _ _ (by simp only [zIdx, cIdx]; omega)), + Function.update_of_ne (hne _ _ (by simp only [zIdx, resIdx]; omega)), + Function.update_of_ne (hne _ _ (by simp only [zIdx, rIdx]; omega)), + bodyBank_rest k N H N a r (zIdx k) + (hne _ _ (by simp only [zIdx, cIdx]; omega)) + (hne _ _ (by simp only [zIdx, aIdx]; omega)) + (hne _ _ (by simp only [zIdx, rIdx]; omega)), + bodyRest_other k N H (zIdx k) + (hne _ _ (by simp only [zIdx, nIdx]; omega)) + (hne _ _ (by simp only [zIdx, regIdx]; omega))] + +theorem epilogueBank_parked (k N H a r : ℕ) : ∀ j, TM.Parked (epilogueBank k N H a r j) := by + intro j + simp only [epilogueBank] + by_cases h1 : j = cIdx k + · rw [h1, Function.update_self]; exact TM.blankTape_parked + rw [Function.update_of_ne h1] + by_cases h2 : j = resIdx k + · rw [h2, Function.update_self]; exact natTape_parked _ + rw [Function.update_of_ne h2] + by_cases h3 : j = rIdx k + · rw [h3, Function.update_self]; exact natTape_parked _ + rw [Function.update_of_ne h3] + exact bodyBank_parked k N H N a r j + +theorem epilogueBank_cells_zero (k N H a r : ℕ) : + ∀ j, (epilogueBank k N H a r j).cells 0 = Γ.start := by + intro j + simp only [epilogueBank] + by_cases h1 : j = cIdx k + · rw [h1, Function.update_self]; exact TM.blankTape_startInvariant.1 + rw [Function.update_of_ne h1] + by_cases h2 : j = resIdx k + · rw [h2, Function.update_self]; exact natTape_cells_zero _ + rw [Function.update_of_ne h2] + by_cases h3 : j = rIdx k + · rw [h3, Function.update_self]; exact natTape_cells_zero _ + rw [Function.update_of_ne h3] + exact bodyBank_cells_zero k N H N a r j + +/-- **The epilogue's comparison.** Testing the difference against zero decides `r < a`; the +answer lands on the counter tape, which the arithmetic stage cleared for exactly this purpose. -/ +theorem epilogueEq_hoareTime (k N H a r : ℕ) (I : Tape) (hI : TM.Parked I) + (hIsi : Tape.StartInvariant I) : + (TM.binaryEqTM (resIdx k) (zIdx k) (cIdx k)).HoareTime + (fun inp work out => inp = I ∧ work = epilogueBank k N H a r ∧ + out = outSlot Γw.one) + (afterEq k (decide (r < a)) I 2) + (TM.binaryEqTime ((r + 1) - a).bits (0 : ℕ).bits) := by + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + have hsc : resIdx k ≠ cIdx k := hne _ _ (by simp only [resIdx, cIdx]; omega) + have hsz : resIdx k ≠ zIdx k := hne _ _ (by simp only [resIdx, zIdx]; omega) + have hzc : zIdx k ≠ cIdx k := hne _ _ (by simp only [zIdx, cIdx]; omega) + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + set W := epilogueBank k N H a r with hWdef + have hWP : ∀ j, TM.Parked (W j) := epilogueBank_parked k N H a r + have hWz : ∀ j, (W j).cells 0 = Γ.start := epilogueBank_cells_zero k N H a r + have hlhs : (W (resIdx k)).HasBinaryString ((r + 1) - a).bits := by + rw [hWdef, epilogueBank_resIdx k N H a r hsc] + exact (Tape.init_move_right_hasBinaryNat _).2 + have hrhs : (W (zIdx k)).HasBinaryString (0 : ℕ).bits := by + rw [hWdef, epilogueBank_zIdx k N H a r, show TM.blankTape = natTape 0 from natTape_zero.symm] + exact (Tape.init_move_right_hasBinaryNat 0).2 + have hres : (W (cIdx k)).HasBinaryPrefix [] := by + rw [hWdef, epilogueBank_cIdx k N H a r] + refine ⟨rfl, nofun, fun i _ => ?_⟩ + show ((Tape.init ([] : List Γ)).move Dir3.right).cells (i + 1) = Γ.blank + rw [Tape.move_cells, Tape.init_nil_cells_succ] + have hIp : TM.Parked inp := by rw [hi]; exact hI + have hOp : TM.Parked out := by rw [ho]; exact outSlot_parked _ + rw [hi, hw, ho] + obtain ⟨c', t, ht, hreach, hhalt, hinp', hres', hlhs', hlhsh, hrhs', hrhsh, hother', hout'⟩ := + TM.binaryEqTM_reachesIn_frame (resIdx k) (zIdx k) (cIdx k) ⟨hsz, hsc, hzc⟩ + ((r + 1) - a).bits (0 : ℕ).bits I W (outSlot Γw.one) hlhs hrhs hres + (by rw [← hi]; exact hIp.read_ne_start) (fun i _ _ _ => (hWP i).read_ne_start) + (outSlot_parked _).read_ne_start + obtain ⟨-, hSI', -⟩ := TM.startInvariant_reachesIn _ hreach hIsi + (fun j => ⟨hWz j, fun i hi2 => (hWP j).2 i hi2⟩) + ⟨rfl, fun j hj => (outSlot_parked Γw.one).2 j hj⟩ + have hbits : (decide (((r + 1) - a).bits = (0 : ℕ).bits)) = decide (r < a) := by + refine decide_eq_decide.mpr ?_ + rw [lt_iff_succ_sub_eq_zero] + exact ⟨fun h => bits_injective h, fun h => by rw [h]⟩ + refine ⟨c', t, ht, hreach, hhalt, hinp', hout', fun j => ?_, fun j => (hSI' j).1, ?_, ?_⟩ + · refine ⟨?_, fun i hi2 => (hSI' j).2 i hi2⟩ + by_cases h1 : j = cIdx k + · rw [h1, hres'.1]; omega + by_cases h2 : j = resIdx k + · rw [h2]; exact hlhsh + by_cases h3 : j = zIdx k + · rw [h3]; exact hrhsh + · rw [hother' j h2 h3 h1]; exact (hWP j).1 + · rw [hres'.1] + simp + · rw [hres'.2.1 0 (by simp), ← hbits] + simp + + +/-- The state between the epilogue's comparison and its publication survives a phase boundary: +every tape it names is parked, so the boundary is the identity. -/ +theorem afterEq_trans (k : ℕ) (b : Bool) (I : Tape) (B : ℕ) (hI : TM.Parked I) + (inp : Tape) (work : Fin (bodyTapes k) → Tape) (out : Tape) + (h : afterEq k b I B inp work out) : + afterEq k b I B (TM.transitionInput inp) (fun i => TM.transitionTape (work i)) + (TM.transitionTape out) := by + obtain ⟨hi, ho, hpark, hzero, hhead, hcell⟩ := h + have hid : ∀ j, TM.transitionTape (work j) = work j := + fun j => TM.transitionTape_eq_self (hpark j).read_ne_start + have hidI : TM.transitionInput inp = inp := by + rw [hi]; exact TM.transitionInput_eq_self hI.read_ne_start + have hidO : TM.transitionTape out = out := by + rw [ho]; exact TM.transitionTape_eq_self (outSlot_parked _).read_ne_start + rw [hidI, hidO, show (fun i => TM.transitionTape (work i)) = work from funext hid] + exact ⟨hi, ho, hpark, hzero, hhead, hcell⟩ + +/-- The epilogue's running time: its three stages and the two transitions between them. -/ +def epilogueTime (N a r : ℕ) : ℕ := + (3 * (max (max (TM.binarySuccTime r) (TM.binaryRippleSubTime (r + 1) a)) + (TM.resetBinaryWorkTime 1 N.bits.length) + 1) + 1) + 1 + + (TM.binaryEqTime ((r + 1) - a).bits (0 : ℕ).bits + 1 + (1 * (2 + 3) + 1 + 1 + 1)) + +/-- **The epilogue's contract.** From the bank the loop leaves — the counter at the horizon, the +two tallies holding their counts — the machine writes `1` into the verdict slot exactly when the +rejecting tally is smaller than the accepting one. -/ +theorem epilogueTM_hoareTime (k N H a r : ℕ) (I : Tape) (hI : TM.Parked I) + (hIsi : Tape.StartInvariant I) : + (epilogueTM k).HoareTime + (fun inp work out => inp = I ∧ work = bodyBank k N H N a r ∧ out = outSlot Γw.one) + (fun _inp _work out => out = outSlot (TM.readBackWrite (Γ.ofBool (decide (r < a))))) + (epilogueTime N a r) := by + have htrans1 : ∀ inp work out, + (inp = I ∧ work = epilogueBank k N H a r ∧ out = outSlot Γw.one) → + (TM.transitionInput inp = I ∧ + (fun i => TM.transitionTape (work i)) = epilogueBank k N H a r ∧ + TM.transitionTape out = outSlot Γw.one) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hI.read_ne_start, + funext fun i => TM.transitionTape_eq_self (epilogueBank_parked k N H a r i).read_ne_start, + TM.transitionTape_eq_self (outSlot_parked _).read_ne_start⟩ + exact TM.seqTM_hoareTime _ _ (epiloguePreTM_hoareTime k N H a r I (outSlot Γw.one) hI + (outSlot_parked _)) htrans1 + (TM.seqTM_hoareTime _ _ (epilogueEq_hoareTime k N H a r I hI hIsi) + (afterEq_trans k (decide (r < a)) I 2 hI) + (epiloguePostTM_hoareTime k (decide (r < a)) I 2 hI)) + + +/-- **The epilogue keeps a window.** It runs for a bounded time from tapes parked at cell one, so +no head can leave a window of that width. -/ +theorem epilogueTM_keepsWindowOn (k N H a r : ℕ) (x : List Bool) : + (epilogueTM k).KeepsWindowOn + (fun c => c.state = (epilogueTM k).qstart ∧ + (c.input = bodyInput x ∧ c.work = bodyBank k N H N a r ∧ + c.output = outSlot Γw.one)) + x.length (1 + epilogueTime N a r) := + TM.keepsWindowOn_of_hoareTime_pinned + (epilogueTM_hoareTime k N H a r (bodyInput x) (bodyInput_parked x) + (bodyInput_startInvariant x)) + (fun i => le_of_eq (bodyBank_head k N H N a r i)) + (by rw [bodyInput_head]; omega) + (by show (1 : ℕ) ≤ 1 + 1; omega) + + +/-- The register-arithmetic subroutines state their contracts in the `TM.EmitPred` shape, whose +output component is an accumulator of emitted bits. With nothing emitted that is just the blank +tape, so those contracts are pinned after all. -/ +theorem outAcc_nil_iff (out : Tape) : TM.OutAcc [] out ↔ out = TM.blankTape := by + constructor + · intro h + refine TM.OutAcc.eq h ?_ + show TM.OutAcc [] TM.blankTape + exact TM.outAcc_nil_init + · intro h + rw [h] + exact TM.outAcc_nil_init + + +/-- A pinned contract with a blank output is an `TM.EmitPred` contract with nothing emitted. -/ +theorem hoareTime_emit_of_pinned {m : ℕ} {tm : TM m} {inp₀ : Tape} + {W W' : Fin m → Tape} {b : ℕ} + (h : tm.HoareTime (fun inp work out => inp = inp₀ ∧ work = W ∧ out = TM.blankTape) + (fun inp work out => inp = inp₀ ∧ work = W' ∧ out = TM.blankTape) b) : + tm.HoareTime (TM.EmitPred inp₀ W []) (TM.EmitPred inp₀ W' []) b := by + intro inp work out hpre + obtain ⟨hi, hw, hout⟩ := hpre + obtain ⟨c', t, ht, hreach, hhalt, hi', hw', ho'⟩ := + h inp work out ⟨hi, hw, (outAcc_nil_iff out).mp hout⟩ + exact ⟨c', t, ht, hreach, hhalt, hi', hw', (outAcc_nil_iff _).mpr ho'⟩ + +/-- The machine's own input tape, in the shape the register subroutines name it. -/ +theorem bodyInput_eq (x : List Bool) : + bodyInput x = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) := + Tape.ext rfl (by rw [bodyInput, Tape.move_cells]) + +/-- **The counting machine's prologue.** Measure the input, evaluate the horizon polynomial on a +unary register, turn that register into the binary horizon with one increment, bump the wipe +height, and clear the scratch. -/ +def prologueTM (k : ℕ) (p : Polynomial ℕ) : TM (bodyTapes k) := + TM.bigSeqTM + [TM.inputLenRegTM (resIdx k), + TM.polyEvalTM (resIdx k) (regIdx k) (nIdx k) p, + TM.binarySuccTM (nIdx k), + TM.incRegTM (regIdx k), + TM.clearRegTM (resIdx k)] + + +/-- The bank the prologue's five stages leave behind. -/ +def prologueBank (k T lx : ℕ) : Fin (bodyTapes k) → Tape := + Function.update + (Function.update + (Function.update + (Function.update + (Function.update (fun _ => TM.blankTape) (resIdx k) (TM.regTape lx)) + (nIdx k) (TM.regTape T)) + (regIdx k) (TM.regTape T)) + (nIdx k) (natTape (2 ^ T))) + (regIdx k) (TM.regTape (T + 1)) + +/-- **The prologue lands on the loop's starting bank.** The horizon sits on `nIdx`, the wipe +height on `regIdx`, and everything else — the counter, both tallies, the scratch registers — is +blank, which is what `NTM.bodyBank` at index zero says. -/ +theorem prologueBank_eq (k T lx : ℕ) : + Function.update (prologueBank k T lx) (resIdx k) (TM.regTape 0) + = bodyBank k (2 ^ T) (1 + T) 0 0 0 := by + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + funext j + by_cases hs : j = resIdx k + · rw [hs, Function.update_self, regTape_zero, + bodyBank_rest k (2 ^ T) (1 + T) 0 0 0 (resIdx k) + (hne _ _ (by simp only [resIdx, cIdx]; omega)) + (hne _ _ (by simp only [resIdx, aIdx]; omega)) + (hne _ _ (by simp only [resIdx, rIdx]; omega)), + bodyRest_other k (2 ^ T) (1 + T) (resIdx k) + (hne _ _ (by simp only [resIdx, nIdx]; omega)) + (hne _ _ (by simp only [resIdx, regIdx]; omega))] + rw [Function.update_of_ne hs] + by_cases hr : j = regIdx k + · rw [hr, prologueBank, Function.update_self, + bodyBank_rest k (2 ^ T) (1 + T) 0 0 0 (regIdx k) + (hne _ _ (by simp only [regIdx, cIdx]; omega)) + (hne _ _ (by simp only [regIdx, aIdx]; omega)) + (hne _ _ (by simp only [regIdx, rIdx]; omega)), + bodyRest_regIdx] + congr 1 + omega + by_cases hn : j = nIdx k + · rw [hn, prologueBank, Function.update_of_ne (hne _ _ (by simp only [nIdx, regIdx]; omega)), + Function.update_self, + bodyBank_rest k (2 ^ T) (1 + T) 0 0 0 (nIdx k) + (hne _ _ (by simp only [nIdx, cIdx]; omega)) + (hne _ _ (by simp only [nIdx, aIdx]; omega)) + (hne _ _ (by simp only [nIdx, rIdx]; omega)), + bodyRest_nIdx] + · rw [prologueBank, Function.update_of_ne hr, Function.update_of_ne hn, + Function.update_of_ne hr, Function.update_of_ne hn, Function.update_of_ne hs] + show TM.blankTape = _ + by_cases hc : j = cIdx k + · rw [hc, bodyBank_cIdx, natTape_zero] + by_cases ha : j = aIdx k + · rw [ha, bodyBank_aIdx, natTape_zero] + by_cases hb : j = rIdx k + · rw [hb, bodyBank_rIdx, natTape_zero] + · rw [bodyBank_rest k (2 ^ T) (1 + T) 0 0 0 j hc ha hb, + bodyRest_other k (2 ^ T) (1 + T) j hn hr] + + +/-- A bound covering the input length and every Horner accumulator the prologue forms. -/ +def prologueCap (p : Polynomial ℕ) (lx : ℕ) : ℕ := + ((TM.polyCoeffs p).sum + 1) * (lx + 1) ^ (TM.polyCoeffs p).length + +theorem le_prologueCap (p : Polynomial ℕ) (lx : ℕ) : lx ≤ prologueCap p lx := by + have hlen : 1 ≤ (TM.polyCoeffs p).length := + List.length_pos_iff.mpr (TM.polyCoeffs_ne_nil p) + have h1 : lx + 1 ≤ (lx + 1) ^ (TM.polyCoeffs p).length := + Nat.le_self_pow (by omega) _ + have h2 : (lx + 1) ^ (TM.polyCoeffs p).length + ≤ ((TM.polyCoeffs p).sum + 1) * (lx + 1) ^ (TM.polyCoeffs p).length := + Nat.le_mul_of_pos_left _ (by omega) + unfold prologueCap + omega + +/-- The prologue's running time. -/ +def prologueTime (p : Polynomial ℕ) (lx : ℕ) : ℕ := + 5 * (max (max (max (2 * lx + 4) + (TM.opBudget (prologueCap p lx) + 1 + + ((p.natDegree + 1) * (TM.layerBudget (prologueCap p lx) + 1) + 1))) + (TM.binarySuccTime (2 ^ p.eval lx - 1))) + (max (2 * p.eval lx + 4) (2 * lx + 4)) + 1) + 1 + +/-- **The prologue's contract.** From the blank bank it lands on the loop's starting bank: the +horizon on `nIdx`, the wipe height on `regIdx`, everything else blank. -/ +theorem prologueTM_hoareTime (k : ℕ) (p : Polynomial ℕ) (x : List Bool) : + (prologueTM k p).HoareTime + (fun inp work out => inp = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) ∧ + work = (fun _ => TM.blankTape) ∧ out = TM.blankTape) + (fun inp work out => inp = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) ∧ + work = bodyBank k (2 ^ p.eval x.length) (1 + p.eval x.length) 0 0 0 ∧ + out = TM.blankTape) + (prologueTime p x.length) := by + have hne : ∀ i i' : Fin (bodyTapes k), i.val ≠ i'.val → i ≠ i' := + fun i i' h hh => h (congrArg Fin.val hh) + have hsn : resIdx k ≠ nIdx k := hne _ _ (by simp only [resIdx, nIdx]; omega) + have hsg : resIdx k ≠ regIdx k := hne _ _ (by simp only [resIdx, regIdx]; omega) + have hgn : regIdx k ≠ nIdx k := hne _ _ (by simp only [regIdx, nIdx]; omega) + set I : Tape := (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) with hI + have hIp : TM.Parked I := by rw [hI, ← bodyInput_eq]; exact bodyInput_parked x + set lx := x.length with hlx + set T := p.eval lx with hT + set M := prologueCap p lx with hM + set V0 : Fin (bodyTapes k) → Tape := fun _ => TM.blankTape with hV0 + set V1 : Fin (bodyTapes k) → Tape := + Function.update V0 (resIdx k) (TM.regTape lx) with hV1 + set V2 : Fin (bodyTapes k) → Tape := + Function.update (Function.update V1 (nIdx k) (TM.regTape T)) (regIdx k) + (TM.regTape T) with hV2 + set V3 : Fin (bodyTapes k) → Tape := + Function.update V2 (nIdx k) (natTape (2 ^ T)) with hV3 + set V4 : Fin (bodyTapes k) → Tape := + Function.update V3 (regIdx k) (TM.regTape (T + 1)) with hV4 + have hupd : ∀ (W : Fin (bodyTapes k) → Tape) (i : Fin (bodyTapes k)) (t : Tape), + (∀ j, TM.Parked (W j)) → TM.Parked t → ∀ j, TM.Parked (Function.update W i t j) := by + intro W i t hW ht j + by_cases hj : j = i + · rw [hj, Function.update_self]; exact ht + · rw [Function.update_of_ne hj]; exact hW j + have hreg : ∀ v : ℕ, TM.Parked (TM.regTape v) := fun v => by + rw [regTape_eq_natTape]; exact natTape_parked _ + have hV0P : ∀ j, TM.Parked (V0 j) := fun _ => TM.blankTape_parked + have hV1P : ∀ j, TM.Parked (V1 j) := hupd _ _ _ hV0P (hreg _) + have hV2P : ∀ j, TM.Parked (V2 j) := hupd _ _ _ (hupd _ _ _ hV1P (hreg _)) (hreg _) + have hV3P : ∀ j, TM.Parked (V3 j) := hupd _ _ _ hV2P (natTape_parked _) + have hV4P : ∀ j, TM.Parked (V4 j) := hupd _ _ _ hV3P (hreg _) + have hV1s : V1 (resIdx k) = TM.regTape lx := by rw [hV1, Function.update_self] + have hV1g : V1 (regIdx k) = TM.regTape 0 := by + rw [hV1, Function.update_of_ne (Ne.symm hsg), hV0, regTape_zero] + have hV1n : V1 (nIdx k) = TM.regTape 0 := by + rw [hV1, Function.update_of_ne (Ne.symm hsn), hV0, regTape_zero] + have hV2n : V2 (nIdx k) = TM.regTape T := by + rw [hV2, Function.update_of_ne hgn.symm, Function.update_self] + have hV2g : V2 (regIdx k) = TM.regTape T := by rw [hV2, Function.update_self] + have hV3g : V3 (regIdx k) = TM.regTape T := by + rw [hV3, Function.update_of_ne hgn, hV2g] + have hV4s : V4 (resIdx k) = TM.regTape lx := by + rw [hV4, Function.update_of_ne hsg, hV3, Function.update_of_ne hsn, hV2, + Function.update_of_ne hsg, Function.update_of_ne hsn, hV1s] + have hpow : 2 ^ T - 1 + 1 = 2 ^ T := by + have : 1 ≤ 2 ^ T := Nat.one_le_two_pow + omega + set bnd := max (max (max (2 * lx + 4) + (TM.opBudget M + 1 + ((p.natDegree + 1) * (TM.layerBudget M + 1) + 1))) + (TM.binarySuccTime (2 ^ T - 1))) + (max (2 * T + 4) (2 * lx + 4)) with hbnd + refine (TM.bigSeqTM_hoareTime + [TM.inputLenRegTM (resIdx k), TM.polyEvalTM (resIdx k) (regIdx k) (nIdx k) p, + TM.binarySuccTM (nIdx k), TM.incRegTM (regIdx k), TM.clearRegTM (resIdx k)] + I + (fun j => if j = 0 then V0 else if j = 1 then V1 else if j = 2 then V2 + else if j = 3 then V3 else if j = 4 then V4 + else Function.update V4 (resIdx k) (TM.regTape 0)) + (fun _ => []) bnd hIp ?_ ?_).consequence ?_ ?_ (le_refl _) + · intro j i + dsimp only + split + · exact hV0P i + · split + · exact hV1P i + · split + · exact hV2P i + · split + · exact hV3P i + · split + · exact hV4P i + · exact hupd _ _ _ hV4P (hreg _) i + · intro j hj + match j, hj with + | 0, _ => + show (TM.inputLenRegTM (resIdx k)).HoareTime _ _ _ + exact (TM.inputLenRegTM_hoareTime (resIdx k) x V0 [] (fun i _ => hV0P i) + (by rw [hV0, regTape_zero])).mono_bound + (le_trans (le_max_left _ _) (le_trans (le_max_left _ _) (le_max_left _ _))) + | 1, _ => + show (TM.polyEvalTM (resIdx k) (regIdx k) (nIdx k) p).HoareTime _ _ _ + exact (TM.polyEvalTM_hoareTime (resIdx k) (regIdx k) (nIdx k) hsg hsn hgn p M lx 0 0 + (le_prologueCap p lx) (Nat.zero_le _) (Nat.zero_le _) + (fun j _ => le_trans (TM.hornerFold_take_le lx (TM.polyCoeffs p) j) (le_of_eq rfl)) + I V1 [] hIp hV1P hV1s hV1g hV1n).mono_bound + (le_trans (le_max_right _ _) (le_trans (le_max_left _ _) (le_max_left _ _))) + | 2, _ => + show (TM.binarySuccTM (nIdx k)).HoareTime _ _ _ + refine (hoareTime_emit_of_pinned + ((TM.binarySuccTM_hoareTime_pinned (nIdx k) (2 ^ T - 1) I V2 TM.blankTape + (by rw [hV2n, regTape_eq_natTape]) hIp.read_ne_start + (fun i _ => (hV2P i).read_ne_start) + TM.blankTape_parked.read_ne_start).strengthen_post ?_)).mono_bound + (le_trans (le_max_right _ _) (le_max_left _ _)) + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, by rw [hw, hpow]; rfl, ho⟩ + | 3, _ => + show (TM.incRegTM (regIdx k)).HoareTime _ _ _ + exact (TM.incRegTM_hoareTime (regIdx k) T I V3 [] hIp (fun i _ => hV3P i) + hV3g).mono_bound (le_trans (le_max_left _ _) (le_max_right _ _)) + | 4, _ => + show (TM.clearRegTM (resIdx k)).HoareTime _ _ _ + exact (TM.clearRegTM_hoareTime (resIdx k) lx I V4 [] hIp (fun i _ => hV4P i) + hV4s).mono_bound (le_trans (le_max_right _ _) (le_max_right _ _)) + · rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, hw, (outAcc_nil_iff out).mpr ho⟩ + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, (outAcc_nil_iff out).mp ho⟩ + rw [hw] + show Function.update V4 (resIdx k) (TM.regTape 0) = _ + rw [hV4, hV3, hV2, hV1, hV0] + exact prologueBank_eq k T lx + + +/-- **The prologue keeps a window.** It runs for a bounded time from blank tapes parked at cell +one, so nothing travels beyond a window of that width. -/ +theorem prologueTM_keepsWindowOn (k : ℕ) (p : Polynomial ℕ) (x : List Bool) : + (prologueTM k p).KeepsWindowOn + (fun c => c.state = (prologueTM k p).qstart ∧ + (c.input = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) ∧ + c.work = (fun _ => TM.blankTape) ∧ c.output = TM.blankTape)) + x.length (1 + prologueTime p x.length) := + TM.keepsWindowOn_of_hoareTime_pinned (prologueTM_hoareTime k p x) + (fun _ => le_of_eq rfl) (by show (1 : ℕ) ≤ x.length + 1 + 1; omega) + (by show (1 : ℕ) ≤ 1 + 1; omega) + +/-- **The whole counting machine.** Park the heads off the left marker, set up the horizon and +the wipe height, run the tally to its horizon, then compare the two tallies and publish. -/ +def ppMachine (k : ℕ) (tm : NTM k) (p : Polynomial ℕ) : TM (bodyTapes k) := + TM.seqTM TM.skipTM + (TM.seqTM (prologueTM k p) + (TM.seqTM (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))) + (epilogueTM k))) + + +/-- **The parking step.** One transition off the initial configuration puts every head at cell +one, which is where every stage of the machine expects to be entered. -/ +theorem ppPark_hoareTime (k : ℕ) (x : List Bool) : + (TM.skipTM (n := bodyTapes k)).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun inp work out => inp = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) ∧ + work = (fun _ => TM.blankTape) ∧ out = TM.blankTape) + 1 := by + have hblank : Tape.StartInvariant (Tape.init ([] : List Γ)) := Tape.StartInvariant.init_nil + have hinit : Tape.StartInvariant (Tape.init (x.map Γ.ofBool)) := + Tape.StartInvariant.init_ofBool x + have hb : (⟨max (Tape.init ([] : List Γ)).head 1, (Tape.init ([] : List Γ)).cells⟩ : Tape) + = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show (Tape.init ([] : List Γ)).cells j = _ + rw [TM.blankTape, Tape.move_cells] + refine (TM.parkAll_hoareTime (Tape.init (x.map Γ.ofBool)) + (fun _ => Tape.init ([] : List Γ)) (Tape.init ([] : List Γ)) hinit (fun _ => hblank) + hblank).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨?_, by rw [funext hw]; exact funext fun _ => hb, by rw [ho]; exact hb⟩ + rw [hi] + refine Tape.ext ?_ rfl + show max (Tape.init (x.map Γ.ofBool)).head 1 = 1 + rw [Tape.init_head] + omega + + +/-- The whole machine's running time. -/ +def ppTime (k : ℕ) (tm : NTM k) (p : Polynomial ℕ) (x : List Bool) : ℕ := + 1 + 1 + (prologueTime p x.length + 1 + + ((2 ^ p.eval x.length) * + (bodyTimeBound k (p.eval x.length) (2 ^ p.eval x.length) + + testTimeBound (2 ^ p.eval x.length) + 5) + 1 + + epilogueTime (2 ^ p.eval x.length) + (tally (acceptsAt tm x (p.eval x.length)) (2 ^ p.eval x.length)) + (tally (fun u => !acceptsAt tm x (p.eval x.length) u) (2 ^ p.eval x.length)))) + +/-- **The counting machine's contract.** From its initial configuration it halts with the verdict +slot holding `1` exactly when the accepting paths outnumber the rejecting ones. -/ +theorem ppMachine_hoareTime (k : ℕ) (tm : NTM k) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (p : Polynomial ℕ) (hT : 1 ≤ p.eval x.length) (hfT : f x.length ≤ p.eval x.length) : + (ppMachine k tm p).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun _inp _work out => out = outSlot (TM.readBackWrite (Γ.ofBool + (decide (tally (fun u => !acceptsAt tm x (p.eval x.length) u) (2 ^ p.eval x.length) + < tally (acceptsAt tm x (p.eval x.length)) (2 ^ p.eval x.length)))))) + (ppTime k tm p x) := by + set T := p.eval x.length with hTdef + set N := 2 ^ T with hNdef + set P := acceptsAt tm x T with hPdef + have hIp : TM.Parked (bodyInput x) := bodyInput_parked x + have hIsi : Tape.StartInvariant (bodyInput x) := bodyInput_startInvariant x + have hIeq : bodyInput x = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) := bodyInput_eq x + have hN : 1 ≤ N := Nat.one_le_two_pow + have htr : ∀ (W : Fin (bodyTapes k) → Tape) (O : Tape), (∀ j, TM.Parked (W j)) → + TM.Parked O → ∀ inp work out, (inp = bodyInput x ∧ work = W ∧ out = O) → + (TM.transitionInput inp = bodyInput x ∧ + (fun i => TM.transitionTape (work i)) = W ∧ TM.transitionTape out = O) := by + rintro W O hW hO inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hIp.read_ne_start, + funext fun i => TM.transitionTape_eq_self (hW i).read_ne_start, + TM.transitionTape_eq_self hO.read_ne_start⟩ + -- The parking step, with the input tape named the way the rest of the machine names it. + have p0 : (TM.skipTM (n := bodyTapes k)).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun inp work out => inp = bodyInput x ∧ work = (fun _ => TM.blankTape) ∧ + out = TM.blankTape) 1 := + (ppPark_hoareTime k x).strengthen_post + (fun _ _ _ h => ⟨by rw [hIeq]; exact h.1, h.2.1, h.2.2⟩) + -- The prologue, restated as the loop's precondition. + have p1 : (prologueTM k p).HoareTime + (fun inp work out => inp = bodyInput x ∧ work = (fun _ => TM.blankTape) ∧ + out = TM.blankTape) + (tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) P 0) + (prologueTime p x.length) := by + refine ((prologueTM_hoareTime k p x).weaken_pre ?_).strengthen_post ?_ + · rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨by rw [← hIeq]; exact hi, hw, ho⟩ + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨by rw [hIeq]; exact hi, hw, Γw.blank, by decide, ?_⟩ + rw [ho, outSlot_blank_eq_blankTape] + -- The loop. + have p2 := tallyLoop_full_bounded tm x hne hall T N hT hfT hN + -- The epilogue, entered on the bank the loop leaves. + have p3 : (epilogueTM k).HoareTime + (tallyPost (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) P N N) + (fun _inp _work out => out = outSlot (TM.readBackWrite (Γ.ofBool + (decide (tally (fun u => !P u) N < tally P N))))) + (epilogueTime N (tally P N) (tally (fun u => !P u) N)) := by + refine (epilogueTM_hoareTime k N (1 + T) (tally P N) (tally (fun u => !P u) N) + (bodyInput x) hIp hIsi).weaken_pre ?_ + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, hw, by rw [ho, if_pos rfl]⟩ + exact TM.seqTM_hoareTime _ _ p0 + (htr (fun _ => TM.blankTape) TM.blankTape (fun _ => TM.blankTape_parked) + TM.blankTape_parked) + (TM.seqTM_hoareTime _ _ p1 + (fun inp work out h => by + obtain ⟨hi, hw, s, hs, ho⟩ := h + refine ⟨?_, ?_, ?_⟩ + · rw [hi]; exact TM.transitionInput_eq_self hIp.read_ne_start + · rw [hw] + exact funext fun i => + TM.transitionTape_eq_self + (bodyBank_parked k N (1 + T) 0 (tally P 0) (tally (fun u => !P u) 0) i).read_ne_start + · refine ⟨s, hs, ?_⟩ + rw [ho] + exact TM.transitionTape_eq_self (outSlot_parked s).read_ne_start) + (TM.seqTM_hoareTime _ _ p2 + (fun inp work out h => by + obtain ⟨hi, hw, ho⟩ := h + refine ⟨?_, ?_, ?_⟩ + · rw [hi]; exact TM.transitionInput_eq_self hIp.read_ne_start + · rw [hw] + exact funext fun i => + TM.transitionTape_eq_self + (bodyBank_parked k N (1 + T) N (tally P N) + (tally (fun u => !P u) N) i).read_ne_start + · rw [ho]; exact TM.transitionTape_eq_self (outSlot_parked _).read_ne_start) + p3)) + + +/-- The counting loop's space bound, packaged as a conditional window contract so it can be +composed with the machine's other parts. -/ +theorem tallyLoop_keepsWindowOn (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T N : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (hN : 1 ≤ N) : + (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).KeepsWindowOn + (fun c => c.state = + (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart ∧ + tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) 0 c.input c.work c.output) + x.length (1 + (bodyTimeBound k T N + testTimeBound N + 5)) := by + intro c hc c' hreach + obtain ⟨hstate, hpre⟩ := hc + refine tallyLoop_keepsWindow_bounded tm x hne hall T N hT hfT hN c.input c.work c.output hpre + c' ?_ + rwa [show (⟨(TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, + c.input, c.work, c.output⟩ : Cfg (bodyTapes k) _) = c from Cfg.ext hstate.symm rfl rfl rfl] + + +/-- The loop's starting configuration is inside any window at least one cell wide, and carries +its left markers. -/ +theorem tallyPre_cfg_ok (k N H v a r : ℕ) (x : List Bool) (S : ℕ) (hS : 1 ≤ S) + {Q : Type} (c : Cfg (bodyTapes k) Q) + (h : c.input = bodyInput x ∧ c.work = bodyBank k N H v a r ∧ + ∃ s : Γw, s ≠ Γw.one ∧ c.output = outSlot s) : + c.WithinDecisionSpace x.length S ∧ TM.CfgStartInvariant c := by + obtain ⟨hi, hw, s, -, ho⟩ := h + refine ⟨⟨⟨fun i => ?_, ?_⟩, ?_⟩, ?_, ?_, ?_⟩ + · rw [hw, bodyBank_head]; omega + · rw [hi, bodyInput_head]; omega + · rw [ho]; show (1 : ℕ) ≤ S + 1; omega + · rw [hi]; exact bodyInput_startInvariant x + · intro i + rw [hw] + exact bodyBank_startInvariant k N H v a r i + · rw [ho] + exact ⟨rfl, fun j hj => (outSlot_parked s).2 j hj⟩ + + +/-- **The loop and the epilogue, composed in space.** -/ +theorem loopEpilogue_keepsWindowOn (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T N : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (hN : 1 ≤ N) (S : ℕ) + (hS1 : 1 + (bodyTimeBound k T N + testTimeBound N + 5) ≤ S) + (hS2 : 1 + epilogueTime N (tally (acceptsAt tm x T) N) + (tally (fun u => !acceptsAt tm x T u) N) ≤ S) : + (TM.seqTM (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))) + (epilogueTM k)).KeepsWindowOn + (fun c => ∃ d, (d.state = + (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart ∧ + tallyPre (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) + (acceptsAt tm x T) 0 d.input d.work d.output) ∧ + c = TM.phase1Wrap _ (epilogueTM k) d) + x.length S := by + set P := acceptsAt tm x T with hP + have hIp : TM.Parked (bodyInput x) := bodyInput_parked x + have hIsi : Tape.StartInvariant (bodyInput x) := bodyInput_startInvariant x + refine TM.seqTM_keepsWindowOn _ _ (by omega) + (mid := tallyPost (cIdx k) (aIdx k) (rIdx k) (bodyInput x) (bodyRest k N (1 + T)) P N N) ?_ + ((tallyLoop_keepsWindowOn tm x hne hall T N hT hfT hN).mono_space hS1) ?_ + ((epilogueTM_keepsWindowOn k N (1 + T) (tally P N) (tally (fun u => !P u) N) + x).mono_space hS2) + ?_ + · rintro c ⟨hstate, hpre⟩ + exact ⟨hstate, tallyPre_cfg_ok k N (1 + T) 0 0 0 x S (by omega) c hpre⟩ + · rintro c ⟨hstate, hpre⟩ + obtain ⟨c', t, -, hreach, hhalt, hpost⟩ := + tallyLoop_full_bounded tm x hne hall T N hT hfT hN c.input c.work c.output hpre + refine ⟨c', ?_, hhalt, hpost⟩ + rw [show (⟨(TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, + c.input, c.work, c.output⟩ : Cfg (bodyTapes k) _) = c from + Cfg.ext hstate.symm rfl rfl rfl] at hreach + exact TM.reaches_of_reachesIn hreach + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨rfl, ?_, ?_, ?_⟩ + · rw [hi]; exact TM.transitionInput_eq_self hIp.read_ne_start + · rw [hw] + exact funext fun i => TM.transitionTape_eq_self + (bodyBank_parked k N (1 + T) N (tally P N) (tally (fun u => !P u) N) i).read_ne_start + · rw [ho, if_pos rfl] + exact TM.transitionTape_eq_self (outSlot_parked Γw.one).read_ne_start + + +/-- **The prologue joined to the rest, in space.** -/ +theorem prologueRest_keepsWindowOn (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (p : Polynomial ℕ) (T N : ℕ) + (hTdef : T = p.eval x.length) (hNdef : N = 2 ^ T) + (hT : 1 ≤ T) (hfT : f x.length ≤ T) (hN : 1 ≤ N) (S : ℕ) + (hS0 : 1 + prologueTime p x.length ≤ S) + (hS1 : 1 + (bodyTimeBound k T N + testTimeBound N + 5) ≤ S) + (hS2 : 1 + epilogueTime N (tally (acceptsAt tm x T) N) + (tally (fun u => !acceptsAt tm x T u) N) ≤ S) : + (TM.seqTM (prologueTM k p) + (TM.seqTM (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))) + (epilogueTM k))).KeepsWindowOn + (fun c => ∃ d, (d.state = (prologueTM k p).qstart ∧ + (d.input = bodyInput x ∧ d.work = (fun _ => TM.blankTape) ∧ + d.output = TM.blankTape)) ∧ + c = TM.phase1Wrap _ _ d) + x.length S := by + have hIp : TM.Parked (bodyInput x) := bodyInput_parked x + have hIeq : bodyInput x = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) := bodyInput_eq x + refine TM.seqTM_keepsWindowOn _ _ (by omega) + (mid := fun inp work out => inp = bodyInput x ∧ + work = bodyBank k N (1 + T) 0 0 0 ∧ out = TM.blankTape) ?_ + (((prologueTM_keepsWindowOn k p x).mono + (fun c hc => ⟨hc.1, by rw [← hIeq]; exact hc.2.1, hc.2.2.1, hc.2.2.2⟩)).mono_space hS0) ?_ + (loopEpilogue_keepsWindowOn tm x hne hall T N hT hfT hN S hS1 hS2) ?_ + · rintro c ⟨hstate, hi, hw, ho⟩ + refine ⟨hstate, ⟨⟨fun i => ?_, ?_⟩, ?_⟩, ?_, ?_, ?_⟩ + · rw [hw]; show (1 : ℕ) ≤ S; omega + · rw [hi, bodyInput_head]; omega + · rw [ho]; show (1 : ℕ) ≤ S + 1; omega + · rw [hi]; exact bodyInput_startInvariant x + · intro i; rw [hw]; exact TM.blankTape_startInvariant + · rw [ho]; exact TM.blankTape_startInvariant + · rintro c ⟨hstate, hi, hw, ho⟩ + obtain ⟨c', t, -, hreach, hhalt, hpi, hpw, hpo⟩ := + prologueTM_hoareTime k p x c.input c.work c.output + ⟨by rw [hi, hIeq], hw, ho⟩ + refine ⟨c', ?_, hhalt, by rw [hpi, ← hIeq], by rw [hpw, hNdef, hTdef], hpo⟩ + rw [show (⟨(prologueTM k p).qstart, c.input, c.work, c.output⟩ : + Cfg (bodyTapes k) _) = c from Cfg.ext hstate.symm rfl rfl rfl] at hreach + exact TM.reaches_of_reachesIn hreach + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨⟨(TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))).qstart, + TM.transitionInput inp, fun i => TM.transitionTape (work i), TM.transitionTape out⟩, + ⟨rfl, ?_, ?_, ?_⟩, rfl⟩ + · rw [hi]; exact TM.transitionInput_eq_self hIp.read_ne_start + · rw [hw] + exact funext fun i => TM.transitionTape_eq_self + (bodyBank_parked k N (1 + T) 0 0 0 i).read_ne_start + · refine ⟨Γw.blank, by decide, ?_⟩ + rw [ho, TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start, + outSlot_blank_eq_blankTape] + + +/-- **The whole machine keeps a polynomial window.** Every configuration it reaches from its +initial one fits inside `S` cells. -/ +theorem ppMachine_keepsWindow (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (p : Polynomial ℕ) (T N : ℕ) + (hTdef : T = p.eval x.length) (hNdef : N = 2 ^ T) + (hT : 1 ≤ T) (hfT : f x.length ≤ T) (hN : 1 ≤ N) (S : ℕ) (hS : 1 ≤ S) + (hS0 : 1 + prologueTime p x.length ≤ S) + (hS1 : 1 + (bodyTimeBound k T N + testTimeBound N + 5) ≤ S) + (hS2 : 1 + epilogueTime N (tally (acceptsAt tm x T) N) + (tally (fun u => !acceptsAt tm x T u) N) ≤ S) : + ∀ c', (ppMachine k tm p).reaches ((ppMachine k tm p).initCfg x) c' → + c'.WithinDecisionSpace x.length S := by + have hIeq : bodyInput x = (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) := bodyInput_eq x + have hpark : (TM.skipTM (n := bodyTapes k)).KeepsWindowOn + (fun c => c.state = (TM.skipTM (n := bodyTapes k)).qstart ∧ + (c.input = Tape.init (x.map Γ.ofBool) ∧ + c.work = (fun _ => Tape.init ([] : List Γ)) ∧ + c.output = Tape.init ([] : List Γ))) x.length S := + (TM.keepsWindowOn_of_hoareTime_pinned (h₀ := 0) (ppPark_hoareTime k x) + (fun _ => le_of_eq rfl) (by show (0 : ℕ) ≤ x.length + 0 + 1; omega) + (by show (0 : ℕ) ≤ 0 + 1; omega)).mono_space (by omega) + have hcomp := TM.seqTM_keepsWindowOn (TM.skipTM (n := bodyTapes k)) + (TM.seqTM (prologueTM k p) + (TM.seqTM (TM.loopTM (bodyTM tm) (TM.tallyTestTM (cIdx k) (nIdx k) (resIdx k))) + (epilogueTM k))) hS + (mid := fun inp work out => inp = bodyInput x ∧ work = (fun _ => TM.blankTape) ∧ + out = TM.blankTape) + (fun c hc => ⟨hc.1, ⟨⟨fun i => by rw [hc.2.2.1]; show (0 : ℕ) ≤ S; omega, + by rw [hc.2.1]; show (0 : ℕ) ≤ x.length + S + 1; omega⟩, + by rw [hc.2.2.2]; show (0 : ℕ) ≤ S + 1; omega⟩, + by rw [hc.2.1]; exact Tape.StartInvariant.init_ofBool x, + fun i => by rw [hc.2.2.1]; exact Tape.StartInvariant.init_nil, + by rw [hc.2.2.2]; exact Tape.StartInvariant.init_nil⟩) + hpark + (fun c hc => by + obtain ⟨hstate, hi, hw, ho⟩ := hc + obtain ⟨c', t, -, hreach, hhalt, hpi, hpw, hpo⟩ := + ppPark_hoareTime k x c.input c.work c.output ⟨hi, hw, ho⟩ + refine ⟨c', ?_, hhalt, by rw [hpi, ← hIeq], hpw, hpo⟩ + rw [show (⟨(TM.skipTM (n := bodyTapes k)).qstart, c.input, c.work, c.output⟩ : + Cfg (bodyTapes k) _) = c from Cfg.ext hstate.symm rfl rfl rfl] at hreach + exact TM.reaches_of_reachesIn hreach) + (prologueRest_keepsWindowOn tm x hne hall p T N hTdef hNdef hT hfT hN S hS0 hS1 hS2) + (fun inp work out h => by + obtain ⟨hi, hw, ho⟩ := h + refine ⟨⟨(prologueTM k p).qstart, TM.transitionInput inp, + fun i => TM.transitionTape (work i), TM.transitionTape out⟩, ⟨rfl, ?_, ?_, ?_⟩, rfl⟩ + · rw [hi] + exact TM.transitionInput_eq_self (bodyInput_parked x).read_ne_start + · rw [hw] + exact funext fun i => + TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start + · rw [ho] + exact TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start) + intro c' hreach + exact hcomp ((ppMachine k tm p).initCfg x) + ⟨⟨(TM.skipTM (n := bodyTapes k)).qstart, Tape.init (x.map Γ.ofBool), + fun _ => Tape.init ([] : List Γ), Tape.init ([] : List Γ)⟩, + ⟨rfl, rfl, rfl, rfl⟩, rfl⟩ c' hreach + + +/-- **The horizon's width is the exponent plus one.** Every bound the machine's parts state in +terms of the horizon's number of digits is therefore a bound in terms of the exponent — which is +what makes them polynomial in the input length rather than exponential. -/ +theorem size_horizon (T : ℕ) : (2 ^ T).size = T + 1 := Nat.size_pow + +theorem bits_length_horizon (T : ℕ) : (2 ^ T).bits.length = T + 1 := + (Nat.size_eq_bits_len (2 ^ T)).trans (size_horizon T) + + +/-- The Horner cap, as a polynomial. The space bound the surrounding obligation asks for must be +a `Polynomial ℕ`, so each arithmetic expression the machine's parts are bounded by has to be +mirrored by a polynomial whose evaluation reproduces it. -/ +noncomputable def capPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C ((TM.polyCoeffs p).sum + 1) * (Polynomial.X + 1) ^ (TM.polyCoeffs p).length + +@[simp] theorem capPoly_eval (p : Polynomial ℕ) (n : ℕ) : + (capPoly p).eval n = prologueCap p n := by + simp only [capPoly, prologueCap, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_add, Polynomial.eval_X, Polynomial.eval_one] + +/-- The operation budget, as a polynomial. -/ +noncomputable def opBudgetPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 32 * ((capPoly p + Polynomial.C 2) ^ 3) + +@[simp] theorem opBudgetPoly_eval (p : Polynomial ℕ) (n : ℕ) : + (opBudgetPoly p).eval n = TM.opBudget (prologueCap p n) := by + simp only [opBudgetPoly, TM.opBudget, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_add, capPoly_eval] + ring + +/-- The layer budget, as a polynomial. -/ +noncomputable def layerBudgetPoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 4 * opBudgetPoly p + Polynomial.C 3 + +@[simp] theorem layerBudgetPoly_eval (p : Polynomial ℕ) (n : ℕ) : + (layerBudgetPoly p).eval n = TM.layerBudget (prologueCap p n) := by + simp only [layerBudgetPoly, TM.layerBudget, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_add, opBudgetPoly_eval] + +/-- The predecessor of the horizon has exactly `T` digits, all of them ones. -/ +theorem size_horizon_pred (T : ℕ) : (2 ^ T - 1).size = T := by + rw [← Nat.size_eq_bits_len (2 ^ T - 1), bits_two_pow_sub_one, List.length_replicate] + +theorem binarySuccTime_horizon_pred (T : ℕ) : + TM.binarySuccTime (2 ^ T - 1) ≤ 2 * T + 2 := by + have h := TM.binarySuccTime_le (2 ^ T - 1) + rw [size_horizon_pred] at h + exact h + +/-- The prologue's running time, as a polynomial. Only a bound is possible — the running time +involves `max`, which no polynomial reproduces — so the maxima are replaced by sums. -/ +noncomputable def prologueTimePoly (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 5 * + ((Polynomial.C 2 * Polynomial.X + Polynomial.C 4) + + (opBudgetPoly p + Polynomial.C 1 + + (Polynomial.C (p.natDegree + 1) * (layerBudgetPoly p + Polynomial.C 1) + + Polynomial.C 1)) + + (Polynomial.C 2 * p + Polynomial.C 2) + + ((Polynomial.C 2 * p + Polynomial.C 4) + + (Polynomial.C 2 * Polynomial.X + Polynomial.C 4)) + Polynomial.C 1) + Polynomial.C 1 + +theorem prologueTime_le (p : Polynomial ℕ) (n : ℕ) : + prologueTime p n ≤ (prologueTimePoly p).eval n := by + have hsucc := binarySuccTime_horizon_pred (p.eval n) + have hev : (prologueTimePoly p).eval n + = 5 * ((2 * n + 4) + + (TM.opBudget (prologueCap p n) + 1 + + ((p.natDegree + 1) * (TM.layerBudget (prologueCap p n) + 1) + 1)) + + (2 * p.eval n + 2) + ((2 * p.eval n + 4) + (2 * n + 4)) + 1) + 1 := by + simp only [prologueTimePoly, Polynomial.eval_mul, Polynomial.eval_add, Polynomial.eval_C, + Polynomial.eval_X, opBudgetPoly_eval, layerBudgetPoly_eval] + rw [hev, prologueTime] + have hmax : ∀ a b : ℕ, max a b ≤ a + b := fun a b => by omega + have h1 := hmax (2 * n + 4) + (TM.opBudget (prologueCap p n) + 1 + + ((p.natDegree + 1) * (TM.layerBudget (prologueCap p n) + 1) + 1)) + have h2 := hmax (max (2 * n + 4) + (TM.opBudget (prologueCap p n) + 1 + + ((p.natDegree + 1) * (TM.layerBudget (prologueCap p n) + 1) + 1))) + (TM.binarySuccTime (2 ^ p.eval n - 1)) + have h3 := hmax (max (max (2 * n + 4) + (TM.opBudget (prologueCap p n) + 1 + + ((p.natDegree + 1) * (TM.layerBudget (prologueCap p n) + 1) + 1))) + (TM.binarySuccTime (2 ^ p.eval n - 1))) + (max (2 * p.eval n + 4) (2 * n + 4)) + have h4 := hmax (2 * p.eval n + 4) (2 * n + 4) + omega + + +/-- **A tally has no more digits than its horizon.** Every time bound the epilogue states in +terms of the tallies' widths is therefore a bound in terms of the exponent. -/ +theorem tally_size_le (P : ℕ → Bool) (N : ℕ) : (tally P N).size ≤ N.size := + Nat.size_le_size (tally_le P N) + +theorem tally_size_horizon_le (P : ℕ → Bool) (T : ℕ) : + (tally P (2 ^ T)).size ≤ T + 1 := by + have h := tally_size_le P (2 ^ T) + rw [size_horizon] at h + exact h + +/-- One more than a tally still has no more than one extra digit. -/ +theorem tally_succ_size_horizon_le (P : ℕ → Bool) (T : ℕ) : + (tally P (2 ^ T) + 1).size ≤ T + 2 := by + have h1 : tally P (2 ^ T) + 1 ≤ 2 ^ (T + 1) := by + have := tally_le P (2 ^ T) + have h2 : 2 ^ (T + 1) = 2 * 2 ^ T := by ring + have h3 : 1 ≤ 2 ^ T := Nat.one_le_two_pow + omega + have h := Nat.size_le_size h1 + rw [size_horizon] at h + omega + + +/-- **The loop's window is linear in the exponent.** Its width is stated through the digit counts +of the horizon and of the two tallies; each of those is `T + O(1)`, so the width is too — even +though the horizon itself is `2 ^ T`. -/ +theorem loopWidth_le (k T : ℕ) : + 1 + (bodyTimeBound k T (2 ^ T) + testTimeBound (2 ^ T) + 5) + ≤ 2 * ((wipeTargets k).length * (T + 5)) + (40 * T + 300) := by + unfold bodyTimeBound testTimeBound testB + rw [size_horizon, bits_length_horizon] + simp only [TM.resetBinaryWorkTime, TM.clearWorkTimeBound] + have hL : (wipeTargets k).length * (1 + T + 4) = (wipeTargets k).length * (T + 5) := by + congr 1 + omega + rw [hL] + omega + + +/-- **The epilogue's window is linear in the exponent too.** Its cost is stated through the digit +counts of the two tallies and of their difference, all of which are `T + O(1)`. -/ +theorem epilogueWidth_le (T : ℕ) (P : ℕ → Bool) : + 1 + epilogueTime (2 ^ T) (tally P (2 ^ T)) (tally (fun u => !P u) (2 ^ T)) + ≤ 40 * T + 200 := by + set a := tally P (2 ^ T) with ha' + set r := tally (fun u => !P u) (2 ^ T) with hr' + have ha : a.size ≤ T + 1 := tally_size_horizon_le P T + have hr : r.size ≤ T + 1 := tally_size_horizon_le _ T + have hr1 : (r + 1).size ≤ T + 2 := tally_succ_size_horizon_le _ T + have hsucc : TM.binarySuccTime r ≤ 2 * r.size + 2 := TM.binarySuccTime_le r + have hsub : TM.binaryRippleSubTime (r + 1) a ≤ 3 * ((r + 1).size + a.size) + 10 := + TM.binaryRippleSubTime_le _ _ + have hdiff : ((r + 1) - a).size ≤ T + 2 := + le_trans (Nat.size_le_size (by omega)) hr1 + have hbitsz : ((r + 1) - a).bits.length ≤ T + 2 := by + rw [Nat.size_eq_bits_len ((r + 1) - a)] + exact hdiff + have hzero : (0 : ℕ).bits.length = 0 := by simp + have heq : TM.binaryEqTime ((r + 1) - a).bits (0 : ℕ).bits ≤ T + 3 := by + show max ((r + 1 - a).bits.length) ((0 : ℕ).bits.length) + 1 ≤ T + 3 + rw [hzero] + omega + unfold epilogueTime + simp only [TM.resetBinaryWorkTime, TM.clearWorkTimeBound, bits_length_horizon] + omega + + +/-- **The machine's space bound, as a polynomial.** The sum of the three parts' widths: the +prologue's, the loop's, and the epilogue's. -/ +noncomputable def ppSpacePoly (k : ℕ) (p : Polynomial ℕ) : Polynomial ℕ := + prologueTimePoly p + + (Polynomial.C (2 * (wipeTargets k).length) * (p + Polynomial.C 5) + + Polynomial.C 40 * p + Polynomial.C 300) + + (Polynomial.C 40 * p + Polynomial.C 200) + +theorem ppSpacePoly_eval (k : ℕ) (p : Polynomial ℕ) (n : ℕ) : + (ppSpacePoly k p).eval n + = (prologueTimePoly p).eval n + + (2 * (wipeTargets k).length * (p.eval n + 5) + 40 * p.eval n + 300) + + (40 * p.eval n + 200) := by + simp only [ppSpacePoly, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C] + +theorem prologue_le_ppSpacePoly (k : ℕ) (p : Polynomial ℕ) (n : ℕ) : + 1 + prologueTime p n ≤ (ppSpacePoly k p).eval n := by + have h := prologueTime_le p n + rw [ppSpacePoly_eval] + omega + +theorem loop_le_ppSpacePoly (k : ℕ) (p : Polynomial ℕ) (n : ℕ) : + 1 + (bodyTimeBound k (p.eval n) (2 ^ p.eval n) + + testTimeBound (2 ^ p.eval n) + 5) ≤ (ppSpacePoly k p).eval n := by + have h := loopWidth_le k (p.eval n) + have hmul : 2 * (wipeTargets k).length * (p.eval n + 5) + = 2 * ((wipeTargets k).length * (p.eval n + 5)) := by ring + rw [ppSpacePoly_eval, hmul] + omega + +theorem epilogue_le_ppSpacePoly (k : ℕ) (p : Polynomial ℕ) (n : ℕ) (P : ℕ → Bool) : + 1 + epilogueTime (2 ^ p.eval n) (tally P (2 ^ p.eval n)) + (tally (fun u => !P u) (2 ^ p.eval n)) ≤ (ppSpacePoly k p).eval n := by + have h := epilogueWidth_le (p.eval n) P + rw [ppSpacePoly_eval] + omega + + +/-- The comparison the surrounding obligation names: after `2 ^ p |x|` tally steps, does the +accepting component exceed the rejecting one? -/ +def ppCond (tm : NTM k) (p : Polynomial ℕ) (x : List Bool) : Prop := + ((tallyStep fun v => acceptsAt tm x (p.eval x.length) v)^[2 ^ p.eval x.length] (0, 0, 0)).2.2 < + ((tallyStep fun v => acceptsAt tm x (p.eval x.length) v)^[2 ^ p.eval x.length] (0, 0, 0)).2.1 + +/-- **The counting machine decides the `PP` comparison.** It runs at the horizon `p.eval |x| + 1` +— one more than the specification names, so that the horizon is never zero, which the simulation +needs — and `NTM.cmp_horizon_iff'` says the comparison is the same either way. -/ +theorem ppMachine_decides (k : ℕ) (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (p : Polynomial ℕ) (hle : ∀ n, f n ≤ p.eval n) (hne : tm.qstart ≠ tm.qhalt) + (x : List Bool) : + ∃ c', (ppMachine k tm (p + 1)).reaches ((ppMachine k tm (p + 1)).initCfg x) c' ∧ + (ppMachine k tm (p + 1)).halted c' ∧ + (ppCond tm p x → c'.output.cells 1 = Γ.one) ∧ + (¬ ppCond tm p x → c'.output.cells 1 = Γ.zero) := by + set T := (p + 1).eval x.length with hT' + have hTval : T = p.eval x.length + 1 := by + rw [hT'] + simp + have hT : 1 ≤ T := by omega + have hfT : f x.length ≤ T := by + have := hle x.length + omega + obtain ⟨c', t, -, hreach, hhalt, hout⟩ := + ppMachine_hoareTime k tm x hne hall (p + 1) hT hfT + (Tape.init (x.map Γ.ofBool)) (fun _ => Tape.init ([] : List Γ)) + (Tape.init ([] : List Γ)) ⟨rfl, rfl, rfl⟩ + have hiff : (tally (fun u => !acceptsAt tm x T u) (2 ^ T) < + tally (fun u => acceptsAt tm x T u) (2 ^ T)) ↔ ppCond tm p x := by + rw [ppCond, tallyStep_iterate, tally_cmp_iff, tally_cmp_iff] + exact cmp_horizon_iff' tm hall x T (p.eval x.length) hfT (hle x.length) + refine ⟨c', TM.reaches_of_reachesIn hreach, hhalt, ?_, ?_⟩ + · intro hcond + rw [hout, outSlot_cells_one, decide_eq_true_iff.mpr (hiff.mpr hcond)] + rfl + · intro hcond + rw [hout, outSlot_cells_one, + show decide (tally (fun u => !acceptsAt tm x T u) (2 ^ T) < + tally (fun u => acceptsAt tm x T u) (2 ^ T)) = false from by + simp only [decide_eq_false_iff_not] + exact fun hc => hcond (hiff.mp hc)] + rfl + + +/-- **The counting machine runs in polynomial space.** Every configuration it reaches fits inside +`NTM.ppSpacePoly` cells — a polynomial in the input length, even though the machine's own running +time is exponential. -/ +theorem ppMachine_space (k : ℕ) (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (p : Polynomial ℕ) (hle : ∀ n, f n ≤ p.eval n) (hne : tm.qstart ≠ tm.qhalt) + (x : List Bool) (c' : Cfg (bodyTapes k) (ppMachine k tm (p + 1)).Q) + (hreach : (ppMachine k tm (p + 1)).reaches ((ppMachine k tm (p + 1)).initCfg x) c') : + c'.WithinDecisionSpace x.length ((ppSpacePoly k (p + 1)).eval x.length) := by + set T := (p + 1).eval x.length with hT' + have hTval : T = p.eval x.length + 1 := by + rw [hT'] + simp + have hT : 1 ≤ T := by omega + have hfT : f x.length ≤ T := by + have := hle x.length + omega + have hN : 1 ≤ 2 ^ T := Nat.one_le_two_pow + have hS0 := prologue_le_ppSpacePoly k (p + 1) x.length + have hS1 := loop_le_ppSpacePoly k (p + 1) x.length + have hS2 := epilogue_le_ppSpacePoly k (p + 1) x.length (acceptsAt tm x T) + exact ppMachine_keepsWindow tm x hne hall (p + 1) T (2 ^ T) rfl rfl hT hfT hN + ((ppSpacePoly k (p + 1)).eval x.length) (by omega) hS0 hS1 hS2 c' hreach + + +/-- **Two is the smallest numeral whose low digit is zero.** A blank register incremented twice +therefore reads `0`, which is how the trivial machine below produces a `0` to publish — the +alphabet offers no other way to name one. -/ +theorem natTape_two_read : (natTape 2).read = Γ.zero := by + show ((Tape.init ((Nat.bits 2).map Γ.ofBool)).move Dir3.right).cells 1 = Γ.zero + rw [Tape.move_cells, show Nat.bits 2 = [false, true] from by decide] + show (Tape.init (([false, true] : List Bool).map Γ.ofBool)).cells (0 + 1) = Γ.zero + rw [Tape.init_ofBool_cells_lt [false, true] 0 (by simp)] + rfl + +/-- **The trivial machine**: it writes `0` and halts. This is what serves for a source machine +that starts halted, where no path can accept and the comparison is always false. -/ +def zeroTM (k : ℕ) : TM (bodyTapes k) := + TM.seqTM TM.skipTM + (TM.bigSeqTM [TM.binarySuccTM (cIdx k), TM.binarySuccTM (cIdx k), + TM.writeOutputBitTM (cIdx k)]) + +/-- The trivial machine's running time. -/ +def zeroTime : ℕ := + 1 + 1 + (3 * (max (max (TM.binarySuccTime 0) (TM.binarySuccTime 1)) 1 + 1) + 1) + +/-- **The trivial machine's contract.** It halts with `0` in the verdict slot. -/ +theorem zeroTM_hoareTime (k : ℕ) (x : List Bool) : + (zeroTM k).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun _inp _work out => out = outSlot Γw.zero) + zeroTime := by + set I : Tape := (⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ : Tape) with hI + have hIp : TM.Parked I := by rw [hI, ← bodyInput_eq]; exact bodyInput_parked x + set V0 : Fin (bodyTapes k) → Tape := fun _ => TM.blankTape with hV0 + set V1 : Fin (bodyTapes k) → Tape := Function.update V0 (cIdx k) (natTape 1) with hV1 + set V2 : Fin (bodyTapes k) → Tape := Function.update V1 (cIdx k) (natTape 2) with hV2 + have hupd : ∀ (W : Fin (bodyTapes k) → Tape) (i : Fin (bodyTapes k)) (t : Tape), + (∀ j, TM.Parked (W j)) → TM.Parked t → ∀ j, TM.Parked (Function.update W i t j) := by + intro W i t hW ht j + by_cases hj : j = i + · rw [hj, Function.update_self]; exact ht + · rw [Function.update_of_ne hj]; exact hW j + have hV0P : ∀ j, TM.Parked (V0 j) := fun _ => TM.blankTape_parked + have hV1P : ∀ j, TM.Parked (V1 j) := hupd _ _ _ hV0P (natTape_parked _) + have hV2P : ∀ j, TM.Parked (V2 j) := hupd _ _ _ hV1P (natTape_parked _) + set b := max (max (TM.binarySuccTime 0) (TM.binarySuccTime 1)) 1 with hb + have hrest : (TM.bigSeqTM [TM.binarySuccTM (cIdx k), TM.binarySuccTM (cIdx k), + TM.writeOutputBitTM (cIdx k)]).HoareTime + (fun inp work out => inp = I ∧ work = V0 ∧ out = TM.blankTape) + (fun inp work out => inp = I ∧ work = V2 ∧ out = outSlot Γw.zero) + (3 * (b + 1) + 1) := by + refine (TM.bigSeqTM_hoareTime_pinned _ I + (fun j => if j = 0 then V0 else if j = 1 then V1 else V2) + (fun j => if j ≤ 2 then TM.blankTape else outSlot Γw.zero) b hIp ?_ ?_ ?_).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (le_refl _) + · intro j i + dsimp only + split + · exact hV0P i + · split + · exact hV1P i + · exact hV2P i + · intro j + dsimp only + split + · exact TM.blankTape_parked + · exact outSlot_parked _ + · intro j hj + match j, hj with + | 0, _ => + show (TM.binarySuccTM (cIdx k)).HoareTime _ _ _ + exact (TM.binarySuccTM_hoareTime_pinned (cIdx k) 0 I V0 TM.blankTape + (by rw [hV0, natTape_zero]) hIp.read_ne_start (fun i _ => (hV0P i).read_ne_start) + TM.blankTape_parked.read_ne_start).mono_bound + (le_trans (le_max_left _ _) (le_max_left _ _)) + | 1, _ => + show (TM.binarySuccTM (cIdx k)).HoareTime _ _ _ + exact (TM.binarySuccTM_hoareTime_pinned (cIdx k) 1 I V1 TM.blankTape + (by rw [hV1, Function.update_self]) hIp.read_ne_start + (fun i _ => (hV1P i).read_ne_start) + TM.blankTape_parked.read_ne_start).mono_bound + (le_trans (le_max_right _ _) (le_max_left _ _)) + | 2, _ => + show (TM.writeOutputBitTM (cIdx k)).HoareTime _ _ _ + refine ((TM.writeOutputBitTM_hoareTime_frame (cIdx k) I V2 TM.blankTape hIp hV2P + TM.blankTape_parked).strengthen_post ?_).mono_bound (le_max_right _ _) + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, hw, ?_⟩ + rw [ho, show V2 (cIdx k) = natTape 2 from by rw [hV2, Function.update_self], + natTape_two_read, ← outSlot_blank_eq_blankTape] + exact outSlot_write Γw.blank Γw.zero + have hpark : (TM.skipTM (n := bodyTapes k)).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init ([] : List Γ)) ∧ out = Tape.init ([] : List Γ)) + (fun inp work out => inp = I ∧ work = V0 ∧ out = TM.blankTape) 1 := + ppPark_hoareTime k x + have htrans : ∀ inp work out, (inp = I ∧ work = V0 ∧ out = TM.blankTape) → + (TM.transitionInput inp = I ∧ (fun i => TM.transitionTape (work i)) = V0 ∧ + TM.transitionTape out = TM.blankTape) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨TM.transitionInput_eq_self hIp.read_ne_start, + funext fun i => TM.transitionTape_eq_self (hV0P i).read_ne_start, + TM.transitionTape_eq_self TM.blankTape_parked.read_ne_start⟩ + exact (TM.seqTM_hoareTime _ _ hpark htrans hrest).strengthen_post (fun _ _ _ h => h.2.2) + +/-- The trivial machine's space bound, as a polynomial: a constant. -/ +noncomputable def zeroSpacePoly : Polynomial ℕ := Polynomial.C zeroTime + +@[simp] theorem zeroSpacePoly_eval (n : ℕ) : zeroSpacePoly.eval n = zeroTime := by + simp [zeroSpacePoly] + +/-- **The trivial machine keeps a constant window.** Its running time is constant, so the heads +cannot travel far enough to leave one. -/ +theorem zeroTM_space (k : ℕ) (x : List Bool) (c' : Cfg (bodyTapes k) (zeroTM k).Q) + (hreach : (zeroTM k).reaches ((zeroTM k).initCfg x) c') : + c'.WithinDecisionSpace x.length (zeroSpacePoly.eval x.length) := by + have h := TM.keepsWindowOn_of_hoareTime_pinned (h₀ := 0) (inputLength := x.length) + (zeroTM_hoareTime k x) (fun _ => le_of_eq rfl) + (by show (0 : ℕ) ≤ x.length + 0 + 1; omega) (by show (0 : ℕ) ≤ 0 + 1; omega) + have hw := h ((zeroTM k).initCfg x) ⟨rfl, rfl, rfl, rfl⟩ c' hreach + rw [zeroSpacePoly_eval] + exact (by simpa using hw : c'.WithinDecisionSpace x.length (0 + zeroTime)) + +/-- **The trivial machine publishes `0`.** -/ +theorem zeroTM_decides (k : ℕ) (x : List Bool) : + ∃ c', (zeroTM k).reaches ((zeroTM k).initCfg x) c' ∧ (zeroTM k).halted c' ∧ + c'.output.cells 1 = Γ.zero := by + obtain ⟨c', t, -, hreach, hhalt, hout⟩ := + zeroTM_hoareTime k x (Tape.init (x.map Γ.ofBool)) (fun _ => Tape.init ([] : List Γ)) + (Tape.init ([] : List Γ)) ⟨rfl, rfl, rfl⟩ + exact ⟨c', TM.reaches_of_reachesIn hreach, hhalt, by rw [hout, outSlot_cells_one]; rfl⟩ + +/-- **A source that starts halted fails the comparison.** No path accepts, so the accepting tally +is zero and cannot exceed the rejecting one — which is why the trivial machine, publishing `0` +unconditionally, decides this case. -/ +theorem not_ppCond_of_qstart_eq_qhalt (k : ℕ) (tm : NTM k) (heq : tm.qstart = tm.qhalt) + (p : Polynomial ℕ) (x : List Bool) : ¬ ppCond tm p x := by + rw [ppCond, tallyStep_iterate] + show ¬ (tally (fun v => !acceptsAt tm x (p.eval x.length) v) (2 ^ p.eval x.length) < + tally (fun v => acceptsAt tm x (p.eval x.length) v) (2 ^ p.eval x.length)) + rw [tally_eq_acceptCount, acceptCount_eq_zero_of_qstart_eq_qhalt heq] + omega + + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPBody.lean b/Complexitylib/Classes/Containments/Internal/PPBody.lean new file mode 100644 index 00000000..aa372382 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPBody.lean @@ -0,0 +1,304 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PPTest +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SentinelStep +public import Complexitylib.Models.TuringMachine.Delay + +/-! +# The counting loop's body + +⚠️ Unreviewed by Bolton + +The body of the counting loop advances the count and one of the two tallies. Which tally it +advances is decided by the simulated path's verdict, and `TM.ifTM` is the combinator that reads a +verdict and branches — but it reads the *output* tape, so the verdict must already have been +published there, which is what `TM.writeOutputBitTM` is for. + +This file builds the arithmetic end of the body: given the verdict in the output tape's slot, +bump the chosen tally, bump the count, and blank the slot again for the next pass. + +## Main results + +- `TM.binarySuccTM_hoareTime_pinned`, `TM.binaryRippleSubTM_hoareTime_pinned` — the successor and + truncated subtraction, with fully named result banks +- `TM.condBumpTM`, `TM.condBumpTM_hoareTime` — bump one of two registers according to the + published verdict +- `TM.tallyBumpTM`, `TM.tallyBumpTM_hoareTime` — that bump, the count's bump, and the blanking of + the verdict slot, chained through named banks +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **The canonical successor, with the result bank named.** `Tape.HasBinaryNat` determines a +tape outright, so the library's contract — which reports the new value rather than the new tape — +can be sharpened to a pinned one, which is what the chaining rules consume. -/ +theorem binarySuccTM_hoareTime_pinned (idx : Fin n) (value : ℕ) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hvalue : work₀ idx = natTape value) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + (binarySuccTM idx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ + work = Function.update work₀ idx (natTape (value + 1)) ∧ out = out₀) + (binarySuccTime value) := by + have hbn : (work₀ idx).HasBinaryNat value := by + rw [hvalue]; exact Tape.init_move_right_hasBinaryNat value + refine (binarySuccTM_hoareTime_frame idx value inp₀ work₀ out₀ hbn hinp hother + hout).strengthen_post ?_ + rintro inp work out ⟨rfl, hkeep, hnew, rfl⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + by_cases hj : j = idx + · subst hj + rw [Function.update_self] + simpa [natTape] using hnew.eq_init_move_right + · rw [Function.update_of_ne hj] + exact hkeep j hj + +/-- **Bump one of two registers, according to the verdict already in the output slot.** The test +stage is `TM.skipTM`: the verdict is published before the branch is reached, so the conditional +has nothing left to compute. -/ +def condBumpTM (aIdx rIdx : Fin n) : TM n := + ifTM skipTM (binarySuccTM aIdx) (binarySuccTM rIdx) + + +/-- **The conditional bump's contract.** The verdict `b` sitting in the output slot selects which +register grows; the slot itself is untouched, since the branch reads it and nothing writes it. -/ +theorem condBumpTM_hoareTime (aIdx rIdx : Fin n) (a r : ℕ) (b : Bool) (s : Γw) + (hb : s = Γw.one ↔ b = true) + (I : Tape) (W : Fin n → Tape) + (hI : Parked I) (hIz : I.cells 0 = Γ.start) + (hW : ∀ j, Parked (W j)) (hWz : ∀ j, (W j).cells 0 = Γ.start) + (ha : W aIdx = natTape a) (hr : W rIdx = natTape r) : + (condBumpTM aIdx rIdx).HoareTime + (fun inp work out => inp = I ∧ work = W ∧ out = NTM.outSlot s) + (fun inp work out => inp = I ∧ + work = (if b then Function.update W aIdx (natTape (a + 1)) + else Function.update W rIdx (natTape (r + 1))) ∧ + out = NTM.outSlot s) + (1 + 1 + max (binarySuccTime a) (binarySuccTime r) + 5) := by + set O := NTM.outSlot s with hO + have hOP : Parked O := NTM.outSlot_parked _ + have hOne : O.cells 1 = Γ.one ↔ b = true := by + rw [hO, NTM.outSlot_cells_one_eq_one_iff] + exact hb + have hIdW : ∀ i, transitionTape (W i) = W i := + fun i => transitionTape_eq_self (hW i).read_ne_start + have hIdI : transitionInput I = I := transitionInput_eq_self hI.read_ne_start + have hIdO : transitionTape O = O := transitionTape_eq_self hOP.read_ne_start + have hOfix : (⟨1, O.cells⟩ : Tape) = O := Tape.ext rfl rfl + refine ifTM_hoareTime skipTM (binarySuccTM aIdx) (binarySuccTM rIdx) + (mid_then := fun inp work out => b = true ∧ (inp = I ∧ work = W ∧ out = O)) + (mid_else := fun inp work out => b = false ∧ (inp = I ∧ work = W ∧ out = O)) + (post_then := fun inp work out => b = true ∧ + (inp = I ∧ work = Function.update W aIdx (natTape (a + 1)) ∧ out = O)) + (post_else := fun inp work out => b = false ∧ + (inp = I ∧ work = Function.update W rIdx (natTape (r + 1)) ∧ out = O)) + (p_bound := 1) + (skipTM_hoareTime_frame I W O hI hW hOP) ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + · rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨hIz, fun j hj => hI.2 j hj, hWz, fun i j hj => (hW i).2 j hj, + by rw [hO]; rfl, fun j hj => hOP.2 j hj⟩ + · rintro inp work out ⟨rfl, rfl, rfl⟩ + exact le_of_eq rfl + · rintro inp work out ⟨rfl, rfl, rfl⟩ hone + exact ⟨hOne.mp hone, hIdI, funext hIdW, hOfix⟩ + · rintro inp work out ⟨rfl, rfl, rfl⟩ hne + refine ⟨?_, hIdI, funext hIdW, hOfix⟩ + cases b + · rfl + · exact absurd (hOne.mpr rfl) hne + · intro inp work out h + obtain ⟨hb, hpre⟩ := h + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := + binarySuccTM_hoareTime_pinned aIdx a I W O ha hI.read_ne_start + (fun i _ => (hW i).read_ne_start) hOP.read_ne_start inp work out hpre + exact ⟨c', t, ht, hreach, hhalt, hb, hpost⟩ + · intro inp work out h + obtain ⟨hb, hpre⟩ := h + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := + binarySuccTM_hoareTime_pinned rIdx r I W O hr hI.read_ne_start + (fun i _ => (hW i).read_ne_start) hOP.read_ne_start inp work out hpre + exact ⟨c', t, ht, hreach, hhalt, hb, hpost⟩ + · rintro inp work out ⟨hb, rfl, rfl, rfl⟩ + refine ⟨hIdI, ?_, hIdO⟩ + rw [if_pos hb] + funext i + exact transitionTape_eq_self (by + by_cases hi : i = aIdx + · subst hi + rw [Function.update_self] + exact (natTape_parked _).read_ne_start + · rw [Function.update_of_ne hi]; exact (hW i).read_ne_start) + · rintro inp work out ⟨hb, rfl, rfl, rfl⟩ + refine ⟨hIdI, ?_, hIdO⟩ + rw [if_neg (by simp [hb])] + funext i + exact transitionTape_eq_self (by + by_cases hi : i = rIdx + · subst hi + rw [Function.update_self] + exact (natTape_parked _).read_ne_start + · rw [Function.update_of_ne hi]; exact (hW i).read_ne_start) + + +/-- **The arithmetic end of the loop body.** Bump the selected tally, bump the count, and blank +the verdict slot so the next pass starts from the state the loop's invariant describes. -/ +def tallyBumpTM (cIdx aIdx rIdx zIdx : Fin n) : TM n := + bigSeqTM [condBumpTM aIdx rIdx, binarySuccTM cIdx, writeOutputBitTM zIdx] + +/-- **The arithmetic end of the loop body, contracted.** Every intermediate bank is named, so the +three stages chain through `TM.bigSeqTM_hoareTime_pinned` with no existential in sight. -/ +theorem tallyBumpTM_hoareTime (cIdx aIdx rIdx zIdx : Fin n) + (hca : cIdx ≠ aIdx) (hcr : cIdx ≠ rIdx) + (hzc : zIdx ≠ cIdx) (hza : zIdx ≠ aIdx) (hzr : zIdx ≠ rIdx) + (v a r : ℕ) (b : Bool) (s : Γw) (hb : s = Γw.one ↔ b = true) + (I : Tape) (W : Fin n → Tape) + (hI : Parked I) (hIz : I.cells 0 = Γ.start) + (hW : ∀ j, Parked (W j)) (hWz : ∀ j, (W j).cells 0 = Γ.start) + (hcv : W cIdx = natTape v) (ha : W aIdx = natTape a) (hr : W rIdx = natTape r) + (hz : (W zIdx).read = Γ.blank) : + (tallyBumpTM cIdx aIdx rIdx zIdx).HoareTime + (fun inp work out => inp = I ∧ work = W ∧ out = NTM.outSlot s) + (fun inp work out => inp = I ∧ + work = Function.update + (if b then Function.update W aIdx (natTape (a + 1)) + else Function.update W rIdx (natTape (r + 1))) cIdx (natTape (v + 1)) ∧ + out = NTM.outSlot Γw.blank) + (3 * (max (1 + 1 + max (binarySuccTime a) (binarySuccTime r) + 5) + (binarySuccTime v) + 1) + 1) := by + set W₁ := if b then Function.update W aIdx (natTape (a + 1)) + else Function.update W rIdx (natTape (r + 1)) with hW₁ + set W₂ := Function.update W₁ cIdx (natTape (v + 1)) with hW₂ + set O := NTM.outSlot s with hO + have hW₁P : ∀ j, Parked (W₁ j) := by + intro j + rw [hW₁] + split + · by_cases hj : j = aIdx + · rw [hj, Function.update_self]; exact natTape_parked _ + · rw [Function.update_of_ne hj]; exact hW j + · by_cases hj : j = rIdx + · rw [hj, Function.update_self]; exact natTape_parked _ + · rw [Function.update_of_ne hj]; exact hW j + have hW₁z : ∀ j, (W₁ j).cells 0 = Γ.start := by + intro j + rw [hW₁] + split + · by_cases hj : j = aIdx + · rw [hj, Function.update_self]; exact NTM.natTape_cells_zero _ + · rw [Function.update_of_ne hj]; exact hWz j + · by_cases hj : j = rIdx + · rw [hj, Function.update_self]; exact NTM.natTape_cells_zero _ + · rw [Function.update_of_ne hj]; exact hWz j + have hW₁c : W₁ cIdx = natTape v := by + rw [hW₁] + split + · rw [Function.update_of_ne hca]; exact hcv + · rw [Function.update_of_ne hcr]; exact hcv + have hW₁z' : (W₁ zIdx).read = Γ.blank := by + rw [hW₁] + split + · rw [Function.update_of_ne hza]; exact hz + · rw [Function.update_of_ne hzr]; exact hz + have hW₂P : ∀ j, Parked (W₂ j) := by + intro j + rw [hW₂] + by_cases hj : j = cIdx + · rw [hj, Function.update_self]; exact natTape_parked _ + · rw [Function.update_of_ne hj]; exact hW₁P j + have hW₂z : (W₂ zIdx).read = Γ.blank := by + rw [hW₂, Function.update_of_ne hzc]; exact hW₁z' + have hOP : Parked O := NTM.outSlot_parked _ + have hObP : Parked (NTM.outSlot Γw.blank) := NTM.outSlot_parked _ + refine (bigSeqTM_hoareTime_pinned + [condBumpTM aIdx rIdx, binarySuccTM cIdx, writeOutputBitTM zIdx] + I (fun k => if k = 0 then W else if k = 1 then W₁ else W₂) + (fun k => if k ≤ 2 then O else NTM.outSlot Γw.blank) + (max (1 + 1 + max (binarySuccTime a) (binarySuccTime r) + 5) (binarySuccTime v)) + hI ?_ ?_ ?_).consequence (fun _ _ _ h => h) (fun _ _ _ h => h) (le_refl _) + · intro k i + dsimp only + split + · exact hW i + · split + · exact hW₁P i + · exact hW₂P i + · intro k + dsimp only + split + · exact hOP + · exact hObP + · intro k hk + match k, hk with + | 0, _ => + show (condBumpTM aIdx rIdx).HoareTime _ _ _ + exact (condBumpTM_hoareTime aIdx rIdx a r b s hb I W hI hIz hW hWz ha hr).mono_bound + (le_max_left _ _) + | 1, _ => + show (binarySuccTM cIdx).HoareTime _ _ _ + exact (binarySuccTM_hoareTime_pinned cIdx v I W₁ O hW₁c hI.read_ne_start + (fun i _ => (hW₁P i).read_ne_start) hOP.read_ne_start).mono_bound (le_max_right _ _) + | 2, _ => + show (writeOutputBitTM zIdx).HoareTime _ _ _ + refine ((writeOutputBitTM_hoareTime_frame zIdx I W₂ O hI hW₂P hOP).strengthen_post + ?_).mono_bound (le_trans (by omega) (le_max_left _ _)) + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨rfl, rfl, ?_⟩ + rw [hW₂z] + show O.write (readBackWrite Γ.blank).toΓ = _ + rw [hO] + exact NTM.outSlot_write _ Γw.blank + + +/-- **Truncated subtraction, with the result bank named.** As with the successor, the library +reports the new *values*; since `Tape.HasBinaryNat` determines a tape, the operands come back +literally unchanged and only the result register moves. -/ +theorem binaryRippleSubTM_hoareTime_pinned (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) (lhs rhs : ℕ) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hlhs : work₀ lhsIdx = natTape lhs) (hrhs : work₀ rhsIdx = natTape rhs) + (hres : (work₀ resultIdx).HasBinaryNat 0) + (hinput : Parked inp₀) + (hother : ∀ i, i ≠ lhsIdx → i ≠ rhsIdx → i ≠ resultIdx → Parked (work₀ i)) + (houtput : Parked out₀) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ + work = Function.update work₀ resultIdx (natTape (lhs - rhs)) ∧ out = out₀) + (binaryRippleSubTime lhs rhs) := by + have hbl : (work₀ lhsIdx).HasBinaryNat lhs := by + rw [hlhs]; exact Tape.init_move_right_hasBinaryNat lhs + have hbr : (work₀ rhsIdx).HasBinaryNat rhs := by + rw [hrhs]; exact Tape.init_move_right_hasBinaryNat rhs + refine (binaryRippleSubTM_hoareTime_frame lhsIdx rhsIdx resultIdx hdistinct lhs rhs + inp₀ work₀ out₀ hbl hbr hres hinput hother houtput).strengthen_post ?_ + rintro inp work out ⟨hi, hl, hr, hd, hkeep, ho⟩ + refine ⟨hi, funext fun j => ?_, ho⟩ + by_cases hj : j = resultIdx + · rw [hj, Function.update_self] + simpa [natTape] using hd.eq_init_move_right + by_cases hj1 : j = lhsIdx + · rw [Function.update_of_ne hj, hj1, hlhs] + simpa [natTape] using hl.eq_init_move_right + by_cases hj2 : j = rhsIdx + · rw [Function.update_of_ne hj, hj2, hrhs] + simpa [natTape] using hr.eq_init_move_right + · rw [Function.update_of_ne hj] + exact hkeep j hj1 hj2 hj + +end TM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPLayout.lean b/Complexitylib/Classes/Containments/Internal/PPLayout.lean new file mode 100644 index 00000000..b0b578c7 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPLayout.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PPSim +public import Complexitylib.Classes.Containments.Internal.PPBody +public import Complexitylib.Models.TuringMachine.Subroutines.WipeRewind +public import Complexitylib.Models.TuringMachine.Subroutines.ParkRewind + +/-! +# The counting machine's tape layout + +⚠️ Unreviewed by Bolton + +Placing the simulation with `TM.placeWorkTM 0 m` fixes where every tape sits: the simulated +machine's `k` tapes come first, then its choice tape — which is the loop's counter — then the +loop's own registers, and last the tape `TM.retargetOutput` sends the verdict to. + +Six registers are needed: the two tallies, the horizon to compare the count against, a scratch +cell for that comparison, a permanently blank tape to blank the verdict slot from, and the unary +register that drives the wipe. + +## Main results + +- `NTM.bodyTapes` — the tape count, and the named indices into it +- `NTM.bodyIdx_distinct` — the indices are pairwise distinct +- `NTM.bodyRest` — the resting contents of every tape the tally state does not name +- `NTM.wipeTargets` — the tapes the body blanks on its way out +- `NTM.natTape_zero`, `NTM.regTape_zero` — a register holding zero is the blank tape +- `NTM.regTape_eq_natTape` — a unary register of `T` ones is the binary numeral `2 ^ T - 1` +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} + +/-- The counting machine's tape count: the simulation's `k + 1`, six registers, and the tape the +verdict is written to. -/ +abbrev bodyTapes (k : ℕ) : ℕ := 0 + (k + 1) + 6 + 1 + +/-- The counter, which is also the simulation's choice tape. -/ +def cIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k, by show k < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- The accepting tally. -/ +def aIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 1, by show k + 1 < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- The rejecting tally. -/ +def rIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 2, by show k + 2 < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- The horizon the counter is compared against. -/ +def nIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 3, by show k + 3 < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- Scratch space for that comparison. -/ +def resIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 4, by show k + 4 < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- A permanently blank tape, read whenever the verdict slot must be blanked. -/ +def zIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 5, by show k + 5 < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- The unary register that drives the wipe. -/ +def regIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 6, by show k + 6 < 0 + (k + 1) + 6 + 1; omega⟩ + +/-- The tape the simulation's output is redirected to. -/ +def vIdx (k : ℕ) : Fin (bodyTapes k) := ⟨k + 7, by show k + 7 < 0 + (k + 1) + 6 + 1; omega⟩ + +theorem vIdx_eq_last (k : ℕ) : vIdx k = Fin.last (0 + (k + 1) + 6) := by + apply Fin.ext + show k + 7 = 0 + (k + 1) + 6 + omega + +/-- The simulated machine's own work tapes: everything strictly left of the counter. -/ +def simTapes (k : ℕ) : List (Fin (bodyTapes k)) := + (List.finRange (bodyTapes k)).filter (fun j => decide (j.val < k)) + +@[simp] theorem mem_simTapes_iff (k : ℕ) (j : Fin (bodyTapes k)) : + j ∈ simTapes k ↔ j.val < k := by + simp [simTapes, List.mem_filter] + +theorem simTapes_nodup (k : ℕ) : (simTapes k).Nodup := + (List.nodup_finRange _).filter _ + +theorem simTapes_length_le (k : ℕ) : (simTapes k).length ≤ bodyTapes k := by + refine le_trans (List.length_filter_le _ _) ?_ + rw [List.length_finRange] + + +/-- **A counter tape holding zero is the blank tape**, and so is a unary register holding zero. +The machine's initial configuration therefore already carries both, which is what a prologue can +start from. -/ +theorem natTape_zero : natTape 0 = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show ((Tape.init ((Nat.bits 0).map Γ.ofBool)).move Dir3.right).cells j + = ((Tape.init ([] : List Γ)).move Dir3.right).cells j + rw [show Nat.bits 0 = [] from by simp] + rfl + +theorem regTape_zero : TM.regTape 0 = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show TM.regCells 0 j = ((Tape.init ([] : List Γ)).move Dir3.right).cells j + rw [Tape.move_cells] + by_cases hj : j = 0 + · rw [hj] + show (if (0 : ℕ) = 0 then Γ.start else _) = _ + rw [if_pos rfl, Tape.init_cells_zero] + · show (if j = 0 then Γ.start else if j ≤ 0 then Γ.one else Γ.blank) = _ + rw [if_neg hj, if_neg (by omega), show j = (j - 1) + 1 from by omega, + Tape.init_nil_cells_succ] + + +/-- **A unary register of `T` ones is the binary numeral `2 ^ T - 1`.** The two encodings agree +cell for cell: `regCells` writes `1` in cells `1 … T` and blanks beyond, and so do the bits of +`2 ^ T - 1`. This is what lets the prologue produce the horizon `2 ^ T` with a single increment, +instead of a doubling loop. -/ +theorem bits_two_pow_sub_one : ∀ T : ℕ, (2 ^ T - 1).bits = List.replicate T true := by + intro T + induction T with + | zero => simp + | succ T ih => + have hrw : 2 ^ (T + 1) - 1 = 2 * (2 ^ T - 1) + 1 := by + have h : 1 ≤ 2 ^ T := Nat.one_le_two_pow + have : 2 ^ (T + 1) = 2 * 2 ^ T := by ring + omega + rw [hrw, Nat.bit1_bits, ih, List.replicate_succ] + +theorem regTape_eq_natTape (T : ℕ) : TM.regTape T = natTape (2 ^ T - 1) := by + refine Tape.ext rfl (funext fun j => ?_) + have hbits := bits_two_pow_sub_one T + have hlen : (2 ^ T - 1).bits.length = T := by rw [hbits, List.length_replicate] + show TM.regCells T j = (natTape (2 ^ T - 1)).cells j + rw [natTape, Tape.move_cells] + by_cases hj : j = 0 + · rw [hj] + show (if (0 : ℕ) = 0 then Γ.start else _) = _ + rw [if_pos rfl, Tape.init_cells_zero] + · obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_cells_succ] + show (if i + 1 = 0 then Γ.start else if i + 1 ≤ T then Γ.one else Γ.blank) + = (((2 ^ T - 1).bits.map Γ.ofBool)[i]?).getD Γ.blank + rw [if_neg (by omega), hbits] + by_cases hi : i < T + · rw [if_pos (by omega)] + simp [hi, Γ.ofBool] + · rw [if_neg (by omega)] + simp [hi] + +/-- **The registers are pairwise distinct**, and none of them is one of the simulation's tapes. -/ +theorem cIdx_lt_aIdx (k : ℕ) : (cIdx k).val < (aIdx k).val := by + show k < k + 1; omega + +theorem bodyIdx_distinct (k : ℕ) : + cIdx k ≠ aIdx k ∧ cIdx k ≠ rIdx k ∧ aIdx k ≠ rIdx k ∧ + nIdx k ≠ cIdx k ∧ nIdx k ≠ aIdx k ∧ nIdx k ≠ rIdx k ∧ + resIdx k ≠ cIdx k ∧ resIdx k ≠ aIdx k ∧ resIdx k ≠ rIdx k ∧ + resIdx k ≠ nIdx k ∧ zIdx k ≠ cIdx k ∧ zIdx k ≠ aIdx k ∧ zIdx k ≠ rIdx k ∧ + regIdx k ≠ cIdx k ∧ vIdx k ≠ cIdx k ∧ vIdx k ≠ aIdx k ∧ vIdx k ≠ rIdx k ∧ + vIdx k ≠ zIdx k ∧ regIdx k ∉ simTapes k ∧ vIdx k ∉ simTapes k := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ <;> + first + | (intro h; have := congrArg Fin.val h; simp only [cIdx, aIdx, rIdx, nIdx, resIdx, + zIdx, regIdx, vIdx] at this; omega) + | (rw [mem_simTapes_iff]; simp only [regIdx, vIdx]; omega) + +/-- **The resting contents of every tape the tally state does not name.** The horizon sits on +`NTM.nIdx` and the wipe's unary register on `NTM.regIdx`; everything else rests blank. -/ +def bodyRest (k N H : ℕ) : Fin (bodyTapes k) → Tape := fun j => + if j = nIdx k then natTape N + else if j = regIdx k then TM.regTape H + else TM.blankTape + +theorem bodyRest_nIdx (k N H : ℕ) : bodyRest k N H (nIdx k) = natTape N := by + simp only [bodyRest] + simp + +theorem bodyRest_regIdx (k N H : ℕ) : bodyRest k N H (regIdx k) = TM.regTape H := by + have h : regIdx k ≠ nIdx k := by + intro h + have := congrArg Fin.val h + simp only [regIdx, nIdx] at this + omega + simp only [bodyRest, if_neg h] + simp + +theorem bodyRest_other (k N H : ℕ) (j : Fin (bodyTapes k)) + (hn : j ≠ nIdx k) (hr : j ≠ regIdx k) : bodyRest k N H j = TM.blankTape := by + simp only [bodyRest, if_neg hn, if_neg hr] + +theorem bodyRest_parked (k N H : ℕ) : ∀ j, TM.Parked (bodyRest k N H j) := by + intro j + simp only [bodyRest] + split + · exact natTape_parked N + · split + · exact ⟨le_refl 1, fun i hi => by + show TM.regCells H i ≠ Γ.start + simp only [TM.regCells] + split + · omega + · split <;> decide⟩ + · exact TM.blankTape_parked + +theorem bodyRest_cells_zero (k N H : ℕ) : ∀ j, (bodyRest k N H j).cells 0 = Γ.start := by + intro j + simp only [bodyRest] + split + · exact natTape_cells_zero N + · split + · rfl + · show ((Tape.init ([] : List Γ)).move Dir3.right).cells 0 = Γ.start + rw [Tape.move_cells] + exact Tape.init_cells_zero [] + +theorem bodyRest_head (k N H : ℕ) : ∀ j, (bodyRest k N H j).head = 1 := by + intro j + simp only [bodyRest] + split + · rfl + · split + · rfl + · rfl + +theorem bodyRest_startInvariant (k N H : ℕ) : + ∀ j, Tape.StartInvariant (bodyRest k N H j) := + fun j => ⟨bodyRest_cells_zero k N H j, fun i hi => (bodyRest_parked k N H j).2 i hi⟩ + +/-- **The named registers are distinct from each other and from the simulation's tapes.** -/ +theorem bodyIdx_ne (k : ℕ) : + (cIdx k).val = k ∧ (aIdx k).val = k + 1 ∧ (rIdx k).val = k + 2 ∧ + (nIdx k).val = k + 3 ∧ (resIdx k).val = k + 4 ∧ (zIdx k).val = k + 5 ∧ + (regIdx k).val = k + 6 ∧ (vIdx k).val = k + 7 := + ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + + +/-- The tapes the body wipes on its way out: the simulated machine's own, and the tape its +verdict was written to. -/ +def wipeTargets (k : ℕ) : List (Fin (bodyTapes k)) := simTapes k ++ [vIdx k] + +@[simp] theorem mem_wipeTargets_iff (k : ℕ) (j : Fin (bodyTapes k)) : + j ∈ wipeTargets k ↔ (j.val < k ∨ j = vIdx k) := by + simp [wipeTargets] + +theorem wipeTargets_nodup (k : ℕ) : (wipeTargets k).Nodup := by + refine List.Nodup.append (simTapes_nodup k) (List.nodup_singleton _) ?_ + intro a ha hb + rw [mem_simTapes_iff] at ha + rw [List.mem_singleton] at hb + subst hb + simp only [vIdx] at ha + omega + +theorem regIdx_not_mem_wipeTargets (k : ℕ) : regIdx k ∉ wipeTargets k := by + rw [mem_wipeTargets_iff] + rintro (h | h) + · simp only [regIdx] at h + omega + · have := congrArg Fin.val h + simp only [regIdx, vIdx] at this + omega + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPParts.lean b/Complexitylib/Classes/Containments/Internal/PPParts.lean new file mode 100644 index 00000000..3d0191b5 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPParts.lean @@ -0,0 +1,1186 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.RetargetWindow +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SeqChain +public import Complexitylib.Models.TuringMachine.Combinators.Internal.LoopIndexed +public import Complexitylib.Models.TuringMachine.Delay +public import Complexitylib.Models.TuringMachine.Combinators.Internal.LoopIteration +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Window +public import Complexitylib.Models.TuringMachine.ChoiceTape +public import Complexitylib.Models.TuringMachine.Tape.Encoding +public import Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import Complexitylib.Models.TuringMachine.Subroutines.WriteOutputBit +public import Complexitylib.Classes.Randomized +public import Complexitylib.Classes.FiniteCounting +public import Complexitylib.Classes.Containments.Internal.WitnessEnum + +/-! +# Parts of the path-counting machine + +⚠️ Unreviewed by Bolton + +The machine that will witness `PP ⊆ PSPACE` enumerates choice sequences, runs one path of the +probabilistic machine along each, and keeps a running count. Its inner call is +`NTM.choiceTM`, which is *time*-bounded rather than space-bounded: every path halts within the +protocol's own time bound, so the window follows from `TM.keepsWindowOn_of_haltsIn` with no space +hypothesis at all. That is simpler than the corresponding step for `PH ⊆ PSPACE`, whose inner +call is only space-bounded. + +## An architectural constraint on the body + +The body must clear the simulated machine's work tapes between iterations, and the only +content-agnostic reset available is `TM.resetTapesTM`, whose wipe phase (`TM.wipeLoop_hoareTime`) +*requires the real output tape blank*. The rewind phase (`TM.rewindList_hoareTime`) does not — it +asks only that the output be `TM.Parked`. + +That rules out the obvious design. `TM.ifTM` branches on the real output tape's verdict cell, so +using the simulation as a conditional's test would leave the verdict sitting on the output and +block the next iteration's wipe; and there is no subroutine that clears the output tape. The +verdict therefore has to be written to a *work* tape — the simulation output-retargeted, as in +`NTM.choiceTM_placed_keepsWindow` — and republished on the output only for the moment the branch +needs it. `TM.writeOutputBitTM` is the one-transition subroutine that does the republishing; the +library had no way to move a bit from a work tape to the output, which is why the constraint +above looked fatal. + +## Main results + +- `NTM.acceptCount_add`, `NTM.mem_iff_polyHorizon` — the comparison is stable under enlarging + the horizon, so the machine may use a polynomial bound in place of the protocol's own + (uncomputable) time function +- `hasBinaryString_unique`, `hasBinaryNat_value_unique` — a binary tape determines its contents +- `tallyState`, `tallyIdx`, `tallyIdx_tallyState` — the counting machine's tape state, and the + index read back off it +- `natTape`, `tallyWork`, `tallyState_iff` — that state, fully pinned +- `binarySucc_tallyState`, `binarySucc_tallyState_counter`, `binarySucc_tallyState_rej` — the + three increment stages, from the library's canonical successor +- `NTM.choiceStream_of_hasBinaryString`, `NTM.choiceStream_eq_choicesOfNat` — a binary counter + tape *is* the choice sequence of its value +- `NTM.choiceTM_choiceCells` — the path simulation leaves the counter's digits alone +- `NTM.choiceTM_dropChoice_eq`, `NTM.choiceTM_verdict` — what the simulation computes from a + counter value, and that its verdict is the enumeration's acceptance test +- `NTM.choiceTM_haltsIn` — a path simulation halts within the protocol's time bound +- `NTM.choiceTM_keepsWindowOn` — and therefore keeps a window +- `NTM.choiceTM_placed_keepsWindow`, `NTM.choiceTM_lifted_keepsWindow` — and so does the call + once placed in the larger machine, with or without output retargeting +- `natTape_parked` — the numeric tapes satisfy the side condition the reset subroutines demand +- `NTM.acceptCount_eq_card_range` — the accepting-path count is a count over counter values +- `NTM.tally`, `NTM.tally_eq_card` — the running accumulation computes that count +- `NTM.mem_iff_two_mul_tally` — what the counting machine decides +- `NTM.tally_add_compl`, `NTM.lt_two_mul_tally_iff`, `NTM.mem_iff_tally_lt_tally` — and the same + as a comparison of two counters, so the machine never forms `2 ^ T` +- `NTM.acceptsAt`, `NTM.mem_iff_tally_lt_tally_poly` — **the complete machine specification** +- `NTM.tallyStep`, `NTM.tallyStep_iterate` — the loop invariant on (counter, accepting tally, + rejecting tally) +- `NTM.mem_iff_iterate_tallyStep` — membership as one iterated function and a comparison +- `NTM.outSlot`, `NTM.tallyPre`, `NTM.tallyPost`, `NTM.tallyLoop_hoareTime_of_hoare` — the + counting loop from a Hoare contract for the body and one for the test, chained through fully + pinned tape states, which is the interface a machine construction meets +- `NTM.tallyLoop_keepsWindow_of_hoare` — the same loop's space bound, one iteration wide +- `NTM.delayNTM_char`, `NTM.acceptCount_eq_zero_of_qstart_eq_qhalt`, + `NTM.not_mem_of_qstart_eq_qhalt` — the `PP` characterisation transported to + the delayed machine, and the degenerate case that licenses it +- `NTM.choiceTM_delay_dropChoice_eq`, `NTM.choiceTM_delay_haltsIn` — what the loop body's + simulation computes, entered where a composed machine can enter it +- `NTM.tally_eq_acceptCount`, `NTM.tally_cmp_iff` — the tally is the accepting count +- `NTM.cmp_horizon_iff`, `NTM.cmp_horizon_iff'` — the `PP` comparison does not depend on the + horizon, past the point where every path has halted +- `NTM.tallyLoop_hoareTime`, `NTM.tallyLoop_hoareTime_of_body` — the counting loop, granted only + that the body advances the triple +-/ + +@[expose] public section + +namespace Complexity + +/-! ## A binary tape determines its contents + +The indexed loop rule reads the iteration count back off the tapes, so the counter's encoding has +to be unambiguous. It is: a tape's digits are pinned cell by cell and the first blank marks the +end, so two representations on the same tape coincide. -/ + +/-- A tape carries at most one binary string. -/ +theorem hasBinaryString_unique {t : Tape} {b b' : List Bool} + (h : t.HasBinaryString b) (h' : t.HasBinaryString b') : b = b' := by + obtain ⟨-, hin, hout⟩ := h + obtain ⟨-, hin', hout'⟩ := h' + have hlen : b.length = b'.length := by + by_contra hne + rcases Nat.lt_or_ge b.length b'.length with hlt | hge + · have h1 := hout b.length le_rfl + have h2 := hin' b.length hlt + rw [h1] at h2 + revert h2 + cases b'[b.length] <;> simp [Γ.ofBool] + · have hlt' : b'.length < b.length := by omega + have h1 := hout' b'.length le_rfl + have h2 := hin b'.length hlt' + rw [h1] at h2 + revert h2 + cases b[b'.length] <;> simp [Γ.ofBool] + refine List.ext_getElem hlen fun i h1 h2 => ?_ + have e1 := hin i h1 + have e2 := hin' i h2 + rw [e1] at e2 + revert e2 + cases b[i] <;> cases b'[i] <;> simp [Γ.ofBool] + +/-- A tape carries at most one natural number. -/ +theorem hasBinaryNat_value_unique {t : Tape} {v v' : ℕ} + (h : t.HasBinaryNat v) (h' : t.HasBinaryNat v') : v = v' := + bits_injective (hasBinaryString_unique h.2 h'.2) + + +/-! ## The counting machine's tape state -/ + +/-- **The tape state of the counting machine.** Three designated work tapes carry the counter and +the two tallies in canonical binary; every other tape, the input, and the output are pinned. -/ +def tallyState {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) (rest : Fin n → Tape) + (st : ℕ × ℕ × ℕ) : TapePred n := fun inp work out => + inp = I ∧ out.read ≠ Γ.start ∧ + (work cIdx).HasBinaryNat st.1 ∧ (work aIdx).HasBinaryNat st.2.1 ∧ + (work rIdx).HasBinaryNat st.2.2 ∧ + ∀ i, i ≠ cIdx → i ≠ aIdx → i ≠ rIdx → work i = rest i + +/-- The iteration count read back off the counter tape. The input and output tapes are ignored; +they are present because `TM.loopTM_hoareTime_indexed` takes the index as a function of the whole +tape state. -/ +@[nolint unusedArguments] +noncomputable def tallyIdx {n : ℕ} (cIdx : Fin n) : + Tape → (Fin n → Tape) → Tape → ℕ := + fun _ work _ => Classical.epsilon fun v => (work cIdx).HasBinaryNat v + +/-- **Reading the index back is faithful.** This is the hypothesis `TM.loopTM_hoareTime_indexed` +needs: the loop's variant can be computed from the tapes it is looking at. -/ +theorem tallyIdx_tallyState {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) + (rest : Fin n → Tape) (st : ℕ × ℕ × ℕ) (inp : Tape) (work : Fin n → Tape) (out : Tape) + (h : tallyState cIdx aIdx rIdx I rest st inp work out) : + tallyIdx cIdx inp work out = st.1 := by + obtain ⟨-, -, hc, -, -, -⟩ := h + have hex : ∃ v, (work cIdx).HasBinaryNat v := ⟨st.1, hc⟩ + exact hasBinaryNat_value_unique (Classical.epsilon_spec hex) hc + + +/-- The canonical tape for a natural number. -/ +def natTape (v : ℕ) : Tape := (Tape.init (v.bits.map Γ.ofBool)).move Dir3.right + +/-- The work bank of the counting machine at a given state. -/ +def tallyWork {n : ℕ} (cIdx aIdx rIdx : Fin n) (rest : Fin n → Tape) + (st : ℕ × ℕ × ℕ) : Fin n → Tape := fun i => + if i = cIdx then natTape st.1 + else if i = aIdx then natTape st.2.1 + else if i = rIdx then natTape st.2.2 + else rest i + +/-- **The tape state is fully pinned.** `Tape.HasBinaryNat` determines a tape outright, so the +counting machine's state names every tape exactly — which is what lets the library's framed +subroutine contracts, whose preconditions pin all three tape components, be applied to it. -/ +theorem tallyState_iff {n : ℕ} (cIdx aIdx rIdx : Fin n) + (hca : cIdx ≠ aIdx) (hcr : cIdx ≠ rIdx) (har : aIdx ≠ rIdx) + (I : Tape) (rest : Fin n → Tape) (st : ℕ × ℕ × ℕ) + (inp : Tape) (work : Fin n → Tape) (out : Tape) : + tallyState cIdx aIdx rIdx I rest st inp work out ↔ + (inp = I ∧ work = tallyWork cIdx aIdx rIdx rest st ∧ out.read ≠ Γ.start) := by + constructor + · rintro ⟨hi, ho, hc, ha, hr, hother⟩ + refine ⟨hi, funext fun i => ?_, ho⟩ + simp only [tallyWork] + by_cases hic : i = cIdx + · subst hic + simpa [natTape] using hc.eq_init_move_right + · by_cases hia : i = aIdx + · subst hia + simp only [if_neg hic] + simpa [natTape] using ha.eq_init_move_right + · by_cases hir : i = rIdx + · subst hir + simp only [if_neg hic, if_neg hia] + simpa [natTape] using hr.eq_init_move_right + · simp only [if_neg hic, if_neg hia, if_neg hir] + exact hother i hic hia hir + · rintro ⟨hi, rfl, ho⟩ + refine ⟨hi, ho, ?_, ?_, ?_, ?_⟩ + · simpa [tallyWork, natTape] using Tape.init_move_right_hasBinaryNat st.1 + · simp only [tallyWork, if_neg hca.symm] + exact Tape.init_move_right_hasBinaryNat st.2.1 + · simp only [tallyWork, if_neg hcr.symm, if_neg har.symm] + exact Tape.init_move_right_hasBinaryNat st.2.2 + · intro i hic hia hir + simp only [tallyWork, if_neg hic, if_neg hia, if_neg hir] + + +/-- Canonical number tapes read a digit or a blank, never the left marker. -/ +theorem natTape_read_ne_start (v : ℕ) : (natTape v).read ≠ Γ.start := by + have h := Tape.init_move_right_hasBinaryNat v + show (natTape v).cells (natTape v).head ≠ Γ.start + rw [show (natTape v).head = 1 from h.2.1] + by_cases hb : 0 < v.bits.length + · rw [show (natTape v).cells (0 + 1) = Γ.ofBool (v.bits[0]'hb) from h.2.2.1 0 hb] + cases v.bits[0] <;> simp [Γ.ofBool] + · rw [show (natTape v).cells (0 + 1) = Γ.blank from h.2.2.2 0 (by omega)] + simp + +/-- The work bank of the counting machine reads off the left marker on every tape. -/ +theorem tallyWork_read_ne_start {n : ℕ} (cIdx aIdx rIdx : Fin n) (rest : Fin n → Tape) + (hrest : ∀ i, (rest i).read ≠ Γ.start) (st : ℕ × ℕ × ℕ) (i : Fin n) : + (tallyWork cIdx aIdx rIdx rest st i).read ≠ Γ.start := by + simp only [tallyWork] + split + · exact natTape_read_ne_start _ + · split + · exact natTape_read_ne_start _ + · split + · exact natTape_read_ne_start _ + · exact hrest i + +/-- A canonical number tape is parked: its head is off the left marker and no cell beyond the +marker holds one. This is the side condition the rewind and wipe subroutines ask of every tape +they carry along. -/ +theorem natTape_parked (v : ℕ) : TM.Parked (natTape v) := by + have h : (natTape v).HasBinaryNat v := Tape.init_move_right_hasBinaryNat v + refine ⟨by rw [show (natTape v).head = 1 from h.2.1], fun j hj => ?_⟩ + obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + by_cases hb : i < v.bits.length + · rw [h.2.2.1 i hb] + cases v.bits[i] <;> simp [Γ.ofBool] + · rw [h.2.2.2 i (by omega)] + simp + +/-- **The three increment stages.** Advancing one of the numeric tapes by one is the library's +canonical successor applied to the pinned state; the output tape is carried along untouched, +whatever it holds. -/ +theorem binarySucc_tallyState {n : ℕ} (cIdx aIdx rIdx : Fin n) + (hca : cIdx ≠ aIdx) (hcr : cIdx ≠ rIdx) (har : aIdx ≠ rIdx) + (I : Tape) (rest : Fin n → Tape) (v a r : ℕ) + (hI : I.read ≠ Γ.start) (hrest : ∀ i, (rest i).read ≠ Γ.start) : + (TM.binarySuccTM aIdx).HoareTime + (tallyState cIdx aIdx rIdx I rest (v, a, r)) + (tallyState cIdx aIdx rIdx I rest (v, a + 1, r)) + (TM.binarySuccTime a) := by + intro inp work out hpre + rw [tallyState_iff cIdx aIdx rIdx hca hcr har] at hpre + obtain ⟨hinp, hwork, hore⟩ := hpre + have hval : (tallyWork cIdx aIdx rIdx rest (v, a, r) aIdx).HasBinaryNat a := by + simp only [tallyWork, if_neg hca.symm] + exact Tape.init_move_right_hasBinaryNat a + obtain ⟨c', t, ht, hreach, hhalt, hi, hother, hidx, ho⟩ := + TM.binarySuccTM_hoareTime_frame aIdx a I (tallyWork cIdx aIdx rIdx rest (v, a, r)) out + hval hI (fun i _ => tallyWork_read_ne_start cIdx aIdx rIdx rest hrest _ i) hore + inp work out ⟨hinp, hwork, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, hi, by rw [ho]; exact hore, ?_, hidx, ?_, ?_⟩ + · rw [hother cIdx hca] + simpa [tallyWork, natTape] using Tape.init_move_right_hasBinaryNat v + · rw [hother rIdx har.symm] + simp only [tallyWork, if_neg hcr.symm, if_neg har.symm] + exact Tape.init_move_right_hasBinaryNat r + · intro i hic hia hir + rw [hother i hia] + simp only [tallyWork, if_neg hic, if_neg hia, if_neg hir] + +/-- The counter-increment stage. -/ +theorem binarySucc_tallyState_counter {n : ℕ} (cIdx aIdx rIdx : Fin n) + (hca : cIdx ≠ aIdx) (hcr : cIdx ≠ rIdx) (har : aIdx ≠ rIdx) + (I : Tape) (rest : Fin n → Tape) (v a r : ℕ) + (hI : I.read ≠ Γ.start) (hrest : ∀ i, (rest i).read ≠ Γ.start) : + (TM.binarySuccTM cIdx).HoareTime + (tallyState cIdx aIdx rIdx I rest (v, a, r)) + (tallyState cIdx aIdx rIdx I rest (v + 1, a, r)) + (TM.binarySuccTime v) := by + intro inp work out hpre + rw [tallyState_iff cIdx aIdx rIdx hca hcr har] at hpre + obtain ⟨hinp, hwork, hore⟩ := hpre + have hval : (tallyWork cIdx aIdx rIdx rest (v, a, r) cIdx).HasBinaryNat v := by + simpa [tallyWork, natTape] using Tape.init_move_right_hasBinaryNat v + obtain ⟨c', t, ht, hreach, hhalt, hi, hother, hidx, ho⟩ := + TM.binarySuccTM_hoareTime_frame cIdx v I (tallyWork cIdx aIdx rIdx rest (v, a, r)) out + hval hI (fun i _ => tallyWork_read_ne_start cIdx aIdx rIdx rest hrest _ i) hore + inp work out ⟨hinp, hwork, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, hi, by rw [ho]; exact hore, hidx, ?_, ?_, ?_⟩ + · rw [hother aIdx hca.symm] + simp only [tallyWork, if_neg hca.symm] + exact Tape.init_move_right_hasBinaryNat a + · rw [hother rIdx hcr.symm] + simp only [tallyWork, if_neg hcr.symm, if_neg har.symm] + exact Tape.init_move_right_hasBinaryNat r + · intro i hic hia hir + rw [hother i hic] + simp only [tallyWork, if_neg hic, if_neg hia, if_neg hir] + +/-- The rejecting-tally-increment stage. -/ +theorem binarySucc_tallyState_rej {n : ℕ} (cIdx aIdx rIdx : Fin n) + (hca : cIdx ≠ aIdx) (hcr : cIdx ≠ rIdx) (har : aIdx ≠ rIdx) + (I : Tape) (rest : Fin n → Tape) (v a r : ℕ) + (hI : I.read ≠ Γ.start) (hrest : ∀ i, (rest i).read ≠ Γ.start) : + (TM.binarySuccTM rIdx).HoareTime + (tallyState cIdx aIdx rIdx I rest (v, a, r)) + (tallyState cIdx aIdx rIdx I rest (v, a, r + 1)) + (TM.binarySuccTime r) := by + intro inp work out hpre + rw [tallyState_iff cIdx aIdx rIdx hca hcr har] at hpre + obtain ⟨hinp, hwork, hore⟩ := hpre + have hval : (tallyWork cIdx aIdx rIdx rest (v, a, r) rIdx).HasBinaryNat r := by + simp only [tallyWork, if_neg hcr.symm, if_neg har.symm] + exact Tape.init_move_right_hasBinaryNat r + obtain ⟨c', t, ht, hreach, hhalt, hi, hother, hidx, ho⟩ := + TM.binarySuccTM_hoareTime_frame rIdx r I (tallyWork cIdx aIdx rIdx rest (v, a, r)) out + hval hI (fun i _ => tallyWork_read_ne_start cIdx aIdx rIdx rest hrest _ i) hore + inp work out ⟨hinp, hwork, rfl⟩ + refine ⟨c', t, ht, hreach, hhalt, hi, by rw [ho]; exact hore, ?_, ?_, hidx, ?_⟩ + · rw [hother cIdx hcr] + simpa [tallyWork, natTape] using Tape.init_move_right_hasBinaryNat v + · rw [hother aIdx har] + simp only [tallyWork, if_neg hca.symm] + exact Tape.init_move_right_hasBinaryNat a + · intro i hic hia hir + rw [hother i hir] + simp only [tallyWork, if_neg hic, if_neg hia, if_neg hir] + +namespace NTM + +variable {k : ℕ} + +/-- **A path simulation halts within the protocol's own time bound.** All paths of `tm` halt +within `f |x|` steps, and `choiceTM` follows one of them step for step, so it halts too. -/ +theorem choiceTM_haltsIn (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (x : List Bool) (c : Cfg (k + 1) tm.Q) (hdrop : dropChoice c = tm.initCfg x) + (hinv : (c.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c.work (Fin.last k)).head) : + ∃ c' t, t ≤ f x.length + 1 ∧ (choiceTM tm).reachesIn t c c' ∧ (choiceTM tm).halted c' := by + obtain ⟨c', t, hle, hreach, -, heq⟩ := + choiceTM_simulates tm (f x.length + 1) c hinv hhead + refine ⟨c', t, hle, hreach, ?_⟩ + have hhalted_f : tm.halted + (tm.trace (f x.length) (fun j => choiceStream c j.val) (tm.initCfg x)) := hall x _ + have hfrozen := tm.trace_mono (T := f x.length) (T' := f x.length + 1) (by omega) + (choices := fun j => choiceStream c j.val) + (choices' := fun j => choiceStream c j.val) + (c := tm.initCfg x) (fun _ => rfl) hhalted_f + have hstate : (dropChoice c').state = tm.qhalt := by + rw [heq, hdrop, hfrozen] + exact hhalted_f + exact hstate + + +/-- **A path simulation keeps a window.** Since every path halts within `f |x| + 1` steps and a +head moves at most one cell per step, nothing travels more than that far beyond where it started. +No space hypothesis on `tm` is needed — its time bound does the work. -/ +theorem choiceTM_keepsWindowOn (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (x : List Bool) {inputLength h₀ : ℕ} : + (choiceTM tm).KeepsWindowOn + (fun c => dropChoice c = tm.initCfg x ∧ + (c.work (Fin.last k)).StartInvariant ∧ 1 ≤ (c.work (Fin.last k)).head ∧ + (∀ i, (c.work i).head ≤ h₀) ∧ c.input.head ≤ inputLength + h₀ + 1 ∧ + c.output.head ≤ h₀ + 1) + inputLength (h₀ + (f x.length + 1)) := + TM.keepsWindowOn_of_haltsIn + (fun _ hc i => hc.2.2.2.1 i) + (fun _ hc => hc.2.2.2.2.1) + (fun _ hc => hc.2.2.2.2.2) + (fun c hc => choiceTM_haltsIn tm hall x c hc.1 hc.2.1 hc.2.2.1) + + +/-- **The accepting-path count is a count over counter values.** `NTM.acceptCount` ranges over +functions `Fin T → Bool`; the counting machine ranges over the numbers below `2 ^ T`. The +correspondence of `choicesOfNat` and `natOfChoices` identifies the two counts, so the machine's +tally is the quantity `PP` compares against half. -/ +theorem acceptCount_eq_card_range {k : ℕ} (tm : NTM k) (x : List Bool) (T : ℕ) : + tm.acceptCount x T = + ((Finset.range (2 ^ T)).filter fun v => + let c' := tm.trace T (choicesOfNat T v) (tm.initCfg x) + c'.state = tm.qhalt ∧ c'.output.cells 1 = Γ.one).card := by + classical + refine (Finset.card_bij' (fun ch _ => natOfChoices T ch) (fun v _ => choicesOfNat T v) + ?_ ?_ ?_ ?_).symm ▸ rfl + · intro ch hch + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hch + simp only [Finset.mem_filter, Finset.mem_range] + refine ⟨natOfChoices_lt T ch, ?_⟩ + rw [choicesOfNat_natOfChoices] + exact hch + · intro v hv + simp only [Finset.mem_filter, Finset.mem_range] at hv + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact hv.2 + · intro ch _ + exact choicesOfNat_natOfChoices T ch + · intro v hv + simp only [Finset.mem_filter, Finset.mem_range] at hv + exact natOfChoices_choicesOfNat T v hv.1 + + +/-! ## The running tally + +A counting loop does not compute a cardinality; it accumulates. `tally` is that accumulation, and +`tally_eq_card` identifies it with the cardinality — which is the loop invariant the machine's +correctness proof will carry. -/ + +/-- The running count of the values below `N` satisfying `P`, as a loop accumulates it. -/ +def tally (P : ℕ → Bool) : ℕ → ℕ + | 0 => 0 + | N + 1 => tally P N + (if P N then 1 else 0) + +/-- **The accumulation computes the cardinality.** -/ +theorem tally_eq_card (P : ℕ → Bool) : + ∀ N, tally P N = ((Finset.range N).filter fun v => P v = true).card + | 0 => by simp [tally] + | N + 1 => by + have hins : Finset.range (N + 1) = insert N (Finset.range N) := by + ext v + simp only [Finset.mem_range, Finset.mem_insert] + omega + rw [tally, tally_eq_card P N, hins, Finset.filter_insert] + by_cases h : P N = true + · simp only [h, ↓reduceIte] + rw [Finset.card_insert_of_notMem (by simp)] + · simp [h] + +/-- **What the counting machine decides.** Membership is a comparison between `2 ^ T` and twice a +running tally over counter values — an accumulation a loop performs and a comparison of two +binary naturals. Neither probability, nor rationals, nor a quantifier over functions remains. -/ +theorem mem_iff_two_mul_tally {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : + x ∈ L ↔ 2 ^ f x.length < 2 * tally (fun v => + decide (let c' := tm.trace (f x.length) (choicesOfNat (f x.length) v) (tm.initCfg x) + c'.state = tm.qhalt ∧ c'.output.cells 1 = Γ.one)) (2 ^ f x.length) := by + classical + rw [hchar x, acceptCount_eq_card_range tm x (f x.length), tally_eq_card] + simp + + +/-- A tally and its complement partition the range. -/ +theorem tally_add_compl (P : ℕ → Bool) : + ∀ N, tally P N + tally (fun v => !P v) N = N + | 0 => rfl + | N + 1 => by + have ih := tally_add_compl P N + have key : ∀ b : Bool, (if b then 1 else 0) + (if !b then 1 else 0) = 1 := by decide + have hb := key (P N) + simp only [tally] + omega + +/-- **The threshold is a comparison of two counters.** More than half of the range satisfies `P` +exactly when the tally of `P` exceeds the tally of its complement. The machine therefore never +has to form `2 ^ T` or multiply: it keeps two counters and compares them. -/ +theorem lt_two_mul_tally_iff (P : ℕ → Bool) (N : ℕ) : + N < 2 * tally P N ↔ tally (fun v => !P v) N < tally P N := by + have h := tally_add_compl P N + omega + +/-- **What the counting machine decides, as a comparison of two counters.** -/ +theorem mem_iff_tally_lt_tally {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : + x ∈ L ↔ + tally (fun v => + !decide (let c' := tm.trace (f x.length) (choicesOfNat (f x.length) v) (tm.initCfg x) + c'.state = tm.qhalt ∧ c'.output.cells 1 = Γ.one)) (2 ^ f x.length) < + tally (fun v => + decide (let c' := tm.trace (f x.length) (choicesOfNat (f x.length) v) (tm.initCfg x) + c'.state = tm.qhalt ∧ c'.output.cells 1 = Γ.one)) (2 ^ f x.length) := by + rw [mem_iff_two_mul_tally hchar x, lt_two_mul_tally_iff] + + +/-! ## The counter tape is the choice sequence -/ + +/-- **What the path simulator reads off a binary counter tape.** `NTM.choiceStream` maps every +cell that is not `Γ.one` to `false`, including the blanks past the counter's last digit — and +those are exactly the high bits of the number, which are zero. So a tape carrying a binary string +*is* the choice sequence it encodes, padded with `false` for free. -/ +theorem choiceStream_of_hasBinaryString {k : ℕ} {tm : NTM k} (c : Cfg (k + 1) tm.Q) + (bits : List Bool) (h : (c.work (Fin.last k)).HasBinaryString bits) (j : ℕ) : + choiceStream c j = bits.getD j false := by + obtain ⟨hhead, hin, hout⟩ := h + simp only [choiceStream, hhead] + by_cases hj : j < bits.length + · have hgd : bits.getD j false = bits[j] := by + simp [List.getD, List.getElem?_eq_getElem hj] + rw [show 1 + j = j + 1 from by omega, hin j hj, hgd] + cases bits[j] <;> simp [Γ.ofBool] + · have hgd : bits.getD j false = false := by + simp [List.getD, List.getElem?_eq_none (show bits.length ≤ j by omega)] + rw [show 1 + j = j + 1 from by omega, hout j (by omega), hgd] + simp + + +/-! ## The count is stable under enlarging the horizon + +A counting machine cannot evaluate the protocol's own time bound `f` — it is an arbitrary +function known only to be `O(n^m)`. It must therefore count over a *polynomial* horizon it can +compute. That is sound because every path has already halted: extending the horizon multiplies +both the accepting count and the total by the same factor, so the comparison is unchanged. -/ + +/-- **Extending the horizon multiplies the accepting count by the number of extensions.** -/ +theorem acceptCount_add {k : ℕ} (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (x : List Bool) (b : ℕ) : + tm.acceptCount x (f x.length + b) = tm.acceptCount x (f x.length) * 2 ^ b := by + classical + set a := f x.length with ha + have hfreeze : ∀ w : Fin (a + b) → Bool, + tm.trace (a + b) w (tm.initCfg x) = tm.trace a (blockFst a b w) (tm.initCfg x) := + fun w => tm.trace_mono (T := a) (T' := a + b) (by omega) + (choices := blockFst a b w) (choices' := w) (fun _ => rfl) (hall x _) + have hset : (Finset.univ.filter fun w : Fin (a + b) → Bool => + (tm.trace (a + b) w (tm.initCfg x)).state = tm.qhalt ∧ + (tm.trace (a + b) w (tm.initCfg x)).output.cells 1 = Γ.one) + = Finset.univ.filter fun w : Fin (a + b) → Bool => + ((fun u : Fin a → Bool => + (tm.trace a u (tm.initCfg x)).state = tm.qhalt ∧ + (tm.trace a u (tm.initCfg x)).output.cells 1 = Γ.one) (blockFst a b w)) ∧ + ((fun _ : Fin b → Bool => True) (blockSnd a b w)) := by + ext w + simp only [Finset.mem_filter, Finset.mem_univ, true_and, hfreeze w, and_true] + have hblock := card_filter_block + (P := fun u : Fin a → Bool => + (tm.trace a u (tm.initCfg x)).state = tm.qhalt ∧ + (tm.trace a u (tm.initCfg x)).output.cells 1 = Γ.one) + (Q := fun _ : Fin b → Bool => True) + have hb : (Finset.univ.filter fun _ : Fin b → Bool => True).card = 2 ^ b := by + simp [Finset.filter_true_of_mem] + simp only [NTM.acceptCount] + rw [hset] + convert hblock.trans (by rw [hb]) using 2 + + +/-- **The comparison is unchanged by a larger, computable horizon.** Counting over `p |x|` choice +sequences instead of `f |x|` scales both sides by the same power of two. This is what lets the +machine use a polynomial it can evaluate in place of the protocol's own time function. -/ +theorem mem_iff_polyHorizon {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + {p : Polynomial ℕ} (hall : tm.AllPathsHaltIn f) (hle : ∀ n, f n ≤ p.eval n) + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : + x ∈ L ↔ 2 ^ p.eval x.length < 2 * tm.acceptCount x (p.eval x.length) := by + obtain ⟨b, hb⟩ : ∃ b, p.eval x.length = f x.length + b := + ⟨p.eval x.length - f x.length, by have := hle x.length; omega⟩ + have hd : (0 : ℕ) < 2 ^ b := by positivity + rw [hchar x, hb, acceptCount_add tm hall x b, pow_add, + show 2 * (tm.acceptCount x (f x.length) * 2 ^ b) + = (2 * tm.acceptCount x (f x.length)) * 2 ^ b from by ring] + exact (Nat.mul_lt_mul_right hd).symm + + +/-- **The `PP` comparison does not depend on the horizon**, as long as the horizon is past the +point where every path has halted. Extending it multiplies both the accepting count and the total +by the same power of two. This is what lets the counting machine run to a horizon of its own +choosing rather than the one its specification names. -/ +theorem cmp_horizon_iff {k : ℕ} (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (x : List Bool) (T : ℕ) (hT : f x.length ≤ T) : + (2 ^ T < 2 * tm.acceptCount x T) ↔ + (2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) := by + obtain ⟨b, hb⟩ : ∃ b, T = f x.length + b := ⟨T - f x.length, by omega⟩ + have hd : (0 : ℕ) < 2 ^ b := by positivity + rw [hb, acceptCount_add tm hall x b, pow_add, + show 2 * (tm.acceptCount x (f x.length) * 2 ^ b) + = (2 * tm.acceptCount x (f x.length)) * 2 ^ b from by ring] + exact Nat.mul_lt_mul_right hd + +/-- Two horizons past the halting point give the same comparison. -/ +theorem cmp_horizon_iff' {k : ℕ} (tm : NTM k) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (x : List Bool) (T T' : ℕ) (hT : f x.length ≤ T) (hT' : f x.length ≤ T') : + (2 ^ T < 2 * tm.acceptCount x T) ↔ (2 ^ T' < 2 * tm.acceptCount x T') := + (cmp_horizon_iff tm hall x T hT).trans (cmp_horizon_iff tm hall x T' hT').symm + +/-- The per-value acceptance test the counting loop performs: run the path selected by counter +value `v` and report whether it halts accepting. -/ +def acceptsAt {k : ℕ} (tm : NTM k) (x : List Bool) (T v : ℕ) : Bool := + decide ((tm.trace T (choicesOfNat T v) (tm.initCfg x)).state = tm.qhalt ∧ + (tm.trace T (choicesOfNat T v) (tm.initCfg x)).output.cells 1 = Γ.one) + +/-- **The degenerate machine decides the empty language.** A machine that starts halted never +moves, and its output tape is blank, so no choice sequence is accepting and the `PP` comparison +fails on every input. Ruling this case out is what licenses the `qstart ≠ qhalt` hypothesis the +delay construction needs. -/ +theorem acceptCount_eq_zero_of_qstart_eq_qhalt {k : ℕ} {tm : NTM k} + (heq : tm.qstart = tm.qhalt) (x : List Bool) (T : ℕ) : tm.acceptCount x T = 0 := by + classical + simp only [NTM.acceptCount] + rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] + intro ch _ + rw [tm.trace_halted T ch heq] + rintro ⟨-, hone⟩ + rw [show (tm.initCfg x).output = Tape.init ([] : List Γ) from rfl, + show (1 : ℕ) = 0 + 1 from rfl, Tape.init_nil_cells_succ] at hone + exact absurd hone (by decide) + +theorem not_mem_of_qstart_eq_qhalt {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + (heq : tm.qstart = tm.qhalt) + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : x ∉ L := by + rw [hchar x, acceptCount_eq_zero_of_qstart_eq_qhalt heq x (f x.length)] + simp + +/-- **The `PP` characterisation survives the delay.** `NTM.delayNTM` spends two extra steps and +doubles the count of accepting paths; the horizon's own doubling absorbs exactly that, so the +comparison `2 ^ T < 2 * acceptCount` is unchanged. This is what lets the counting machine +simulate a machine whose first transition ignores its choice bit — the only kind a composed +machine can enter, since no stage can be handed a head at cell zero. -/ +theorem delayNTM_char {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + (hall : tm.AllPathsHaltIn f) (hne : tm.qstart ≠ tm.qhalt) + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : + x ∈ L ↔ 2 ^ (f x.length + 2) < + 2 * (delayNTM tm).acceptCount x (f x.length + 2) := by + have hcount : (delayNTM tm).acceptCount x (f x.length + 2) + = 4 * tm.acceptCount x (f x.length) := by + rw [delayNTM_acceptCount tm x hne (f x.length), + show f x.length + 1 = f x.length + 1 from rfl, acceptCount_add tm hall x 1] + ring + have hpow : (2 : ℕ) ^ (f x.length + 2) = 4 * 2 ^ f x.length := by + rw [pow_add] + ring + rw [hchar x, hcount, hpow] + omega + +/-- **The tally is the accepting count.** Enumerating the counter over `[0, 2 ^ T)` visits every +choice sequence exactly once, so accumulating the acceptance test over that range counts the +accepting paths. -/ +theorem tally_eq_acceptCount {k : ℕ} (tm : NTM k) (x : List Bool) (T : ℕ) : + tally (fun v => acceptsAt tm x T v) (2 ^ T) = tm.acceptCount x T := by + rw [acceptCount_eq_card_range tm x T, tally_eq_card] + simp [acceptsAt] + +/-- **The comparison the machine performs is the `PP` comparison.** -/ +theorem tally_cmp_iff {k : ℕ} (tm : NTM k) (x : List Bool) (T : ℕ) : + (tally (fun v => !acceptsAt tm x T v) (2 ^ T) < + tally (fun v => acceptsAt tm x T v) (2 ^ T)) + ↔ 2 ^ T < 2 * tm.acceptCount x T := by + rw [← lt_two_mul_tally_iff, tally_eq_acceptCount] + +/-- **The complete machine specification for `PP`.** Everything on the right is something a +machine performs: iterate a counter to a polynomial bound it can evaluate, simulate one path per +counter value, keep two tallies, and compare them. No probability, no rationals, no quantifier +over the function space, and no reference to the protocol's own time function survive. -/ +theorem mem_iff_tally_lt_tally_poly {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + {p : Polynomial ℕ} (hall : tm.AllPathsHaltIn f) (hle : ∀ n, f n ≤ p.eval n) + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : + x ∈ L ↔ + tally (fun v => !acceptsAt tm x (p.eval x.length) v) (2 ^ p.eval x.length) < + tally (fun v => acceptsAt tm x (p.eval x.length) v) (2 ^ p.eval x.length) := by + rw [mem_iff_polyHorizon hall hle hchar x, ← lt_two_mul_tally_iff, + acceptCount_eq_card_range tm x (p.eval x.length), tally_eq_card] + simp [acceptsAt] + + +/-- **The inner call, fully placed.** The path simulator sits inside a machine with `m` extra +tapes and writes its verdict onto a work tape rather than the real output. Lifting is free and +the output redirection costs one cell, so the whole placed call keeps a window one wider than the +simulation's own. This is the form in which the counting machine invokes it. -/ +theorem choiceTM_placed_keepsWindow {k : ℕ} (tm : NTM k) {f : ℕ → ℕ} + (hall : tm.AllPathsHaltIn f) (x : List Bool) (m : ℕ) (c₀ : Cfg (k + 1) tm.Q) + {inputLength h₀ : ℕ} + (hdrop : dropChoice c₀ = tm.initCfg x) + (hinv : (c₀.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c₀.work (Fin.last k)).head) + (hheads : ∀ i, (c₀.work i).head ≤ h₀) + (hin : c₀.input.head ≤ inputLength + h₀ + 1) + (hout : c₀.output.head ≤ h₀ + 1) : + ∀ D, (((choiceTM tm).liftTM m).retargetOutput).reaches + (((choiceTM tm).liftTM m).retargetCfg ((choiceTM tm).liftCfg m c₀)) D → + D.WithinDecisionSpace inputLength (h₀ + (f x.length + 1) + 1) := + TM.retargetOutput_keepsWindow_of_reaches _ _ + (TM.liftTM_keepsWindow_of_reaches (choiceTM tm) m c₀ (by omega) + (choiceTM_keepsWindowOn tm hall x c₀ ⟨hdrop, hinv, hhead, hheads, hin, hout⟩)) + + +/-! ## The loop invariant + +The counting machine carries three numbers on its tapes: the counter, the accepting tally, and +the rejecting tally. `tallyStep` is one iteration's effect on that triple, and `tallyStep_iterate` +is the invariant relating the state after `N` iterations to `tally` — the fact the machine's +correctness proof carries through the loop. -/ + +/-- One iteration of the counting loop, on the triple (counter, accepting tally, rejecting +tally). -/ +def tallyStep (P : ℕ → Bool) (st : ℕ × ℕ × ℕ) : ℕ × ℕ × ℕ := + (st.1 + 1, st.2.1 + (if P st.1 then 1 else 0), st.2.2 + (if P st.1 then 0 else 1)) + +/-- **The loop invariant.** After `N` iterations from the zero state, the counter reads `N` and +the two tallies read the counts of the values below `N` satisfying and failing `P`. -/ +theorem tallyStep_iterate (P : ℕ → Bool) : + ∀ N, (tallyStep P)^[N] (0, 0, 0) = (N, tally P N, tally (fun v => !P v) N) + | 0 => rfl + | N + 1 => by + rw [Function.iterate_succ_apply', tallyStep_iterate P N] + have hsplit : (if !P N then 1 else 0) = (if P N then 0 else 1) := by + cases P N <;> simp + simp only [tallyStep, tally, hsplit] + + +/-- **What the counting machine must compute, as a single iterated function.** Running the loop +`2 ^ T` times from the zero state and comparing the two tallies decides membership. This is the +form the machine's Hoare contract will take: an iteration count, one step function, and a +comparison of two components of the final state. -/ +theorem mem_iff_iterate_tallyStep {k : ℕ} {L : Language} {tm : NTM k} {f : ℕ → ℕ} + {p : Polynomial ℕ} (hall : tm.AllPathsHaltIn f) (hle : ∀ n, f n ≤ p.eval n) + (hchar : ∀ x : List Bool, x ∈ L ↔ 2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) + (x : List Bool) : + x ∈ L ↔ + ((tallyStep (fun v => acceptsAt tm x (p.eval x.length) v))^[2 ^ p.eval x.length] + (0, 0, 0)).2.2 < + ((tallyStep (fun v => acceptsAt tm x (p.eval x.length) v))^[2 ^ p.eval x.length] + (0, 0, 0)).2.1 := by + rw [mem_iff_tally_lt_tally_poly hall hle hchar x, + tallyStep_iterate (fun v => acceptsAt tm x (p.eval x.length) v)] + + +/-- **The counting loop, granted a body that realises one step.** With the tape state of +`tallyState` and the index read back by `tallyIdx`, the indexed loop rule reduces the whole run to +two obligations: one iteration advances the state by `tallyStep`, and the loop halts at the final +count. Everything about counting — the invariant, the variant, the fuel — is discharged here. -/ +theorem tallyLoop_hoareTime {n : ℕ} (tmBody tmTest : TM n) (cIdx aIdx rIdx : Fin n) + (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) {post : TapePred n} (N b : ℕ) + (hstep : ∀ j, j < N → ∀ inp work out, + tallyState cIdx aIdx rIdx I rest ((tallyStep P)^[j] (0, 0, 0)) inp work out → + ∃ inp' work' out' t, t ≤ b ∧ + (TM.loopTM tmBody tmTest).reachesIn t + ⟨(TM.loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(TM.loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + tallyState cIdx aIdx rIdx I rest ((tallyStep P)^[j + 1] (0, 0, 0)) inp' work' out') + (hstop : ∀ inp work out, + tallyState cIdx aIdx rIdx I rest ((tallyStep P)^[N] (0, 0, 0)) inp work out → + ∃ c' t, t ≤ b ∧ + (TM.loopTM tmBody tmTest).reachesIn t + ⟨(TM.loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (TM.loopTM tmBody tmTest).halted c' ∧ post c'.input c'.work c'.output) : + (TM.loopTM tmBody tmTest).HoareTime + (tallyState cIdx aIdx rIdx I rest (0, 0, 0)) post ((N + 1) * b) := by + have hzero : ((tallyStep P)^[0] (0, 0, 0)) = (0, 0, 0) := rfl + refine TM.loopTM_hoareTime_indexed tmBody tmTest + (E := fun j => tallyState cIdx aIdx rIdx I rest ((tallyStep P)^[j] (0, 0, 0))) + (idx := tallyIdx cIdx) ?_ hstep hstop |>.consequence + (fun _ _ _ h => by rw [hzero]; exact h) (fun _ _ _ h => h) le_rfl + intro j inp work out h + rw [tallyIdx_tallyState cIdx aIdx rIdx I rest _ inp work out h, tallyStep_iterate] + + +/-- The output tape as the counting loop uses it: a single verdict cell, and blanks beyond it. +`TM.loopTM` inspects exactly this cell after rewinding the output, so the loop's whole +interaction with its output tape is the choice of one symbol. -/ +def outSlot (s : Γw) : Tape where + head := 1 + cells := fun j => if j = 0 then Γ.start else if j = 1 then s.toΓ else Γ.blank + +@[simp] theorem outSlot_head (s : Γw) : (outSlot s).head = 1 := rfl + +@[simp] theorem outSlot_cells_zero (s : Γw) : (outSlot s).cells 0 = Γ.start := rfl + +@[simp] theorem outSlot_cells_one (s : Γw) : (outSlot s).cells 1 = s.toΓ := rfl + +/-- A verdict slot never carries a stray left marker, so it is parked. -/ +theorem outSlot_parked (s : Γw) : TM.Parked (outSlot s) := by + refine ⟨le_refl 1, fun j hj => ?_⟩ + show (if j = 0 then Γ.start else if j = 1 then s.toΓ else Γ.blank) ≠ Γ.start + rw [if_neg (by omega)] + split + · cases s <;> simp [Γw.toΓ] + · simp + +/-- The verdict cell holds `1` exactly when the slot was written with `1`. -/ +theorem outSlot_cells_one_eq_one_iff (s : Γw) : (outSlot s).cells 1 = Γ.one ↔ s = Γw.one := by + cases s <;> simp [Γw.toΓ] + +/-- The tape state the counting loop sits in at its own start state. Every tape is named +outright: the three numeric registers hold the count and the two tallies, every other work tape +is back at its resting contents, and the output carries the previous check's verdict, which for a +continuing iteration is `0`. -/ +def tallyPre {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) + (v : ℕ) : TM.TapePred n := fun inp work out => + inp = I ∧ work = tallyWork cIdx aIdx rIdx rest (v, tally P v, tally (fun u => !P u) v) ∧ + ∃ s : Γw, s ≠ Γw.one ∧ out = outSlot s + +/-- The tape state the loop's test leaves behind: the same registers, with the verdict slot +holding `1` exactly when the count has reached its horizon. -/ +def tallyPost {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) + (N v : ℕ) : TM.TapePred n := fun inp work out => + inp = I ∧ work = tallyWork cIdx aIdx rIdx rest (v, tally P v, tally (fun u => !P u) v) ∧ + out = outSlot (if v = N then Γw.one else Γw.zero) + +/-- A pinned tally state is parked on every tape, given that the resting tapes are. -/ +theorem tallyPre_loopParked {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) (rest : Fin n → Tape) + (P : ℕ → Bool) (hI : TM.Parked I) (hrest : ∀ i, TM.Parked (rest i)) (v : ℕ) + {inp : Tape} {work : Fin n → Tape} {out : Tape} + (h : tallyPre cIdx aIdx rIdx I rest P v inp work out) : TM.LoopParked inp work out := by + obtain ⟨rfl, rfl, s, -, rfl⟩ := h + refine ⟨hI, fun i => ?_, outSlot_parked _, rfl, rfl⟩ + simp only [tallyWork] + split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · exact hrest i + +/-- The same, for the state the test leaves behind. -/ +theorem tallyPost_loopParked {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) (rest : Fin n → Tape) + (P : ℕ → Bool) (hI : TM.Parked I) (hrest : ∀ i, TM.Parked (rest i)) (N v : ℕ) + {inp : Tape} {work : Fin n → Tape} {out : Tape} + (h : tallyPost cIdx aIdx rIdx I rest P N v inp work out) : TM.LoopParked inp work out := by + obtain ⟨rfl, rfl, rfl⟩ := h + refine ⟨hI, fun i => ?_, outSlot_parked _, rfl, rfl⟩ + simp only [tallyWork] + split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · split + · exact natTape_parked _ + · exact hrest i + +/-- **Reading the count back off a pinned tally state.** -/ +theorem tallyIdx_tallyPre {n : ℕ} (cIdx aIdx rIdx : Fin n) (I : Tape) (rest : Fin n → Tape) + (P : ℕ → Bool) (v : ℕ) {inp : Tape} {work : Fin n → Tape} {out : Tape} + (h : tallyPre cIdx aIdx rIdx I rest P v inp work out) : tallyIdx cIdx inp work out = v := by + obtain ⟨-, rfl, -, -, -⟩ := h + have hc : (tallyWork cIdx aIdx rIdx rest + (v, tally P v, tally (fun u => !P u) v) cIdx).HasBinaryNat v := by + simp only [tallyWork, natTape] + exact Tape.init_move_right_hasBinaryNat v + have hex : ∃ w, (tallyWork cIdx aIdx rIdx rest + (v, tally P v, tally (fun u => !P u) v) cIdx).HasBinaryNat w := ⟨v, hc⟩ + exact hasBinaryNat_value_unique (Classical.epsilon_spec hex) hc + +/-- **The counting loop from two Hoare contracts.** This is the interface the machine +construction actually meets: a contract saying the body advances the tally by one index, and a +contract saying the test reports whether the horizon has been reached. + +`TM.loopTM` is a do-while — its body runs before its first test — so a loop that halts after `N` +tallies performs its `N`-th body pass on the *terminating* iteration, not on a continuing one. +The indexed rule is therefore applied at `N - 1`, which is why the body is never asked to run at +index `N` and why `1 ≤ N` is needed. -/ +theorem tallyLoop_hoareTime_of_hoare {n : ℕ} (tmBody tmTest : TM n) (cIdx aIdx rIdx : Fin n) + (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) (mid : ℕ → TM.TapePred n) + (N bBody bTest : ℕ) (hN : 1 ≤ N) + (hI : TM.Parked I) (hrest : ∀ i, TM.Parked (rest i)) + (hbody : ∀ v, v < N → + tmBody.HoareTime (tallyPre cIdx aIdx rIdx I rest P v) (mid v) bBody) + (hmid : ∀ v inp work out, mid v inp work out → TM.LoopParked inp work out) + (htest : ∀ v, v < N → + tmTest.HoareTime (mid v) (tallyPost cIdx aIdx rIdx I rest P N (v + 1)) bTest) : + (TM.loopTM tmBody tmTest).HoareTime + (tallyPre cIdx aIdx rIdx I rest P 0) + (tallyPost cIdx aIdx rIdx I rest P N N) + (N * (bBody + bTest + 5)) := by + have hsucc : N - 1 + 1 = N := by omega + refine (TM.loopTM_hoareTime_indexed tmBody tmTest + (E := fun j => tallyPre cIdx aIdx rIdx I rest P j) + (post := tallyPost cIdx aIdx rIdx I rest P N N) + (N := N - 1) (b := bBody + bTest + 5) + (idx := tallyIdx cIdx) ?_ ?_ ?_).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (le_of_eq (by rw [hsucc])) + · intro j inp work out h + exact tallyIdx_tallyPre cIdx aIdx rIdx I rest P j h + · intro j hj inp work out h + have hjN : j < N := by omega + have hne : ∀ a b c, tallyPost cIdx aIdx rIdx I rest P N (j + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 ≠ Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I rest P hI hrest N (j + 1) hp, ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_neg (show ¬ (j + 1 = N) by omega)] + exact fun hcon => absurd (outSlot_cells_one_eq_one_iff Γw.zero |>.mp hcon) (by decide) + obtain ⟨inp', work', out', t, -, ht, hreach, hp'⟩ := + TM.loopTM_continue_of_hoare tmBody tmTest (hbody j hjN) (htest j hjN) + (fun a b c hm => hmid j a b c hm) hne inp work out h + obtain ⟨hi', hw', ho'⟩ := hp' + exact ⟨inp', work', out', t, ht, hreach, hi', hw', Γw.zero, by decide, + by rw [ho', if_neg (by omega)]⟩ + · intro inp work out h + have hjN : N - 1 < N := by omega + have hhalt : ∀ a b c, tallyPost cIdx aIdx rIdx I rest P N (N - 1 + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 = Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I rest P hI hrest N _ hp, ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_pos hsucc] + exact (outSlot_cells_one_eq_one_iff Γw.one).mpr rfl + obtain ⟨c', t, ht, hreach, hstate, hpost⟩ := + TM.loopTM_halt_of_hoare tmBody tmTest (hbody (N - 1) hjN) (htest (N - 1) hjN) + (fun a b c hm => hmid (N - 1) a b c hm) hhalt inp work out h + exact ⟨c', t, ht, hreach, hstate, by rw [hsucc] at hpost; exact hpost⟩ + + +/-- **The counting loop keeps a window one iteration wide.** The loop runs exponentially many +iterations, so no bound derived from its total running time can be polynomial; what is polynomial +is a single iteration, and every state the loop returns to has all its heads at cell one. -/ +theorem tallyLoop_keepsWindow_of_hoare {n : ℕ} (tmBody tmTest : TM n) (cIdx aIdx rIdx : Fin n) + (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) (mid : ℕ → TM.TapePred n) + (N bBody bTest inputLength : ℕ) (hN : 1 ≤ N) + (hI : TM.Parked I) (hrest : ∀ i, TM.Parked (rest i)) + (hIhead : I.head ≤ inputLength + 1) (hrestHead : ∀ i, (rest i).head ≤ 1) + (hbody : ∀ v, v < N → + tmBody.HoareTime (tallyPre cIdx aIdx rIdx I rest P v) (mid v) bBody) + (hmid : ∀ v inp work out, mid v inp work out → TM.LoopParked inp work out) + (htest : ∀ v, v < N → + tmTest.HoareTime (mid v) (tallyPost cIdx aIdx rIdx I rest P N (v + 1)) bTest) : + ∀ inp work out, tallyPre cIdx aIdx rIdx I rest P 0 inp work out → + ∀ c, (TM.loopTM tmBody tmTest).reaches + ⟨(TM.loopTM tmBody tmTest).qstart, inp, work, out⟩ c → + c.WithinDecisionSpace inputLength (1 + (bBody + bTest + 5)) := by + have hsucc : N - 1 + 1 = N := by omega + refine TM.loopTM_keepsWindow_indexed_of_parked tmBody tmTest + (fun j => tallyPre cIdx aIdx rIdx I rest P j) (N - 1) (bBody + bTest + 5) ?_ ?_ ?_ 0 + (by omega) + · intro j hj inp work out h + have hjN : j < N := by omega + have hne : ∀ a b c, tallyPost cIdx aIdx rIdx I rest P N (j + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 ≠ Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I rest P hI hrest N (j + 1) hp, ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_neg (show ¬ (j + 1 = N) by omega)] + exact fun hcon => absurd (outSlot_cells_one_eq_one_iff Γw.zero |>.mp hcon) (by decide) + obtain ⟨inp', work', out', t, ht1, ht, hreach, hp'⟩ := + TM.loopTM_continue_of_hoare tmBody tmTest (hbody j hjN) (htest j hjN) + (fun a b c hm => hmid j a b c hm) hne inp work out h + obtain ⟨hi', hw', ho'⟩ := hp' + exact ⟨inp', work', out', t, ht1, ht, hreach, hi', hw', Γw.zero, by decide, + by rw [ho', if_neg (by omega)]⟩ + · intro inp work out h + have hjN : N - 1 < N := by omega + have hhalt : ∀ a b c, tallyPost cIdx aIdx rIdx I rest P N (N - 1 + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 = Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I rest P hI hrest N _ hp, ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_pos hsucc] + exact (outSlot_cells_one_eq_one_iff Γw.one).mpr rfl + obtain ⟨c', t, ht, hreach, hstate, -⟩ := + TM.loopTM_halt_of_hoare tmBody tmTest (hbody (N - 1) hjN) (htest (N - 1) hjN) + (fun a b c hm => hmid (N - 1) a b c hm) hhalt inp work out h + exact ⟨c', t, ht, hreach, hstate⟩ + · rintro j - inp work out ⟨rfl, rfl, s, -, rfl⟩ + refine ⟨fun i => ?_, hIhead, le_of_eq rfl⟩ + simp only [tallyWork] + split + · exact le_of_eq rfl + · split + · exact le_of_eq rfl + · split + · exact le_of_eq rfl + · exact hrestHead i + +/-- **The path simulation leaves the counter's digits alone.** `choiceTM` writes every choice bit +back unchanged and only advances the head, so the counter tape's contents survive the run — the +body has merely to rewind the head to restore the encoding for the next iteration. -/ +theorem choiceTM_choiceCells {k : ℕ} (tm : NTM k) {c : Cfg (k + 1) tm.Q} + (hinv : (c.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c.work (Fin.last k)).head) : + ∀ c', (choiceTM tm).reaches c c' → + (c'.work (Fin.last k)).cells = (c.work (Fin.last k)).cells ∧ + (c'.work (Fin.last k)).StartInvariant ∧ 1 ≤ (c'.work (Fin.last k)).head := by + intro c' h + induction h with + | refl => exact ⟨rfl, hinv, hhead⟩ + | @tail dmid dnext _ hstp ih => + obtain ⟨hcells, hsi, hhd⟩ := ih + have hstp' : (choiceTM tm).step dmid = some dnext := hstp + have hne : dmid.state ≠ tm.qhalt := TM.state_ne_qhalt_of_step hstp' + have hread : (dmid.work (Fin.last k)).read ≠ Γ.start := hsi.read_ne_start hhd + obtain ⟨c₁, hstep1, -, hchoice⟩ := choiceTM_step tm dmid hne hread + have hnexteq : dnext = c₁ := (Option.some_inj.mp (hstp'.symm.trans hstep1)) + subst hnexteq + refine ⟨?_, ?_, ?_⟩ + · rw [hchoice, Tape.move_cells] + exact hcells + · refine ⟨?_, ?_⟩ + · rw [hchoice, Tape.move_cells] + exact hsi.1 + · intro j hj + rw [hchoice, Tape.move_cells] + exact hsi.2 j hj + · rw [hchoice] + show 1 ≤ ((dmid.work (Fin.last k)).move Dir3.right).head + show 1 ≤ (dmid.work (Fin.last k)).head + 1 + omega + + +/-- **A counter tape reads exactly as the choice sequence of its value.** Combining the encoding +bridge with the bit correspondence: if the choice tape carries the canonical representation of +`v`, then the stream the path simulator consumes is `choicesOfNat T v` — no padding, no copy, and +no fixed-width counter. -/ +theorem choiceStream_eq_choicesOfNat {k : ℕ} {tm : NTM k} (c : Cfg (k + 1) tm.Q) (v T : ℕ) + (h : (c.work (Fin.last k)).HasBinaryNat v) (j : Fin T) : + choiceStream c j.val = choicesOfNat T v j := by + rw [choiceStream_of_hasBinaryString c v.bits h.2, choicesOfNat_apply, getD_eq_bit, + binValLE_bits] + + +/-- A canonical binary tape carries its left marker and nothing else does. -/ +theorem hasBinaryNat_startInvariant {t : Tape} {v : ℕ} (h : t.HasBinaryNat v) : + t.StartInvariant := by + obtain ⟨h0, -, hin, hout⟩ := h + refine ⟨h0, fun j hj => ?_⟩ + obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + by_cases hi : i < v.bits.length + · rw [hin i hi] + cases v.bits[i] <;> simp [Γ.ofBool] + · rw [hout i (by omega)] + simp + +/-- **What the simulation computes from a counter value.** Started with the counter tape carrying +`v` and the machine's own tapes in their initial configuration, the path simulator produces +exactly the trace of `tm` along the choice sequence `choicesOfNat T v`. -/ +theorem choiceTM_dropChoice_eq {k : ℕ} (tm : NTM k) (x : List Bool) (T v : ℕ) + (c : Cfg (k + 1) tm.Q) (hdrop : dropChoice c = tm.initCfg x) + (hv : (c.work (Fin.last k)).HasBinaryNat v) : + ∃ c' t, t ≤ T ∧ (choiceTM tm).reachesIn t c c' ∧ + dropChoice c' = tm.trace T (choicesOfNat T v) (tm.initCfg x) := by + have hinv := hasBinaryNat_startInvariant hv + have hhead : 1 ≤ (c.work (Fin.last k)).head := by + rw [hv.2.1] + obtain ⟨c', t, hle, hreach, -, heq⟩ := choiceTM_simulates tm T c hinv hhead + refine ⟨c', t, hle, hreach, heq.trans ?_⟩ + rw [hdrop] + congr 1 + funext j + exact choiceStream_eq_choicesOfNat c v T hv j + +/-- **What the loop body's simulation computes.** Started from the delayed machine's +post-sentinel configuration — every head at cell one, the counter carrying `v`, the machine's own +tapes blank — the path simulator produces exactly the source machine's trace along the choice +sequence `v` encodes. + +Two corrections cancel here. Entering after the sentinel step costs one step of the delayed +machine, and the delay itself costs one; together they are exactly the two steps +`NTM.delayNTM_trace_initCfg` charges, so the horizon `T` on the counter is the source machine's +own horizon, with no off-by-one left over. -/ +theorem choiceTM_delay_dropChoice_eq {k : ℕ} (tm : NTM k) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) (T v : ℕ) (hT : 1 ≤ T) + (c : Cfg (k + 1) (delayNTM tm).Q) + (hdrop : dropChoice c + = (delayNTM tm).trace 1 (fun _ => false) ((delayNTM tm).initCfg x)) + (hv : (c.work (Fin.last k)).HasBinaryNat v) : + ∃ c' t, t ≤ T ∧ (choiceTM (delayNTM tm)).reachesIn t c c' ∧ + dropChoice c' = delayEmbed tm (tm.trace T (choicesOfNat T v) (tm.initCfg x)) := by + obtain ⟨S, rfl⟩ : ∃ S, T = S + 1 := ⟨T - 1, by omega⟩ + have hinv := hasBinaryNat_startInvariant hv + have hhead : 1 ≤ (c.work (Fin.last k)).head := by rw [hv.2.1] + obtain ⟨c', t, hle, hreach, -, heq⟩ := choiceTM_simulates (delayNTM tm) (S + 1) c hinv hhead + refine ⟨c', t, hle, hreach, ?_⟩ + have hstream : (fun j : Fin (S + 1) => choiceStream c j.val) = choicesOfNat (S + 1) v := by + funext j + exact choiceStream_eq_choicesOfNat c v (S + 1) hv j + refine heq.trans ?_ + rw [hstream, hdrop] + have hsplit := NTM.trace_succ (delayNTM tm) (S + 1) + (Fin.cons false (choicesOfNat (S + 1) v)) ((delayNTM tm).initCfg x) + have hA : (delayNTM tm).trace (S + 2) (Fin.cons false (choicesOfNat (S + 1) v)) + ((delayNTM tm).initCfg x) + = (delayNTM tm).trace (S + 1) (choicesOfNat (S + 1) v) + ((delayNTM tm).trace 1 (fun _ => false) ((delayNTM tm).initCfg x)) := by + rw [hsplit] + congr 1 + rw [← hA, delayNTM_trace_initCfg tm x hne S (Fin.cons false (choicesOfNat (S + 1) v)), + Fin.tail_cons] + +/-- **The loop body's simulation, run to a halt with its verdict.** The counter's value selects +a path, the simulation follows it to the end, and the halted configuration's verdict cell holds +exactly the bit the tally is counting. -/ +theorem choiceTM_delay_haltsIn {k : ℕ} (tm : NTM k) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) + (T v : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (c : Cfg (k + 1) (delayNTM tm).Q) + (hdrop : dropChoice c + = (delayNTM tm).trace 1 (fun _ => false) ((delayNTM tm).initCfg x)) + (hv : (c.work (Fin.last k)).HasBinaryNat v) : + ∃ c' t, t ≤ T ∧ (choiceTM (delayNTM tm)).reachesIn t c c' ∧ + (choiceTM (delayNTM tm)).halted c' ∧ + decide (c'.output.cells 1 = Γ.one) = acceptsAt tm x T v := by + obtain ⟨c', t, hle, hreach, heq⟩ := + choiceTM_delay_dropChoice_eq tm x hne T v hT c hdrop hv + have hsrc : (tm.trace T (choicesOfNat T v) (tm.initCfg x)).state = tm.qhalt := by + have hfrozen := tm.trace_mono (T := f x.length) (T' := T) hfT + (choices := fun j => choicesOfNat T v ⟨j.val, by omega⟩) + (choices' := choicesOfNat T v) (fun _ => rfl) (hall x _) + rw [hfrozen] + exact hall x _ + have hstate : c'.state = (dropChoice c').state := rfl + have hout : c'.output = (dropChoice c').output := rfl + refine ⟨c', t, hle, hreach, ?_, ?_⟩ + · show c'.state = (delayNTM tm).qhalt + rw [hstate, heq] + exact (delayEmbed_halted_iff tm _).mpr hsrc + · rw [acceptsAt, hout, heq] + have houteq : (delayEmbed tm (tm.trace T (choicesOfNat T v) (tm.initCfg x))).output + = (tm.trace T (choicesOfNat T v) (tm.initCfg x)).output := rfl + rw [houteq] + refine (decide_eq_decide.mpr ?_).symm + exact ⟨fun h => h.2, fun h => ⟨hsrc, h⟩⟩ + +/-- **The verdict the loop body reads is the enumeration's acceptance test.** -/ +theorem choiceTM_verdict {k : ℕ} (tm : NTM k) (x : List Bool) (T v : ℕ) + {c' : Cfg (k + 1) tm.Q} + (heq : dropChoice c' = tm.trace T (choicesOfNat T v) (tm.initCfg x)) : + decide (c'.state = tm.qhalt ∧ c'.output.cells 1 = Γ.one) = acceptsAt tm x T v := by + have hstate : c'.state = (dropChoice c').state := rfl + have hout : c'.output = (dropChoice c').output := rfl + rw [acceptsAt, hstate, hout, heq] + + +/-- **The counting loop, granted only that the body advances the triple.** The body's obligation +no longer mentions iterates or tallies: from a state holding `(v, a, r)` it must reach the state +holding `(v + 1, a + [P v], r + [¬P v])`. All the counting bookkeeping is discharged here. -/ +theorem tallyLoop_hoareTime_of_body {n : ℕ} (tmBody tmTest : TM n) (cIdx aIdx rIdx : Fin n) + (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) {post : TapePred n} (N b : ℕ) + (hbody : ∀ v a r : ℕ, v < N → ∀ inp work out, + tallyState cIdx aIdx rIdx I rest (v, a, r) inp work out → + ∃ inp' work' out' t, t ≤ b ∧ + (TM.loopTM tmBody tmTest).reachesIn t + ⟨(TM.loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(TM.loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + tallyState cIdx aIdx rIdx I rest + (v + 1, a + (if P v then 1 else 0), r + (if P v then 0 else 1)) inp' work' out') + (hstop : ∀ inp work out, + tallyState cIdx aIdx rIdx I rest (N, tally P N, tally (fun v => !P v) N) inp work out → + ∃ c' t, t ≤ b ∧ + (TM.loopTM tmBody tmTest).reachesIn t + ⟨(TM.loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (TM.loopTM tmBody tmTest).halted c' ∧ post c'.input c'.work c'.output) : + (TM.loopTM tmBody tmTest).HoareTime + (tallyState cIdx aIdx rIdx I rest (0, 0, 0)) post ((N + 1) * b) := by + refine tallyLoop_hoareTime tmBody tmTest cIdx aIdx rIdx I rest P N b ?_ ?_ + · intro j hj inp work out h + rw [tallyStep_iterate] at h + obtain ⟨inp', work', out', t, ht, hreach, h'⟩ := + hbody j (tally P j) (tally (fun v => !P v) j) hj inp work out h + refine ⟨inp', work', out', t, ht, hreach, ?_⟩ + rw [tallyStep_iterate] + have hflip : (if !P j then 1 else 0) = (if P j then 0 else 1) := by cases P j <;> simp + have e1 : tally P (j + 1) = tally P j + (if P j then 1 else 0) := rfl + have e2 : tally (fun v => !P v) (j + 1) + = tally (fun v => !P v) j + (if P j then 0 else 1) := by + show tally (fun v => !P v) j + (if !P j then 1 else 0) = _ + rw [hflip] + rw [e1, e2] + exact h' + · intro inp work out h + rw [tallyStep_iterate] at h + exact hstop inp work out h + + +/-- **The inner call as the loop's test, placed.** `TM.ifTM` branches on the *real* output tape's +verdict cell, and the path simulator already writes `tm`'s verdict there — so the simulation can +serve directly as the conditional's test, with no output retargeting. Only the lift into the +larger tape space is needed, and that is free. -/ +theorem choiceTM_lifted_keepsWindow {k : ℕ} (tm : NTM k) {f : ℕ → ℕ} + (hall : tm.AllPathsHaltIn f) (x : List Bool) (m : ℕ) (c₀ : Cfg (k + 1) tm.Q) + {inputLength h₀ : ℕ} + (hdrop : dropChoice c₀ = tm.initCfg x) + (hinv : (c₀.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c₀.work (Fin.last k)).head) + (hheads : ∀ i, (c₀.work i).head ≤ h₀) + (hin : c₀.input.head ≤ inputLength + h₀ + 1) + (hout : c₀.output.head ≤ h₀ + 1) : + ∀ D, ((choiceTM tm).liftTM m).reaches ((choiceTM tm).liftCfg m c₀) D → + D.WithinDecisionSpace inputLength (h₀ + (f x.length + 1)) := + TM.liftTM_keepsWindow_of_reaches (choiceTM tm) m c₀ (by omega) + (choiceTM_keepsWindowOn tm hall x c₀ ⟨hdrop, hinv, hhead, hheads, hin, hout⟩) + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPSim.lean b/Complexitylib/Classes/Containments/Internal/PPSim.lean new file mode 100644 index 00000000..3d6bbec8 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPSim.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PPParts +public import Complexitylib.Models.TuringMachine.Placement +public import Complexitylib.Models.TuringMachine.Lift +public import Complexitylib.Models.TuringMachine.Subroutines.WipeRewind + +/-! +# The counting loop's simulation stage + +⚠️ Unreviewed by Bolton + +The loop body runs one path of the source machine and reads off whether it accepts. Three +wrappers turn that simulation into something a composed machine can use as a stage: + +* `TM.startedTM` moves the start state past the compulsory `▷`-step, because no stage of a + composed machine can be entered with a head at cell zero; +* `TM.placeWorkTM 0 m` sets the simulation's tapes beside the loop's own registers, with an + *exact* frame — the registers come back untouched; +* `TM.retargetOutput` sends the verdict to a work tape instead of the real output tape, which + has to stay blank for the wipe that follows. + +None of the three costs a step, and none of them disturbs the others' tapes, so a run of the +simulation transports to a run of the stage of exactly the same length. + +## Main results + +- `NTM.simTM` — the simulation as a stage of the counting machine +- `NTM.simTM_reachesIn` — a run of the simulation is a run of the stage +- `NTM.simTM_verdict_tape` — the verdict lands on the stage's last work tape +- `NTM.simTM_run` — the stage run to a halt, with the acceptance bit of path `v` +- `NTM.simEntry`, `NTM.simEntry_dropChoice` — the configuration the stage is entered at +- `NTM.simTM_frame` — the invariants and head bounds the stage leaves behind +- `NTM.simCfg_work_middle`, `NTM.simCfg_work_extra`, `NTM.simCfg_counter_cells` — where each of + the stage's tapes comes from +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} + +/-- The path simulator, entered after its sentinel step. -/ +def simCore (tm : NTM k) : TM (k + 1) := + TM.startedTM (choiceTM (delayNTM tm)) + +/-- **The simulation as a stage of the counting machine.** Its tapes are the source machine's +`k` work tapes and the choice tape — which is the loop's counter — followed by `m` registers of +the loop's own and, last, the tape the verdict is written to. -/ +def simTM (tm : NTM k) (m : ℕ) : TM (0 + (k + 1) + m + 1) := + (TM.placeWorkTM 0 m (simCore tm)).retargetOutput + +/-- The stage's entry configuration: the simulation's own configuration, placed beside the +loop's registers, with the real output tape blank. -/ +def simCfg (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (c : Cfg (k + 1) (simCore tm).Q) : Cfg (0 + (k + 1) + m + 1) (simTM tm m).Q := + (TM.placeWorkTM 0 m (simCore tm)).retargetCfg + (TM.placeWorkCfg (simCore tm) 0 m extras c) + +/-- **A run of the simulation is a run of the stage**, of exactly the same length. The loop's +registers need only carry their left marker and be parked; they are returned untouched. -/ +theorem simTM_reachesIn (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (hinv : ∀ i, ¬ TM.placeWorkInMiddle 0 (k + 1) i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ TM.placeWorkInMiddle 0 (k + 1) i → 1 ≤ (extras i).head) + {t : ℕ} {c c' : Cfg (k + 1) (simCore tm).Q} + (h : (simCore tm).reachesIn t c c') : + (simTM tm m).reachesIn t (simCfg tm m extras c) (simCfg tm m extras c') := + TM.retargetOutput_reachesIn_retargetCfg_frame _ + (TM.placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant (simCore tm) 0 m extras h + hinv hhead) + +/-- The verdict lands on the stage's last work tape — the one `TM.retargetOutput` redirects the +simulation's output to. -/ +theorem simTM_verdict_tape (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (c : Cfg (k + 1) (simCore tm).Q) : + (simCfg tm m extras c).work (Fin.last (0 + (k + 1) + m)) = c.output := + TM.retargetCfg_work_last _ _ + +/-- The stage leaves the real output tape blank and parked, which is what the wipe that follows +the simulation requires. -/ +theorem simTM_output (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (c : Cfg (k + 1) (simCore tm).Q) : + (simCfg tm m extras c).output = (Tape.init ([] : List Γ)).move Dir3.right := rfl + +/-- The stage's start state is the simulation's, so a run of the stage from `simCfg` is a run +from the stage machine's own start state. -/ +theorem simTM_qstart (tm : NTM k) (m : ℕ) : (simTM tm m).qstart = (simCore tm).qstart := rfl + + +/-- **The simulation stage, run to a halt with its verdict.** From an entry configuration whose +counter carries `v` and whose simulated tapes are the delayed machine's post-sentinel ones, the +stage halts within the horizon, leaves the loop's registers exactly as it found them, and writes +the acceptance bit of path `v` onto its last work tape. -/ +theorem simTM_run (tm : NTM k) (x : List Bool) (hne : tm.qstart ≠ tm.qhalt) + {f : ℕ → ℕ} (hall : tm.AllPathsHaltIn f) (T v : ℕ) (hT : 1 ≤ T) (hfT : f x.length ≤ T) + (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (hinv : ∀ i, ¬ TM.placeWorkInMiddle 0 (k + 1) i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ TM.placeWorkInMiddle 0 (k + 1) i → 1 ≤ (extras i).head) + (c : Cfg (k + 1) (simCore tm).Q) + (hdrop : dropChoice c + = (delayNTM tm).trace 1 (fun _ => false) ((delayNTM tm).initCfg x)) + (hv : (c.work (Fin.last k)).HasBinaryNat v) : + ∃ (c' : Cfg (k + 1) (simCore tm).Q) (t : ℕ), t ≤ T ∧ + (simCore tm).reachesIn t c c' ∧ + (simTM tm m).reachesIn t (simCfg tm m extras c) (simCfg tm m extras c') ∧ + (simTM tm m).halted (simCfg tm m extras c') ∧ + decide (((simCfg tm m extras c').work + (Fin.last (0 + (k + 1) + m))).cells 1 = Γ.one) = acceptsAt tm x T v := by + obtain ⟨c', t, hle, hreach, hhalt, hverdict⟩ := + choiceTM_delay_haltsIn tm x hne hall T v hT hfT c hdrop hv + refine ⟨c', t, hle, TM.reachesIn_startedTM _ hreach, + simTM_reachesIn tm m extras hinv hhead (TM.reachesIn_startedTM _ hreach), hhalt, ?_⟩ + rw [simTM_verdict_tape tm m extras c'] + exact hverdict + + +/-- **The simulation's entry configuration.** The delayed machine's post-sentinel state: every +head at cell one, the machine's own tapes blank, and the counter carrying `v`. -/ +def simEntry (tm : NTM k) (x : List Bool) (v : ℕ) : Cfg (k + 1) (simCore tm).Q where + state := (simCore tm).qstart + input := (Tape.init (x.map Γ.ofBool)).move Dir3.right + work := fun i => if i.val < k then TM.blankTape else natTape v + output := TM.blankTape + +theorem simEntry_counter (tm : NTM k) (x : List Bool) (v : ℕ) : + (simEntry tm x v).work (Fin.last k) = natTape v := by + show (if (Fin.last k).val < k then TM.blankTape else natTape v) = _ + rw [if_neg (by simp)] + +theorem simEntry_counter_hasBinaryNat (tm : NTM k) (x : List Bool) (v : ℕ) : + ((simEntry tm x v).work (Fin.last k)).HasBinaryNat v := by + rw [simEntry_counter] + simpa [natTape] using Tape.init_move_right_hasBinaryNat v + +/-- The resumed simulation's start state is the delayed machine's extra state: the sentinel step +reads `▷` on the choice tape, and the delayed machine's first transition ignores its choice bit, +so nothing branches there. -/ +theorem simCore_qstart (tm : NTM k) : (simCore tm).qstart = Sum.inl () := rfl + +/-- **The entry configuration is the delayed machine's post-sentinel one.** This is the hypothesis +`NTM.choiceTM_delay_haltsIn` asks for: the simulation is entered exactly where the compulsory +`▷`-step would have left the machine. -/ +theorem simEntry_dropChoice (tm : NTM k) (x : List Bool) (v : ℕ) : + dropChoice (simEntry tm x v) + = (delayNTM tm).trace 1 (fun _ => false) ((delayNTM tm).initCfg x) := by + rw [trace_one_of_heads_zero (delayNTM tm) false ((delayNTM tm).initCfg x) + (by show (Sum.inl () : Unit ⊕ tm.Q) ≠ Sum.inr tm.qhalt; nofun) + rfl (fun _ => rfl) rfl (Tape.init_cells_zero _) (fun _ => Tape.init_cells_zero _) + (Tape.init_cells_zero _)] + refine Cfg.ext rfl rfl ?_ rfl + · funext i + show (if (i.castSucc : Fin (k + 1)).val < k then TM.blankTape else natTape v) + = ((Tape.init ([] : List Γ))).move Dir3.right + rw [show (i.castSucc : Fin (k + 1)).val = (i : ℕ) from rfl, if_pos i.isLt] + rfl + + +/-- **What the stage leaves behind.** Every tape still carries its marker only at cell zero; no +head has travelled further than the run was long; the input tape's contents are untouched, since +a machine never writes to it. These are the facts the cleanup stage needs, and they hold for any +stage, so they are read off the generic run lemmas. -/ +theorem simTM_frame (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + {t : ℕ} {c c' : Cfg (k + 1) (simCore tm).Q} + (hrun : (simTM tm m).reachesIn t (simCfg tm m extras c) (simCfg tm m extras c')) + (hInvI : Tape.StartInvariant (simCfg tm m extras c).input) + (hInvW : ∀ j, Tape.StartInvariant ((simCfg tm m extras c).work j)) + (hInvO : Tape.StartInvariant (simCfg tm m extras c).output) + (hHeadI : (simCfg tm m extras c).input.head ≤ 1) + (hHeadW : ∀ j, ((simCfg tm m extras c).work j).head ≤ 1) : + Tape.StartInvariant (simCfg tm m extras c').input ∧ + (∀ j, Tape.StartInvariant ((simCfg tm m extras c').work j)) ∧ + (simCfg tm m extras c').input.cells = (simCfg tm m extras c).input.cells ∧ + (simCfg tm m extras c').input.head ≤ 1 + t ∧ + (∀ j, ((simCfg tm m extras c').work j).head ≤ 1 + t) := by + obtain ⟨hI, hW, -⟩ := TM.startInvariant_reachesIn (simTM tm m) hrun hInvI hInvW hInvO + obtain ⟨hbI, -, hbW⟩ := TM.head_le_start_add_of_reachesIn (simTM tm m) hrun + refine ⟨hI, hW, TM.reachesIn_input_cells (simTM tm m) hrun, ?_, fun j => ?_⟩ + · omega + · have := hbW j + have := hHeadW j + omega + + +/-- The stage's tapes at the simulation's own indices are the simulation's. -/ +theorem simCfg_work_middle (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (c : Cfg (k + 1) (simCore tm).Q) (i : Fin (k + 1)) + (j : Fin (0 + (k + 1) + m + 1)) (hj : j.val = i.val) : + (simCfg tm m extras c).work j = c.work i := by + have hlt : j.val < 0 + (k + 1) + m := by + have := i.isLt + omega + rw [show (simCfg tm m extras c).work j + = (TM.placeWorkCfg (simCore tm) 0 m extras c).work ⟨j.val, hlt⟩ from + TM.retargetCfg_work_lt _ _ j hlt] + rw [show (⟨j.val, hlt⟩ : Fin (0 + (k + 1) + m)) = TM.placeWorkIdx 0 m i from + Fin.ext (by show j.val = 0 + i.val; omega), TM.placeWorkCfg_work_middle] + +/-- The stage's tapes at the register indices are the registers, untouched. -/ +theorem simCfg_work_extra (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + (c : Cfg (k + 1) (simCore tm).Q) (j : Fin (0 + (k + 1) + m + 1)) + (hmid : ¬ (j.val < 0 + (k + 1))) (hlt : j.val < 0 + (k + 1) + m) : + (simCfg tm m extras c).work j = extras ⟨j.val, hlt⟩ := by + rw [show (simCfg tm m extras c).work j + = (TM.placeWorkCfg (simCore tm) 0 m extras c).work ⟨j.val, hlt⟩ from + TM.retargetCfg_work_lt _ _ j hlt] + exact TM.placeWorkCfg_work_extra _ _ _ _ _ _ (fun hcon => hmid hcon.2) + +/-- **The simulation leaves the counter's digits alone.** `choiceTM` writes every choice bit back +unchanged and only advances the head, so after the cleanup rewinds it the counter reads as `v` +again. -/ +theorem simCfg_counter_cells (tm : NTM k) (m : ℕ) (extras : Fin (0 + (k + 1) + m) → Tape) + {t : ℕ} {c c' : Cfg (k + 1) (simCore tm).Q} + (hreach : (simCore tm).reachesIn t c c') + (hinv : (c.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c.work (Fin.last k)).head) + (j : Fin (0 + (k + 1) + m + 1)) (hj : j.val = k) : + ((simCfg tm m extras c').work j).cells = ((simCfg tm m extras c).work j).cells := by + rw [simCfg_work_middle tm m extras c' (Fin.last k) j (by simpa using hj), + simCfg_work_middle tm m extras c (Fin.last k) j (by simpa using hj)] + exact (choiceTM_choiceCells (delayNTM tm) hinv hhead c' + (TM.reaches_of_reachesIn (TM.reachesIn_of_startedTM _ hreach))).1 + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPSubsetPSPACE.lean b/Complexitylib/Classes/Containments/Internal/PPSubsetPSPACE.lean new file mode 100644 index 00000000..c16b0852 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPSubsetPSPACE.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Randomized +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.Containments.Internal.PolyWindow +public import Complexitylib.Classes.Containments.Internal.PPParts +public import Complexitylib.Classes.Containments.Internal.PPTest +public import Complexitylib.Classes.Containments.Internal.PPBody +public import Complexitylib.Classes.Containments.Internal.PPSim +public import Complexitylib.Models.TuringMachine.Subroutines.ParkRewind +public import Complexitylib.Models.TuringMachine.Subroutines.WipeRewind +public import Complexitylib.Classes.Containments.Internal.PPLayout +public import Complexitylib.Classes.Containments.Internal.PPAssemble + +/-! +# `PP ⊆ PSPACE` — removing the rational threshold + +⚠️ Unreviewed by Bolton + +Membership in `PP` is stated as `acceptProb > 1/2`, a comparison of rationals. A machine has no +rationals; it has a counter. Since `acceptProb x T` is `acceptCount x T / 2 ^ T` by definition, +the threshold is equivalent to the integer comparison `2 ^ T < 2 · acceptCount x T`, and both +sides of that are things a machine can hold: the count needs `T + 1` bits and the choice +sequences it ranges over are `T` bits each. + +What remains for the containment is the enumeration itself — a counter over the `2 ^ T` choice +sequences, one simulation per sequence, and a running tally — with the space reused between +sequences. + +## Main results + +- `NTM.acceptProb_gt_half_iff` — the threshold as an integer comparison +- `PP_integer_characterization_internal` — `PP` with no rational arithmetic left in it +- `PP_subset_PSPACE_of_counter_internal` — the containment, modulo one machine +- `PP_subset_PSPACE_of_tallyMachine_internal` — the same, with the obligation reduced to a + machine deciding one arithmetic predicate +- `PP_subset_PSPACE_of_iterateMachine_internal` — and reduced further, to realising one iterated + step function +- `PP_subset_PSPACE_internal` — the containment itself +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +/-- **The `PP` threshold is an integer comparison.** More than half of the `2 ^ T` choice +sequences accept exactly when twice the accepting count exceeds `2 ^ T`. -/ +theorem acceptProb_gt_half_iff {k : ℕ} (tm : NTM k) (x : List Bool) (T : ℕ) : + tm.acceptProb x T > 1 / 2 ↔ 2 ^ T < 2 * tm.acceptCount x T := by + have hpos : (0 : ℚ) < 2 ^ T := by positivity + rw [NTM.acceptProb, gt_iff_lt, div_lt_div_iff₀ (by norm_num) hpos] + constructor + · intro h + have : ((2 ^ T : ℕ) : ℚ) < ((2 * tm.acceptCount x T : ℕ) : ℚ) := by push_cast; linarith + exact_mod_cast this + · intro h + have : ((2 ^ T : ℕ) : ℚ) < ((2 * tm.acceptCount x T : ℕ) : ℚ) := by exact_mod_cast h + push_cast at this + linarith + +end NTM + +/-- **`PP` with no rational arithmetic left.** A language of `PP` is decided by comparing twice +the number of accepting choice sequences against their total count — a comparison of two +naturals of polynomially many bits. -/ +theorem PP_integer_characterization_internal {L : Language} (hL : L ∈ PP) : + ∃ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ) (m : ℕ), + tm.AllPathsHaltIn f ∧ f =O (· ^ m) ∧ + ∀ x : List Bool, x ∈ L ↔ + 2 ^ f x.length < 2 * tm.acceptCount x (f x.length) := by + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, f, hhalt, hacc, hf⟩ := hm + exact ⟨k, tm, f, m, hhalt, hf, + fun x => (hacc x).trans (NTM.acceptProb_gt_half_iff tm x (f x.length))⟩ + + +/-- **`PP ⊆ PSPACE`, reduced to the existence of one machine.** For each probabilistic machine +and time bound, exhibit a deterministic machine that keeps a polynomial window and decides the +integer comparison `2 ^ T < 2 · acceptCount` — the rational threshold having already been +eliminated. No probability, and no asymptotics, survive in the obligation. -/ +theorem PP_subset_PSPACE_of_counter_internal + (h : ∀ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ), tm.AllPathsHaltIn f → (∃ m, f =O (· ^ m)) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + (2 ^ f x.length < 2 * tm.acceptCount x (f x.length) → + c'.output.cells 1 = Γ.one) ∧ + (¬ (2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) → + c'.output.cells 1 = Γ.zero))) : + PP ⊆ PSPACE := by + intro L hL + obtain ⟨k, tm, f, m, hhalt, hf, hchar⟩ := PP_integer_characterization_internal hL + obtain ⟨k', M, q, hwin, hdec⟩ := h k tm f hhalt ⟨m, hf⟩ + refine mem_PSPACE_of_polyWindow M q hwin fun x => ?_ + obtain ⟨c', hreach, hhalted, hone, hzero⟩ := hdec x + exact ⟨c', hreach, hhalted, fun hx => hone ((hchar x).mp hx), + fun hx => hzero fun hc => hx ((hchar x).mpr hc)⟩ + + +/-- **`PP ⊆ PSPACE`, reduced to a machine deciding one arithmetic predicate.** The obligation no +longer mentions probability, rationals, the function space `Fin T → Bool`, or the protocol's own +time function: exhibit a machine keeping a polynomial window that decides whether the accepting +tally exceeds the rejecting one over a computable horizon. -/ +theorem PP_subset_PSPACE_of_tallyMachine_internal + (h : ∀ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ) (p : Polynomial ℕ), + tm.AllPathsHaltIn f → (∀ n, f n ≤ p.eval n) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + ((NTM.tally (fun v => !NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length) < + NTM.tally (fun v => NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length)) → c'.output.cells 1 = Γ.one) ∧ + (¬ (NTM.tally (fun v => !NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length) < + NTM.tally (fun v => NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length)) → c'.output.cells 1 = Γ.zero))) : + PP ⊆ PSPACE := by + intro L hL + obtain ⟨k, tm, f, m, hall, hf, hchar⟩ := PP_integer_characterization_internal hL + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hf + obtain ⟨k', M, q, hwin, hdec⟩ := h k tm f p hall hp + refine mem_PSPACE_of_polyWindow M q hwin fun x => ?_ + obtain ⟨c', hr, hh, hone, hzero⟩ := hdec x + have hiff := NTM.mem_iff_tally_lt_tally_poly (L := L) hall hp hchar x + exact ⟨c', hr, hh, fun hx => hone (hiff.mp hx), fun hx => hzero fun hc => hx (hiff.mpr hc)⟩ + + +/-- **`PP ⊆ PSPACE`, reduced to realising one iterated step function.** The obligation is now as +small as it can be made without building the machine: exhibit a machine keeping a polynomial +window that decides whether, after `2 ^ p |x|` iterations of `NTM.tallyStep` from the zero state, +the accepting component exceeds the rejecting one. The machine's correctness proof therefore has +to reason only about a single loop body, not about counting. -/ +theorem PP_subset_PSPACE_of_iterateMachine_internal + (h : ∀ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ) (p : Polynomial ℕ), + tm.AllPathsHaltIn f → (∀ n, f n ≤ p.eval n) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + ((((NTM.tallyStep fun v => NTM.acceptsAt tm x (p.eval x.length) v)^[ + 2 ^ p.eval x.length] (0, 0, 0)).2.2 < + (((NTM.tallyStep fun v => NTM.acceptsAt tm x (p.eval x.length) v)^[ + 2 ^ p.eval x.length] (0, 0, 0)).2.1)) → c'.output.cells 1 = Γ.one) ∧ + (¬ (((NTM.tallyStep fun v => NTM.acceptsAt tm x (p.eval x.length) v)^[ + 2 ^ p.eval x.length] (0, 0, 0)).2.2 < + (((NTM.tallyStep fun v => NTM.acceptsAt tm x (p.eval x.length) v)^[ + 2 ^ p.eval x.length] (0, 0, 0)).2.1)) → c'.output.cells 1 = Γ.zero))) : + PP ⊆ PSPACE := by + intro L hL + obtain ⟨k, tm, f, m, hall, hf, hchar⟩ := PP_integer_characterization_internal hL + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hf + obtain ⟨k', M, q, hwin, hdec⟩ := h k tm f p hall hp + refine mem_PSPACE_of_polyWindow M q hwin fun x => ?_ + obtain ⟨c', hr, hh, hone, hzero⟩ := hdec x + have hiff := NTM.mem_iff_iterate_tallyStep (L := L) hall hp hchar x + exact ⟨c', hr, hh, fun hx => hone (hiff.mp hx), fun hx => hzero fun hc => hx (hiff.mpr hc)⟩ + +/-- **`PP ⊆ PSPACE`.** The obligation of `PP_subset_PSPACE_of_iterateMachine_internal` is met by +`NTM.ppMachine`: park, evaluate the horizon, then loop one simulation per counter value, keeping +two tallies, and compare them. A source machine that starts halted has no accepting path at all, +so that case is decided by `NTM.zeroTM`, which publishes `0` and stops. -/ +theorem PP_subset_PSPACE_internal : PP ⊆ PSPACE := by + refine PP_subset_PSPACE_of_iterateMachine_internal ?_ + intro k tm f p hall hle + by_cases heq : tm.qstart = tm.qhalt + · refine ⟨NTM.bodyTapes k, NTM.zeroTM k, NTM.zeroSpacePoly, + fun x c' hr => NTM.zeroTM_space k x c' hr, fun x => ?_⟩ + obtain ⟨c', hr, hh, hz⟩ := NTM.zeroTM_decides k x + exact ⟨c', hr, hh, fun hc => absurd hc (NTM.not_ppCond_of_qstart_eq_qhalt k tm heq p x), + fun _ => hz⟩ + · exact ⟨NTM.bodyTapes k, NTM.ppMachine k tm (p + 1), NTM.ppSpacePoly k (p + 1), + fun x c' hr => NTM.ppMachine_space k tm hall p hle heq x c' hr, + fun x => NTM.ppMachine_decides k tm hall p hle heq x⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PPTest.lean b/Complexitylib/Classes/Containments/Internal/PPTest.lean new file mode 100644 index 00000000..c9b95697 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PPTest.lean @@ -0,0 +1,462 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PPParts +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryEq +public import Complexitylib.Models.TuringMachine.Subroutines.ResetBinary +public import Complexitylib.Models.TuringMachine.Subroutines.RewindList +public import Complexitylib.Models.TuringMachine.Subroutines.WipeRewind +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SeqChain + +/-! +# The counting loop's test + +⚠️ Unreviewed by Bolton + +`TM.loopTM` stops when its test machine leaves `1` in the output tape's verdict cell. The +counting loop stops when its counter reaches the horizon, so its test compares the counter +against a register holding that horizon and publishes the answer. + +The comparison itself is `TM.binaryEqTM`, which deposits its verdict as a bit on a scratch work +tape and leaves the output alone; the remaining three stages move that bit where the loop can see +it. Two of them exist only because of where heads end up: `TM.binaryEqTM` leaves its operands' +heads wherever the scan stopped, and `TM.writeOutputBitTM` publishes whatever is *under* a head, +so the operands must be rewound before the verdict can be read off. + +## Main results + +- `TM.testTailTM` — rewind, publish the verdict, clear the scratch bit +- `TM.testTailTM_hoareTime` — its contract, through fully pinned tape states +- `TM.tallyTestTM`, `TM.tallyTestTM_hoareTime` — the whole test, leaving its bank as it found it +- `NTM.tallyTestTM_hoareTime_tallyPost` — the same contract in the shape + `NTM.tallyLoop_hoareTime_of_hoare` asks for +- `TM.Parked.write_ne_start` — a frame fact the assembly needs +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- The three tapes the comparison touches, in the order the rewind visits them. -/ +def testTargets (cIdx nIdx resIdx : Fin n) : List (Fin n) := [cIdx, nIdx, resIdx] + +/-- The work bank after every compared tape has been rewound to cell one. -/ +def rewoundBank (cIdx nIdx resIdx : Fin n) (W : Fin n → Tape) : Fin n → Tape := fun j => + if j ∈ testTargets cIdx nIdx resIdx then ⟨1, (W j).cells⟩ else W j + +/-- **The tail of the counting loop's test.** Rewind the compared tapes, publish the scratch +bit onto the output, then clear the scratch tape for the next iteration. -/ +def testTailTM (cIdx nIdx resIdx : Fin n) : TM n := + bigSeqTM [bigSeqTM ((testTargets cIdx nIdx resIdx).map rewindWorkTM), + writeOutputBitTM resIdx, resetBinaryWorkTM resIdx] + +theorem rewoundBank_parked {cIdx nIdx resIdx : Fin n} {W : Fin n → Tape} + (hW : ∀ j, Parked (W j)) (j : Fin n) : Parked (rewoundBank cIdx nIdx resIdx W j) := by + simp only [rewoundBank] + split + · exact ⟨le_refl 1, fun i hi => (hW j).2 i hi⟩ + · exact hW j + + +/-- Writing a non-marker symbol keeps a parked tape parked. -/ +theorem Parked.write_ne_start {t : Tape} (h : Parked t) {s : Γ} (hs : s ≠ Γ.start) : + Parked (t.write s) := by + refine ⟨by rw [Tape.write_head]; exact h.1, fun j hj => ?_⟩ + rw [Tape.write] + split + · exact h.2 j hj + · show Function.update t.cells t.head s j ≠ Γ.start + by_cases hjt : j = t.head + · rw [hjt, Function.update_self]; exact hs + · rw [Function.update_of_ne hjt]; exact h.2 j hj + +/-- **The contract of the test's tail.** From a bank in which the compared tapes carry their +markers and the scratch tape carries the verdict bit, the three stages land on a fully named bank +— every compared tape at cell one, the scratch tape blank — with the verdict on the output. -/ +theorem testTailTM_hoareTime (cIdx nIdx resIdx : Fin n) + (hd : BinaryEqDistinct cIdx nIdx resIdx) (b : Bool) (B : ℕ) (hB : 1 ≤ B) + (I : Tape) (W : Fin n → Tape) (O : Tape) + (hI : Parked I) (hO : Parked O) (hW : ∀ j, Parked (W j)) + (hstart : ∀ j, j ∈ testTargets cIdx nIdx resIdx → + (W j).cells 0 = Γ.start ∧ (W j).head ≤ B) + (hres : (W resIdx).cells 1 = Γ.ofBool b) + (hresBlank : ∀ i, 2 ≤ i → (W resIdx).cells i = Γ.blank) : + (testTailTM cIdx nIdx resIdx).HoareTime + (fun inp work out => inp = I ∧ work = W ∧ out = O) + (fun inp work out => inp = I ∧ + work = Function.update (rewoundBank cIdx nIdx resIdx W) resIdx + ((Tape.init ([] : List Γ)).move Dir3.right) ∧ + out = O.write (Γ.ofBool b)) + (3 * (max (3 * (B + 3) + 1) (resetBinaryWorkTime B 1) + 1) + 1) := by + have hnodup : (testTargets cIdx nIdx resIdx).Nodup := by + have h1 := hd.lhs_rhs + have h2 := hd.lhs_result + have h3 := hd.rhs_result + simp [testTargets, h1, h2, h3] + have hresMem : resIdx ∈ testTargets cIdx nIdx resIdx := by simp [testTargets] + set Wr := rewoundBank cIdx nIdx resIdx W with hWr + have hWrP : ∀ j, Parked (Wr j) := rewoundBank_parked hW + have hWrRes : Wr resIdx = ⟨1, (W resIdx).cells⟩ := by + simp only [hWr, rewoundBank, if_pos hresMem] + have hofb : Γ.ofBool b ≠ Γ.start := by cases b <;> simp [Γ.ofBool] + have hread : (Wr resIdx).read = Γ.ofBool b := by + rw [hWrRes]; show (W resIdx).cells 1 = _; exact hres + set Ow := O.write (Γ.ofBool b) with hOw + have hOwP : Parked Ow := hO.write_ne_start hofb + set Wf := Function.update Wr resIdx ((Tape.init ([] : List Γ)).move Dir3.right) with hWf + have hWfP : ∀ j, Parked (Wf j) := by + intro j + by_cases hj : j = resIdx + · rw [hj, hWf, Function.update_self] + refine ⟨le_refl 1, fun i hi => ?_⟩ + rw [Tape.move_cells] + show (if i = 0 then Γ.start else Γ.blank) ≠ Γ.start + rw [if_neg (by omega)] + simp + · rw [hWf, Function.update_of_ne hj]; exact hWrP j + set bnd := max (3 * (B + 3) + 1) (resetBinaryWorkTime B 1) with hbnd + refine (bigSeqTM_hoareTime_pinned + [bigSeqTM ((testTargets cIdx nIdx resIdx).map rewindWorkTM), + writeOutputBitTM resIdx, resetBinaryWorkTM resIdx] + I (fun k => if k = 0 then W else if k ≤ 2 then Wr else Wf) + (fun k => if k ≤ 1 then O else Ow) bnd hI ?_ ?_ ?_).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (le_refl _) + · intro k i + dsimp only + split + · exact hW i + · split + · exact hWrP i + · exact hWfP i + · intro k + dsimp only + split + · exact hO + · exact hOwP + · intro k hk + match k, hk with + | 0, _ => + show (bigSeqTM ((testTargets cIdx nIdx resIdx).map rewindWorkTM)).HoareTime _ _ _ + refine ((rewindList_hoareTime (testTargets cIdx nIdx resIdx) hnodup B I W O hI hO hW + hstart).strengthen_post ?_).mono_bound ?_ + · rintro inp work out ⟨rfl, rfl, hin, hout⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + by_cases hj : j ∈ testTargets cIdx nIdx resIdx + · rw [hin j hj]; show _ = Wr j; rw [hWr, rewoundBank, if_pos hj] + · rw [hout j hj]; show _ = Wr j; rw [hWr, rewoundBank, if_neg hj] + · show 3 * (B + 3) + 1 ≤ bnd + rw [hbnd] + exact le_max_left _ _ + | 1, _ => + show (writeOutputBitTM resIdx).HoareTime _ _ _ + refine ((writeOutputBitTM_hoareTime_frame resIdx I Wr O hI hWrP hO).strengthen_post + ?_).mono_bound (le_trans (by omega : (1 : ℕ) ≤ 3 * (B + 3) + 1) (le_max_left _ _)) + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨rfl, rfl, ?_⟩ + show _ = Ow + rw [hOw, hread, toΓ_readBackWrite_of_ne_start hofb] + | 2, _ => + show (resetBinaryWorkTM resIdx).HoareTime _ _ _ + refine ((resetBinaryWorkTM_hoareTime_frame resIdx [b] B I Wr Ow ?_ ?_ ?_ hI ?_ + hOwP).strengthen_post ?_).mono_bound (le_max_right _ _) + · refine ⟨fun i hi => ?_, fun i hi => ?_⟩ + · have : i = 0 := by simpa using hi + subst this + rw [hWrRes]; show (W resIdx).cells 1 = _; simpa using hres + · rw [hWrRes] + show (W resIdx).cells (i + 1) = _ + exact hresBlank (i + 1) (by simpa using hi) + · rw [hWrRes]; show (W resIdx).cells 0 = _; exact (hstart resIdx hresMem).1 + · rw [hWrRes]; exact ⟨le_refl 1, hB⟩ + · intro i _; exact hWrP i + · rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, rfl⟩ + + +/-- **The counting loop's test.** Compare the counter against the horizon register, then move +the verdict where `TM.loopTM` looks for it. -/ +def tallyTestTM (cIdx nIdx resIdx : Fin n) : TM n := + seqTM (binaryEqTM cIdx nIdx resIdx) (testTailTM cIdx nIdx resIdx) + +/-- **The test's contract.** The bank comes back exactly as it went in — the comparison is +non-destructive and the scratch tape is cleared — and the output gains the verdict bit. -/ +theorem tallyTestTM_hoareTime (cIdx nIdx resIdx : Fin n) + (hd : BinaryEqDistinct cIdx nIdx resIdx) (v N B : ℕ) + (I : Tape) (W : Fin n → Tape) (O : Tape) + (hI : Parked I) (hIz : I.cells 0 = Γ.start) + (hO : Parked O) (hOz : O.cells 0 = Γ.start) + (hW : ∀ j, Parked (W j)) (hWz : ∀ j, (W j).cells 0 = Γ.start) + (hc : W cIdx = natTape v) (hnn : W nIdx = natTape N) + (hres : W resIdx = (Tape.init ([] : List Γ)).move Dir3.right) + (hB : ∀ j, (W j).head + binaryEqTime v.bits N.bits ≤ B) : + (tallyTestTM cIdx nIdx resIdx).HoareTime + (fun inp work out => inp = I ∧ work = W ∧ out = O) + (fun inp work out => inp = I ∧ work = W ∧ + out = O.write (Γ.ofBool (decide (v = N)))) + (binaryEqTime v.bits N.bits + 1 + + (3 * (max (3 * (B + 3) + 1) (resetBinaryWorkTime B 1) + 1) + 1)) := by + have hB1 : 1 ≤ B := le_trans (hW cIdx).1 (le_trans (Nat.le_add_right _ _) (hB cIdx)) + have hSI : ∀ j, (W j).StartInvariant := fun j => ⟨hWz j, fun i hi => (hW j).2 i hi⟩ + have hbits : (decide (v.bits = N.bits)) = decide (v = N) := by + by_cases h : v = N + · simp [h] + · simp only [h, decide_false, decide_eq_false_iff_not] + exact fun hcon => h (bits_injective hcon) + set mid : TapePred n := fun inp work out => inp = I ∧ out = O ∧ + (∀ j, Parked (work j)) ∧ (∀ j, (work j).cells 0 = Γ.start) ∧ + (∀ j, (work j).head ≤ B) ∧ + (work cIdx).HasBinaryContent v.bits ∧ (work nIdx).HasBinaryContent N.bits ∧ + (work resIdx).cells 1 = Γ.ofBool (decide (v = N)) ∧ + (∀ i, 2 ≤ i → (work resIdx).cells i = Γ.blank) ∧ + (∀ j, j ≠ cIdx → j ≠ nIdx → j ≠ resIdx → work j = W j) with hmid + -- The comparison itself. + have hstep1 : (binaryEqTM cIdx nIdx resIdx).HoareTime + (fun inp work out => inp = I ∧ work = W ∧ out = O) mid + (binaryEqTime v.bits N.bits) := by + intro inp work out hpre + obtain ⟨hEi, hEw, hEo⟩ := hpre + rw [hEi, hEw, hEo] + have hlhs : (W cIdx).HasBinaryString v.bits := by + rw [hc]; exact (Tape.init_move_right_hasBinaryNat v).2 + have hrhs : (W nIdx).HasBinaryString N.bits := by + rw [hnn]; exact (Tape.init_move_right_hasBinaryNat N).2 + have hprefix : (W resIdx).HasBinaryPrefix [] := by + refine ⟨by rw [hres]; rfl, nofun, fun i _ => ?_⟩ + rw [hres, Tape.move_cells] + show (if i + 1 = 0 then Γ.start else Γ.blank) = Γ.blank + rw [if_neg (by omega)] + obtain ⟨c', t, ht, hreach, hhalt, hinp', hres', hlhs', hlhsh, hrhs', hrhsh, hother', + hout'⟩ := + binaryEqTM_reachesIn_frame cIdx nIdx resIdx hd v.bits N.bits I W O hlhs hrhs hprefix + hI.read_ne_start (fun i _ _ _ => (hW i).read_ne_start) hO.read_ne_start + obtain ⟨-, hSI', -⟩ := startInvariant_reachesIn _ hreach ⟨hIz, fun i hi => hI.2 i hi⟩ hSI + ⟨hOz, fun i hi => hO.2 i hi⟩ + obtain ⟨-, -, hheads⟩ := head_le_start_add_of_reachesIn _ hreach + have hheadB : ∀ j, (c'.work j).head ≤ B := by + intro j + have h1 : (c'.work j).head ≤ (W j).head + t := hheads j + have h2 := hB j + omega + have hge1 : ∀ j, 1 ≤ (c'.work j).head := by + intro j + by_cases hj : j = cIdx + · subst hj; exact hlhsh + · by_cases hj2 : j = nIdx + · subst hj2; exact hrhsh + · by_cases hj3 : j = resIdx + · subst hj3; rw [hres'.1]; omega + · rw [hother' j hj hj2 hj3]; exact (hW j).1 + refine ⟨c', t, ht, hreach, hhalt, ?_⟩ + refine ⟨hinp', hout', fun j => ⟨hge1 j, fun i hi => (hSI' j).2 i hi⟩, + fun j => (hSI' j).1, hheadB, hlhs', hrhs', ?_, ?_, fun j h1 h2 h3 => hother' j h1 h2 h3⟩ + · have hz := hres'.2.1 0 (by simp) + simpa [hbits] using hz + · intro i hi + obtain ⟨k, rfl⟩ : ∃ k, i = k + 1 := ⟨i - 1, by omega⟩ + exact hres'.2.2 k (by simpa using hi) + -- Phase transitions do not disturb parked tapes. + have htrans : ∀ inp work out, mid inp work out → + mid (transitionInput inp) (fun i => transitionTape (work i)) (transitionTape out) := by + intro inp work out h + obtain ⟨hEi, hEo, hp, hz, hh, h1, h2, h3, h4, h5⟩ := h + have heq : ∀ j, transitionTape (work j) = work j := + fun j => transitionTape_eq_self (hp j).read_ne_start + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hEi]; exact transitionInput_eq_self hI.read_ne_start + · rw [hEo]; exact transitionTape_eq_self hO.read_ne_start + · intro j; show Parked (transitionTape (work j)); rw [heq j]; exact hp j + · intro j; show (transitionTape (work j)).cells 0 = _; rw [heq j]; exact hz j + · intro j; show (transitionTape (work j)).head ≤ _; rw [heq j]; exact hh j + · show (transitionTape (work cIdx)).HasBinaryContent _; rw [heq cIdx]; exact h1 + · show (transitionTape (work nIdx)).HasBinaryContent _; rw [heq nIdx]; exact h2 + · show (transitionTape (work resIdx)).cells 1 = _; rw [heq resIdx]; exact h3 + · intro i hi; show (transitionTape (work resIdx)).cells i = _; rw [heq resIdx] + exact h4 i hi + · intro j a b c; show transitionTape (work j) = _; rw [heq j]; exact h5 j a b c + -- The tail, applied at the unpinned bank the comparison produced. + have hstep2 : (testTailTM cIdx nIdx resIdx).HoareTime mid + (fun inp work out => inp = I ∧ work = W ∧ + out = O.write (Γ.ofBool (decide (v = N)))) + (3 * (max (3 * (B + 3) + 1) (resetBinaryWorkTime B 1) + 1) + 1) := by + intro inp work out h + obtain ⟨hEi, hEo, hp, hz, hh, h1, h2, h3, h4, h5⟩ := h + rw [hEi, hEo] + refine (testTailTM_hoareTime cIdx nIdx resIdx hd (decide (v = N)) B hB1 I work O hI hO hp + (fun j _ => ⟨hz j, hh j⟩) h3 h4).strengthen_post + (post' := fun inp work out => inp = I ∧ work = W ∧ + out = O.write (Γ.ofBool (decide (v = N)))) ?_ I work O ⟨rfl, rfl, rfl⟩ + rintro inp' work' out' ⟨rfl, hwf, rfl⟩ + refine ⟨rfl, ?_, rfl⟩ + rw [hwf] + funext j + by_cases hj : j = resIdx + · subst hj + rw [Function.update_self, hres] + rw [Function.update_of_ne hj] + by_cases hj1 : j = cIdx + · subst hj1 + have hmem : j ∈ testTargets j nIdx resIdx := by simp [testTargets] + rw [rewoundBank, if_pos hmem, hc] + have hbn : (⟨1, (work j).cells⟩ : Tape).HasBinaryNat v := ⟨hz j, rfl, h1.1, h1.2⟩ + simpa [natTape] using hbn.eq_init_move_right + by_cases hj2 : j = nIdx + · subst hj2 + have hmem : j ∈ testTargets cIdx j resIdx := by simp [testTargets] + rw [rewoundBank, if_pos hmem, hnn] + have hbn : (⟨1, (work j).cells⟩ : Tape).HasBinaryNat N := ⟨hz j, rfl, h2.1, h2.2⟩ + simpa [natTape] using hbn.eq_init_move_right + have hmem : j ∉ testTargets cIdx nIdx resIdx := by + simp only [testTargets, List.mem_cons, List.not_mem_nil, or_false] + exact fun h => h.elim hj1 (fun h => h.elim hj2 hj) + rw [rewoundBank, if_neg hmem] + exact h5 j hj1 hj2 hj + exact seqTM_hoareTime _ _ hstep1 htrans hstep2 + +end TM + +namespace NTM + +variable {n : ℕ} + +/-- **Writing into the verdict slot replaces its symbol.** The slot's head never leaves cell one, +so a write lands exactly on the cell `TM.loopTM` inspects. -/ +theorem outSlot_write (s s' : Γw) : (outSlot s).write s'.toΓ = outSlot s' := by + refine Tape.ext ?_ ?_ + · rw [Tape.write_head] + rfl + · funext j + rw [Tape.write, if_neg (show ¬ ((outSlot s).head = 0) from by + show ¬ ((1 : ℕ) = 0); omega)] + show Function.update (outSlot s).cells 1 s'.toΓ j = _ + by_cases hj : j = 1 + · subst hj + rw [Function.update_self] + simp [outSlot] + · rw [Function.update_of_ne hj] + simp [outSlot, hj] + +/-- Writing the verdict into a blank slot produces the slot holding that verdict. -/ +theorem outSlot_blank_write (b : Bool) : + (outSlot Γw.blank).write (Γ.ofBool b) = outSlot (if b then Γw.one else Γw.zero) := by + have h : Γ.ofBool b = (if b then Γw.one else Γw.zero).toΓ := by + cases b <;> simp [Γ.ofBool, Γw.toΓ] + rw [h, outSlot_write] + +/-- The blank verdict slot is the blank tape — the same object under two names, which is what +lets the wipe's precondition and the loop's invariant meet. -/ +theorem outSlot_blank_eq_blankTape : outSlot Γw.blank = TM.blankTape := by + refine Tape.ext rfl (funext fun j => ?_) + show (if j = 0 then Γ.start else if j = 1 then Γw.blank.toΓ else Γ.blank) + = ((Tape.init ([] : List Γ)).move Dir3.right).cells j + rw [Tape.move_cells] + by_cases hj : j = 0 + · rw [hj, if_pos rfl, Tape.init_cells_zero] + · rw [if_neg hj, show j = (j - 1) + 1 from by omega, Tape.init_nil_cells_succ] + split <;> rfl + +/-- Reading a cell back as a writable symbol turns it into `1` exactly when it was `1`. -/ +theorem readBackWrite_eq_one_iff (s : Γ) : TM.readBackWrite s = Γw.one ↔ s = Γ.one := by + cases s <;> simp [TM.readBackWrite] + +/-- **The body's publishing stage.** With the verdict tape rewound to cell one, its symbol is +copied into the output slot, where `TM.ifTM` can branch on it. -/ +theorem publish_hoareTime {n : ℕ} (idx : Fin n) (I : Tape) (W : Fin n → Tape) + (hI : TM.Parked I) (hW : ∀ j, TM.Parked (W j)) (hv : (W idx).head = 1) : + (TM.writeOutputBitTM idx).HoareTime + (fun inp work out => inp = I ∧ work = W ∧ out = TM.blankTape) + (fun inp work out => inp = I ∧ work = W ∧ + out = outSlot (TM.readBackWrite ((W idx).cells 1))) + 1 := by + have hblank : TM.Parked TM.blankTape := TM.blankTape_parked + have hread : (W idx).read = (W idx).cells 1 := by + show (W idx).cells ((W idx).head) = _ + rw [hv] + refine (TM.writeOutputBitTM_hoareTime_frame idx I W TM.blankTape hI hW hblank).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, hw, ?_⟩ + rw [ho, hread, ← outSlot_blank_eq_blankTape] + exact outSlot_write Γw.blank (TM.readBackWrite ((W idx).cells 1)) + +/-- The marker sits at cell zero of a counter tape. -/ +theorem natTape_cells_zero (v : ℕ) : (natTape v).cells 0 = Γ.start := by + rw [natTape, Tape.move_cells] + exact (Tape.init_move_right_hasBinaryNat v).1 + +/-- **The counting loop's test meets its obligation.** With the horizon parked on `nIdx` and a +blank scratch tape on `resIdx`, `TM.tallyTestTM` carries the state the body leaves — the bank at +index `w` and a blank verdict slot — to `NTM.tallyPost` at that index. -/ +theorem tallyTestTM_hoareTime_tallyPost (cIdx aIdx rIdx nIdx resIdx : Fin n) + (hd : TM.BinaryEqDistinct cIdx nIdx resIdx) + (hnc : nIdx ≠ cIdx) (hna : nIdx ≠ aIdx) (hnr : nIdx ≠ rIdx) + (hsc : resIdx ≠ cIdx) (hsa : resIdx ≠ aIdx) (hsr : resIdx ≠ rIdx) + (I : Tape) (rest : Fin n → Tape) (P : ℕ → Bool) (N w B Hr : ℕ) + (hI : TM.Parked I) (hIz : I.cells 0 = Γ.start) + (hrest : ∀ j, TM.Parked (rest j)) (hrestz : ∀ j, (rest j).cells 0 = Γ.start) + (hresth : ∀ j, (rest j).head ≤ Hr) + (hn : rest nIdx = natTape N) + (hr : rest resIdx = (Tape.init ([] : List Γ)).move Dir3.right) + (hB : Hr + 1 + TM.binaryEqTime w.bits N.bits ≤ B) : + (TM.tallyTestTM cIdx nIdx resIdx).HoareTime + (fun inp work out => inp = I ∧ + work = tallyWork cIdx aIdx rIdx rest (w, tally P w, tally (fun u => !P u) w) ∧ + out = outSlot Γw.blank) + (tallyPost cIdx aIdx rIdx I rest P N w) + (TM.binaryEqTime w.bits N.bits + 1 + + (3 * (max (3 * (B + 3) + 1) (TM.resetBinaryWorkTime B 1) + 1) + 1)) := by + set W := tallyWork cIdx aIdx rIdx rest (w, tally P w, tally (fun u => !P u) w) with hW + have hWc : W cIdx = natTape w := by rw [hW]; simp [tallyWork] + have hWn : W nIdx = natTape N := by + rw [hW] + simp only [tallyWork, if_neg hnc, if_neg hna, if_neg hnr] + exact hn + have hWr : W resIdx = (Tape.init ([] : List Γ)).move Dir3.right := by + rw [hW] + simp only [tallyWork, if_neg hsc, if_neg hsa, if_neg hsr] + exact hr + have hcases : ∀ j, W j = natTape w ∨ W j = natTape (tally P w) ∨ + W j = natTape (tally (fun u => !P u) w) ∨ W j = rest j := by + intro j + rw [hW] + simp only [tallyWork] + split + · exact Or.inl rfl + · split + · exact Or.inr (Or.inl rfl) + · split + · exact Or.inr (Or.inr (Or.inl rfl)) + · exact Or.inr (Or.inr (Or.inr rfl)) + have hWP : ∀ j, TM.Parked (W j) := by + intro j + rcases hcases j with h | h | h | h <;> rw [h] + exacts [natTape_parked _, natTape_parked _, natTape_parked _, hrest j] + have hWz : ∀ j, (W j).cells 0 = Γ.start := by + intro j + rcases hcases j with h | h | h | h <;> rw [h] + exacts [natTape_cells_zero _, natTape_cells_zero _, natTape_cells_zero _, hrestz j] + have hWh : ∀ j, (W j).head + TM.binaryEqTime w.bits N.bits ≤ B := by + intro j + have hj : (W j).head ≤ Hr + 1 := by + rcases hcases j with h | h | h | h + · rw [h]; show 1 ≤ Hr + 1; omega + · rw [h]; show 1 ≤ Hr + 1; omega + · rw [h]; show 1 ≤ Hr + 1; omega + · rw [h]; have := hresth j; omega + omega + refine (TM.tallyTestTM_hoareTime cIdx nIdx resIdx hd w N B I W (outSlot Γw.blank) + hI hIz (outSlot_parked _) rfl hWP hWz hWc hWn hWr hWh).strengthen_post ?_ + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨rfl, rfl, ?_⟩ + rw [outSlot_blank_write] + congr 1 + by_cases h : w = N <;> simp [h] + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PSPACESubsetEXP.lean b/Complexitylib/Classes/Containments/Internal/PSPACESubsetEXP.lean new file mode 100644 index 00000000..2bd5018d --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PSPACESubsetEXP.lean @@ -0,0 +1,268 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.Exponential +public import Complexitylib.Classes.Containments.Internal.ConfigCount +public import Complexitylib.Classes.P.Cobham.Internal.Simulate + +/-! +# `PSPACE ⊆ EXP` — proof internals + +⚠️ Unreviewed by Bolton + +A space-bounded machine has only exponentially many configurations, and a deterministic run +visits each at most once before halting, so its halting time is bounded by that count. The +machine is unchanged: only the time bound is new. + +The counting needs one invariant the space predicate does not state. `Cfg.WithinDecisionSpace` +bounds head *positions*, not tape *contents*; but a head that never leaves `[0, S]` can never +write outside it, so every cell beyond the window still holds its initial blank. `Windowed` +records that, and `Windowed.step` propagates it. +-/ + +@[expose] public section + +namespace Complexity + +variable {k : ℕ} {tm : TM k} + +/-- A step of a machine whose heads stay inside the window preserves the invariant. -/ +theorem Windowed.step {x : List Bool} {S : ℕ} {c c' : Cfg k tm.Q} + (hw : Windowed x S c) (hstep : tm.step c = some c') + (hspace : c.WithinDecisionSpace x.length S) : + Windowed x S c' := by + rw [TM.step, if_neg (TM.state_ne_qhalt_of_step hstep)] at hstep + injection hstep with hstep + subst hstep + refine ⟨?_, ?_, ?_⟩ + · show (c.input.move _).cells = _ + cases (tm.δ c.state c.input.read (fun i => (c.work i).read) c.output.read).2.2.2.1 <;> + exact hw.input + · intro i p hp + have hhead : (c.work i).head ≤ S := hspace.1.1 i + show ((c.work i).writeAndMove _ _).cells p = Γ.blank + rw [cells_writeAndMove_of_ne _ _ _ (by omega)] + exact hw.work i p hp + · intro p hp + have hhead : c.output.head ≤ S + 1 := hspace.2 + show (c.output.writeAndMove _ _).cells p = Γ.blank + rw [cells_writeAndMove_of_ne _ _ _ (by omega)] + exact hw.output p hp + +namespace TM + +/-! ## Counting the configurations inside the window -/ + +/-! ## A halting deterministic run is short + +The deterministic iteration `TM.runCfg` and its algebra come from +`Complexitylib.Classes.P.Cobham.Internal.Simulate`, where the Cobham simulation already needed +them. -/ + +/-- Every configuration of a run is reachable. -/ +theorem reaches_runCfg (tm : TM k) (c : Cfg k tm.Q) : ∀ n, tm.reaches c (TM.runCfg tm c n) + | 0 => Relation.ReflTransGen.refl + | n + 1 => by + rw [TM.runCfg_succ] + cases hs : tm.step (TM.runCfg tm c n) with + | none => simpa using reaches_runCfg tm c n + | some c' => + simp only [Option.getD_some] + exact Relation.ReflTransGen.tail (reaches_runCfg tm c n) hs + +/-- Once a configuration repeats, the run is periodic from that point on. -/ +theorem runCfg_periodic (tm : TM k) (c₀ : Cfg k tm.Q) {i d : ℕ} + (h : TM.runCfg tm c₀ i = TM.runCfg tm c₀ (i + d)) (r : ℕ) : + TM.runCfg tm c₀ (i + r) = TM.runCfg tm c₀ (i + d + r) := by + rw [TM.runCfg_add, TM.runCfg_add, h] + +/-- A repeat before the first halt is impossible: periodicity would pull a halted +configuration back before time `t`. -/ +theorem repeat_contradiction (tm : TM k) (c₀ : Cfg k tm.Q) {t : ℕ} + (hmin : ∀ s, s < t → ¬ tm.halted (TM.runCfg tm c₀ s)) + (hhalt : tm.halted (TM.runCfg tm c₀ t)) {a b : ℕ} (hb : b ≤ t) (hlt : a < b) + (hab : TM.runCfg tm c₀ a = TM.runCfg tm c₀ b) : False := by + have hd : b = a + (b - a) := by omega + have hper := runCfg_periodic tm c₀ (d := b - a) (by rw [← hd]; exact hab) (t - b) + have h1 : a + (t - b) < t := by omega + have h2 : a + (b - a) + (t - b) = t := by omega + rw [h2] at hper + exact hmin _ h1 (hper ▸ hhalt) + +/-- Before the first halt, the configurations of a deterministic run are pairwise distinct. -/ +theorem runCfg_injective_before_halt (tm : TM k) (c₀ : Cfg k tm.Q) {t : ℕ} + (hmin : ∀ s, s < t → ¬ tm.halted (TM.runCfg tm c₀ s)) + (hhalt : tm.halted (TM.runCfg tm c₀ t)) : + Function.Injective fun i : Fin (t + 1) => TM.runCfg tm c₀ i.val := by + intro a b hab + have ha := a.isLt + have hb := b.isLt + by_contra hne + have hne' : a.val ≠ b.val := fun h => hne (Fin.ext h) + rcases Nat.lt_or_ge a.val b.val with hlt | hge + · exact repeat_contradiction tm c₀ hmin hhalt (by omega) hlt hab + · exact repeat_contradiction tm c₀ hmin hhalt (by omega) (by omega) hab.symm + +/-! ## From a space bound to a time bound -/ + +/-- Reachability gives a step count. -/ +theorem exists_reachesIn {tm : TM k} {c c' : Cfg k tm.Q} (h : tm.reaches c c') : + ∃ t, tm.reachesIn t c c' := by + induction h with + | refl => exact ⟨0, TM.reachesIn.zero⟩ + | tail _ hstep ih => + obtain ⟨t, ht⟩ := ih + exact ⟨t + 1, tm.reachesIn_snoc ht hstep⟩ + +/-- Before the first halt, the run is a genuine `reachesIn` run. -/ +theorem reachesIn_runCfg (tm : TM k) (c : Cfg k tm.Q) : + ∀ t, (∀ s, s < t → ¬ tm.halted (TM.runCfg tm c s)) → tm.reachesIn t c (TM.runCfg tm c t) + | 0, _ => TM.reachesIn.zero + | t + 1, hmin => by + have hprev := reachesIn_runCfg tm c t fun s hs => hmin s (by omega) + have hnh : ¬ tm.halted (TM.runCfg tm c t) := hmin t (by omega) + rw [TM.runCfg_succ] + cases hs : tm.step (TM.runCfg tm c t) with + | none => exact absurd (TM.step_eq_none_iff_halted.mp hs) hnh + | some c'' => + simp only [Option.getD_some] + exact tm.reachesIn_snoc hprev hs + +/-- Every configuration of a run from the initial configuration is windowed. -/ +theorem windowed_runCfg {tm : TM k} {L : Language} {f : ℕ → ℕ} + (hdec : tm.DecidesInSpace L f) (x : List Bool) : + ∀ n, Windowed x (f x.length) (TM.runCfg tm (tm.initCfg x) n) + | 0 => windowed_init tm.qstart x (f x.length) + | n + 1 => by + have hprev := windowed_runCfg hdec x n + have hspace := hdec.1 x _ (reaches_runCfg tm (tm.initCfg x) n) + rw [TM.runCfg_succ] + cases hs : tm.step (TM.runCfg tm (tm.initCfg x) n) with + | none => simpa using hprev + | some c'' => + simp only [Option.getD_some] + exact hprev.step hs hspace + +/-- The exponential configuration bound of a space-`f` machine. -/ +def spaceTimeBound (tm : TM k) (f : ℕ → ℕ) (n : ℕ) : ℕ := + Fintype.card tm.Q * + ((n + f n + 2) * (((f n + 1) * 4 ^ (f n + 1)) ^ k * ((f n + 2) * 4 ^ (f n + 2)))) + +/-- **A space-bounded machine halts within its configuration count.** -/ +theorem halt_time_le {tm : TM k} {L : Language} {f : ℕ → ℕ} + (hdec : tm.DecidesInSpace L f) (x : List Bool) {t : ℕ} + (hmin : ∀ s, s < t → ¬ tm.halted (TM.runCfg tm (tm.initCfg x) s)) + (hhalt : tm.halted (TM.runCfg tm (tm.initCfg x) t)) : + t < spaceTimeBound tm f x.length := by + have hinj : Function.Injective + fun i : Fin (t + 1) => + cfgCode x.length (f x.length) (TM.runCfg tm (tm.initCfg x) i.val) := by + intro a b hab + refine runCfg_injective_before_halt tm (tm.initCfg x) hmin hhalt ?_ + exact cfgCode_inj (windowed_runCfg hdec x a.val) + (hdec.1 x _ (reaches_runCfg tm (tm.initCfg x) a.val)) + (windowed_runCfg hdec x b.val) + (hdec.1 x _ (reaches_runCfg tm (tm.initCfg x) b.val)) hab + have hcard := Fintype.card_le_of_injective _ hinj + rw [Fintype.card_fin, card_Code] at hcard + exact hcard + +/-- The configuration count is at most exponential in the space bound. -/ +theorem spaceTimeBound_le_two_pow (tm : TM k) (f : ℕ → ℕ) (n : ℕ) : + spaceTimeBound tm f n + ≤ 2 ^ (Fintype.card tm.Q + (n + f n + 2) + 3 * k * (f n + 1) + 3 * (f n + 2)) := by + have h : spaceTimeBound tm f n = Fintype.card (Code tm.Q k n (f n)) := + (card_Code tm.Q k n (f n)).symm + rw [h] + exact card_Code_le_two_pow tm.Q k n (f n) + +/-- A polynomial dominating the exponent of the configuration count. -/ +noncomputable def boundExp (tm : TM k) (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C (Fintype.card tm.Q) + (Polynomial.X + p + Polynomial.C 2) + + Polynomial.C (3 * k) * (p + 1) + Polynomial.C 3 * (p + Polynomial.C 2) + +/-- The configuration count is at most `2` to a polynomial. -/ +theorem spaceTimeBound_le_two_pow_poly (tm : TM k) (f : ℕ → ℕ) (p : Polynomial ℕ) + (hf : ∀ n, f n ≤ p.eval n) (n : ℕ) : + spaceTimeBound tm f n ≤ 2 ^ (boundExp tm p).eval n := by + refine le_trans (spaceTimeBound_le_two_pow tm f n) (Nat.pow_le_pow_right (by norm_num) ?_) + have h := hf n + simp only [boundExp, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, Polynomial.eval_one] + exact Nat.add_le_add (Nat.add_le_add (Nat.add_le_add (le_refl _) (by omega)) + (Nat.mul_le_mul_left _ (by omega))) (Nat.mul_le_mul_left _ (by omega)) + +/-! ## The time bound -/ + +open Classical in +/-- **A space-bounded decider is a time-bounded decider**, with no change of machine: the run +halts by the time it would have to repeat a configuration. -/ +theorem decidesInTime_of_decidesInSpace {tm : TM k} {L : Language} {f : ℕ → ℕ} + (hdec : tm.DecidesInSpace L f) : tm.DecidesInTime L (spaceTimeBound tm f) := by + intro x + obtain ⟨c', hreach, hhalted, hone, hzero⟩ := hdec.2 x + obtain ⟨t₀, ht₀⟩ := exists_reachesIn hreach + have hrun₀ : TM.runCfg tm (tm.initCfg x) t₀ = c' := TM.runCfg_of_reachesIn tm ht₀ + have hex : ∃ m, tm.halted (TM.runCfg tm (tm.initCfg x) m) := ⟨t₀, by rw [hrun₀]; exact hhalted⟩ + set t := Nat.find hex with hts + have hhalt : tm.halted (TM.runCfg tm (tm.initCfg x) t) := Nat.find_spec hex + have hmin : ∀ s, s < t → ¬ tm.halted (TM.runCfg tm (tm.initCfg x) s) := + fun s hs => Nat.find_min hex hs + have hle : t ≤ t₀ := Nat.find_le (by rw [hrun₀]; exact hhalted) + have hfreeze : TM.runCfg tm (tm.initCfg x) t = c' := by + rw [← hrun₀, show t₀ = t + (t₀ - t) from by omega, TM.runCfg_add, + TM.runCfg_of_halted tm hhalt] + refine ⟨TM.runCfg tm (tm.initCfg x) t, t, (halt_time_le hdec x hmin hhalt).le, ?_, hhalt, ?_, ?_⟩ + · exact reachesIn_runCfg tm (tm.initCfg x) t hmin + · rw [hfreeze]; exact hone + · rw [hfreeze]; exact hzero + +/-- A polynomial is eventually dominated by the next power. -/ +theorem eval_le_pow_succ (q : Polynomial ℕ) : + ∃ N, ∀ n, N ≤ n → q.eval n ≤ n ^ (q.natDegree + 1) := by + refine ⟨max (∑ i ∈ Finset.range (q.natDegree + 1), q.coeff i) 1, fun n hn => ?_⟩ + have hn1 : 1 ≤ n := le_trans (le_max_right _ _) hn + have hnS : (∑ i ∈ Finset.range (q.natDegree + 1), q.coeff i) ≤ n := + le_trans (le_max_left _ _) hn + have h1 : q.eval n ≤ (∑ i ∈ Finset.range (q.natDegree + 1), q.coeff i) * n ^ q.natDegree := by + rw [Polynomial.eval_eq_sum_range, Finset.sum_mul] + refine Finset.sum_le_sum fun i hi => ?_ + have hi' : i ≤ q.natDegree := by rw [Finset.mem_range] at hi; omega + exact Nat.mul_le_mul_left _ (Nat.pow_le_pow_right hn1 hi') + calc q.eval n ≤ (∑ i ∈ Finset.range (q.natDegree + 1), q.coeff i) * n ^ q.natDegree := h1 + _ ≤ n * n ^ q.natDegree := Nat.mul_le_mul_right _ hnS + _ = n ^ (q.natDegree + 1) := by rw [pow_succ]; ring + +/-- **The configuration count is exponential.** -/ +theorem spaceTimeBound_bigO {tm : TM k} {f : ℕ → ℕ} {m : ℕ} (hf : f =O (· ^ m)) : + ∃ j, spaceTimeBound tm f =O (fun n => 2 ^ n ^ j) := by + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hf + obtain ⟨N, hN⟩ := eval_le_pow_succ (boundExp tm p) + refine ⟨(boundExp tm p).natDegree + 1, ?_⟩ + rw [BigO] + apply Asymptotics.IsBigO.of_bound 1 + filter_upwards [Filter.eventually_ge_atTop N] with n hn + simp only [Real.norm_natCast, one_mul] + have h1 : spaceTimeBound tm f n ≤ 2 ^ (boundExp tm p).eval n := + spaceTimeBound_le_two_pow_poly tm f p hp n + have h2 : (2 : ℕ) ^ (boundExp tm p).eval n ≤ 2 ^ n ^ ((boundExp tm p).natDegree + 1) := + Nat.pow_le_pow_right (by norm_num) (hN n hn) + exact_mod_cast le_trans h1 h2 + +end TM + +/-- **`PSPACE ⊆ EXP`.** A polynomial-space decider halts within its configuration count, which +is exponential, so the same machine is an exponential-time decider. -/ +theorem PSPACE_subset_EXP_internal : PSPACE ⊆ EXP := by + intro L hL + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, f, hdec, hbig⟩ := hm + obtain ⟨j, hO⟩ := TM.spaceTimeBound_bigO (tm := tm) hbig + exact Set.mem_iUnion.mpr + ⟨j, k, tm, TM.spaceTimeBound tm f, TM.decidesInTime_of_decidesInSpace hdec, hO⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PolyWindow.lean b/Complexitylib/Classes/Containments/Internal/PolyWindow.lean new file mode 100644 index 00000000..2198c0f6 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PolyWindow.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Defs + +/-! +# Class membership as an explicit polynomial bound + +⚠️ Unreviewed by Bolton + +Membership in `PSPACE` is stated asymptotically: some space function that is `O(n^k)`. A machine +under construction needs the opposite — a concrete polynomial it can be checked against, and a +way to hand that polynomial back as a `PSPACE` membership when it is done. The two theorems here +are that exchange, in both directions, and every space-bounded construction in this folder passes +through them. + +## Main results + +- `exists_poly_window_of_mem_PSPACE` — a `PSPACE` language with an explicit polynomial window +- `mem_PSPACE_of_polyWindow` — and the converse +- `mem_P_of_polyTime` — the time-domain counterpart, for `P` +-/ + +@[expose] public section + +namespace Complexity + +/-- **A `PSPACE` language comes with an explicit polynomial window.** Membership in `PSPACE` only +gives an asymptotic bound on some space function; a machine has to be handed a concrete +polynomial, since the window it must respect is a function of the input length it can evaluate. -/ +theorem exists_poly_window_of_mem_PSPACE {L : Language} (h : L ∈ PSPACE) : + ∃ (k : ℕ) (tm : TM k) (q : Polynomial ℕ), + (∀ x : List Bool, ∀ c', tm.reaches (tm.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L → c'.output.cells 1 = Γ.one) ∧ + (x ∉ L → c'.output.cells 1 = Γ.zero)) := by + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp h + obtain ⟨k, tm, f, hdec, hf⟩ := hm + obtain ⟨q, hq⟩ := BigO.pow_polynomial_bound hf + refine ⟨k, tm, q, fun x c' hreach => ?_, hdec.2⟩ + have hb := hdec.1 x c' hreach + have hle := hq x.length + exact ⟨⟨fun i => (hb.1.1 i).trans hle, by have := hb.1.2; omega⟩, by have := hb.2; omega⟩ + +/-- **A machine with an explicit polynomial window decides a `PSPACE` language.** The exact +converse: together the two say that membership in `PSPACE` *is* the existence of a machine +keeping a polynomial window, with no asymptotics left to manage. -/ +theorem mem_PSPACE_of_polyWindow {L : Language} {k : ℕ} (tm : TM k) (q : Polynomial ℕ) + (hwin : ∀ (x : List Bool) (c' : Cfg k tm.Q), tm.reaches (tm.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) + (hdec : ∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L → c'.output.cells 1 = Γ.one) ∧ (x ∉ L → c'.output.cells 1 = Γ.zero)) : + L ∈ PSPACE := + Set.mem_iUnion.mpr ⟨q.natDegree, k, tm, fun n => q.eval n, ⟨hwin, hdec⟩, + BigO.of_polynomial_bound q (fun _ => le_rfl)⟩ + + +/-- **A machine with an explicit polynomial time bound decides a `P` language.** The time-domain +counterpart of `mem_PSPACE_of_polyWindow`: a construction hands back a concrete `Polynomial ℕ` +and gets the class membership, with the asymptotics discharged here. -/ +theorem mem_P_of_polyTime {L : Language} {k : ℕ} (tm : TM k) (q : Polynomial ℕ) + (hdec : tm.DecidesInTime L (fun n => q.eval n)) : L ∈ P := + Set.mem_iUnion.mpr ⟨q.natDegree, k, tm, fun n => q.eval n, hdec, + BigO.of_polynomial_bound q (fun _ => le_rfl)⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/ReachIn.lean b/Complexitylib/Classes/Containments/Internal/ReachIn.lean new file mode 100644 index 00000000..3f26ca6f --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/ReachIn.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.ReachSet + +/-! +# Step-counted reachability and the halving recursion + +⚠️ Unreviewed by Bolton + +Savitch's theorem rests on one combinatorial identity: a walk of at most `m + n` steps is a walk +of at most `m` steps followed by a walk of at most `n` steps, and conversely. Taking `m = n` +turns a bound of `2t` into two independent subproblems with bound `t`, so a bound of `2 ^ i` +recurses to depth `i` — the recursion whose stack a space-bounded machine can afford because +each level stores only one midpoint. + +Nothing here is about space, and nothing is about a machine: this is the pure statement that the +midpoint search is correct, which is the part of Savitch's argument that has to be true before +any bookkeeping is attempted. + +The same step counting supplies the numbers that the Immerman–Szelepcsényi counting argument +compares, so `NLSubsetCoNL` draws on this file too. + +## Main results + +- `NTM.ReachesCfgIn.trans`, `NTM.ReachesCfgIn.split` — walks concatenate and split +- `NTM.reachesCfgLe_add_iff` — **the midpoint recursion** +- `NTM.reachesCfgLe_two_mul_iff`, `NTM.reachesCfgLe_two_pow_succ_iff` — its halving forms +- `NTM.mem_reachSet_iff_reachesCfgLe` — the rounds of the search are exactly the step bounds +- `NTM.reachesCfg_iff_reachesCfgLe` — every reachable configuration is reachable within the + number of configuration codes +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} {tm : NTM k} + +/-! ## Walks concatenate and split -/ + +/-- Walks concatenate, and their lengths add. -/ +theorem ReachesCfgIn.trans {s t : ℕ} {c c' c'' : Cfg k tm.Q} + (h : tm.ReachesCfgIn s c c') (h' : tm.ReachesCfgIn t c' c'') : + tm.ReachesCfgIn (s + t) c c'' := by + induction h with + | refl _ => simpa using h' + | @head c₁ c₂ c₃ t₀ hstep _ ih => + rw [show t₀ + 1 + t = (t₀ + t) + 1 from by omega] + exact .head hstep (ih h') + +/-- **Walks split at any point.** A walk of `s + t` steps passes through a midpoint after +exactly `s` of them. -/ +theorem ReachesCfgIn.split {s t : ℕ} {c c'' : Cfg k tm.Q} + (h : tm.ReachesCfgIn (s + t) c c'') : + ∃ m, tm.ReachesCfgIn s c m ∧ tm.ReachesCfgIn t m c'' := by + induction s generalizing c with + | zero => exact ⟨c, .refl c, by simpa using h⟩ + | succ s ih => + rw [show s + 1 + t = (s + t) + 1 from by omega] at h + cases h with + | head hstep hrest => + obtain ⟨m, hm, hm'⟩ := ih hrest + exact ⟨m, .head hstep hm, hm'⟩ + +/-- A step bound can always be relaxed. -/ +theorem ReachesCfgLe.mono {s t : ℕ} {c c' : Cfg k tm.Q} (h : tm.ReachesCfgLe s c c') + (hst : s ≤ t) : tm.ReachesCfgLe t c c' := by + obtain ⟨u, hu, hwalk⟩ := h + exact ⟨u, by omega, hwalk⟩ + +/-- A configuration reaches itself in no steps. -/ +theorem reachesCfgLe_refl (tm : NTM k) (t : ℕ) (c : Cfg k tm.Q) : tm.ReachesCfgLe t c c := + ⟨0, Nat.zero_le t, .refl c⟩ + +/-! ## The midpoint recursion -/ + +/-- **Savitch's recursion.** A walk of at most `m + n` steps is exactly a walk of at most `m` +steps to some midpoint followed by a walk of at most `n` steps from it. The midpoint is the only +thing a recursive procedure has to remember. -/ +theorem reachesCfgLe_add_iff (tm : NTM k) (m n : ℕ) (c c'' : Cfg k tm.Q) : + tm.ReachesCfgLe (m + n) c c'' ↔ + ∃ mid, tm.ReachesCfgLe m c mid ∧ tm.ReachesCfgLe n mid c'' := by + constructor + · rintro ⟨s, hs, hwalk⟩ + rcases Nat.lt_or_ge s m with hlt | hge + · exact ⟨c'', ⟨s, hlt.le, hwalk⟩, reachesCfgLe_refl tm n c''⟩ + · obtain ⟨mid, h₁, h₂⟩ := + ReachesCfgIn.split (s := m) (t := s - m) (by rwa [show m + (s - m) = s from by omega]) + exact ⟨mid, ⟨m, le_rfl, h₁⟩, ⟨s - m, by omega, h₂⟩⟩ + · rintro ⟨mid, ⟨s, hs, h₁⟩, ⟨t, ht, h₂⟩⟩ + exact ⟨s + t, by omega, h₁.trans h₂⟩ + +/-- The halving form: a bound of `2 t` splits into two independent bounds of `t`. -/ +theorem reachesCfgLe_two_mul_iff (tm : NTM k) (t : ℕ) (c c'' : Cfg k tm.Q) : + tm.ReachesCfgLe (2 * t) c c'' ↔ + ∃ mid, tm.ReachesCfgLe t c mid ∧ tm.ReachesCfgLe t mid c'' := by + rw [show 2 * t = t + t from by omega] + exact reachesCfgLe_add_iff tm t t c c'' + +/-- **The recursion Savitch's machine runs.** A bound of `2 ^ (i + 1)` recurses to two +subproblems with bound `2 ^ i`, so the depth is `i` and each level stores one midpoint. -/ +theorem reachesCfgLe_two_pow_succ_iff (tm : NTM k) (i : ℕ) (c c'' : Cfg k tm.Q) : + tm.ReachesCfgLe (2 ^ (i + 1)) c c'' ↔ + ∃ mid, tm.ReachesCfgLe (2 ^ i) c mid ∧ tm.ReachesCfgLe (2 ^ i) mid c'' := by + have h2 : (2 : ℕ) ^ (i + 1) = 2 * 2 ^ i := by rw [pow_succ, Nat.mul_comm] + rw [h2] + exact reachesCfgLe_two_mul_iff tm (2 ^ i) c c'' + +/-! ## Agreement with the breadth-first rounds -/ + +/-- The rounds of the breadth-first search are exactly the step bounds. -/ +theorem mem_reachSet_iff_reachesCfgLe (tm : NTM k) (c₀ : Cfg k tm.Q) : + ∀ (t : ℕ) (c : Cfg k tm.Q), c ∈ reachSet tm c₀ t ↔ tm.ReachesCfgLe t c₀ c := by + intro t + induction t with + | zero => + intro c + constructor + · intro hc + rw [Set.mem_singleton_iff.mp hc] + exact reachesCfgLe_refl tm 0 c₀ + · rintro ⟨s, hs, hwalk⟩ + rw [Nat.le_zero.mp hs] at hwalk + cases hwalk + exact rfl + | succ t ih => + intro c + constructor + · rintro (hc | ⟨c', hc', hstep⟩) + · exact ((ih c).mp hc).mono (by omega) + · obtain ⟨s, hs, hwalk⟩ := (ih c').mp hc' + exact ⟨s + 1, by omega, hwalk.trans (.head hstep (.refl c))⟩ + · rintro ⟨s, hs, hwalk⟩ + rcases Nat.lt_or_ge s (t + 1) with hlt | hge + · exact Or.inl ((ih c).mpr ⟨s, by omega, hwalk⟩) + · have hst : s = t + 1 := by omega + subst hst + obtain ⟨mid, h₁, h₂⟩ := ReachesCfgIn.split (s := t) (t := 1) hwalk + cases h₂ with + | head hstep hrest => + cases hrest + exact Or.inr ⟨mid, (ih mid).mpr ⟨t, le_rfl, h₁⟩, hstep⟩ + +/-- **Every reachable configuration is reachable within the number of codes.** A walk longer +than that repeats a configuration, and the repetition can be cut out. -/ +theorem reachesCfg_iff_reachesCfgLe {α : Type} [Fintype α] (tm : NTM k) (c₀ : Cfg k tm.Q) + (g : Cfg k tm.Q → α) + (hinj : ∀ {c c' : Cfg k tm.Q}, tm.ReachesCfg c₀ c → tm.ReachesCfg c₀ c' → g c = g c' → c = c') + {N : ℕ} (hN : Fintype.card α ≤ N) (c : Cfg k tm.Q) : + tm.ReachesCfg c₀ c ↔ tm.ReachesCfgLe N c₀ c := by + rw [← mem_reachSet_iff_reachesCfgLe] + exact reachesCfg_iff_mem_reachSet tm c₀ g hinj hN c + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/ReachSet.lean b/Complexitylib/Classes/Containments/Internal/ReachSet.lean new file mode 100644 index 00000000..f8045504 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/ReachSet.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.ConfigGraph +public import Mathlib.Data.Set.Card + +/-! +# Reachability as a bounded fixpoint + +⚠️ Unreviewed by Bolton + +Breadth-first search closes a set of configurations under the successor relation. `reachSet` +is that closure after a fixed number of rounds, and the theorem below says a *polynomial* number +of rounds already suffices: the rounds strictly grow until they stabilize, and they cannot grow +past the number of configurations available. + +This is the specification a polynomial-time search has to implement — the counting it needs comes +from `Complexitylib.Classes.Containments.Internal.LogSpaceBound`. + +`reachSet` itself is defined in `Complexitylib.Classes.Containments.Defs`. + +## Main results + +- `NTM.reachSet_mono`, `NTM.reachSet_stabilizes` — the rounds grow and then stop +- `NTM.reachSet_finite` — each round is a finite set +- `NTM.exists_stabilizing_round` — they stop within the number of configuration codes +- `NTM.reachesCfg_iff_mem_reachSet` — enough rounds compute exactly reachability +- `NTM.reachesCfg_iff_mem_reachSet` — with enough rounds the fixpoint is exactly reachability +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} {tm : NTM k} + +theorem reachSet_succ (tm : NTM k) (c₀ : Cfg k tm.Q) (t : ℕ) : + reachSet tm c₀ (t + 1) = reachSet tm c₀ t ∪ {c' | ∃ c ∈ reachSet tm c₀ t, tm.Succ c c'} := + rfl + +theorem reachSet_subset_succ (tm : NTM k) (c₀ : Cfg k tm.Q) (t : ℕ) : + reachSet tm c₀ t ⊆ reachSet tm c₀ (t + 1) := fun _ h => Or.inl h + +theorem reachSet_mono (tm : NTM k) (c₀ : Cfg k tm.Q) {s t : ℕ} (h : s ≤ t) : + reachSet tm c₀ s ⊆ reachSet tm c₀ t := by + induction t with + | zero => rw [Nat.le_zero.mp h] + | succ t ih => + rcases Nat.lt_or_ge s (t + 1) with hlt | hge + · exact (ih (by omega)).trans (reachSet_subset_succ tm c₀ t) + · rw [show s = t + 1 from by omega] + +/-- Every element of a round is reachable. -/ +theorem reachesCfg_of_mem_reachSet (tm : NTM k) (c₀ : Cfg k tm.Q) : + ∀ (t : ℕ) {c}, c ∈ reachSet tm c₀ t → tm.ReachesCfg c₀ c + | 0, c, hc => by rw [Set.mem_singleton_iff.mp hc]; exact reachesCfg_refl tm c₀ + | t + 1, c, hc => by + rcases hc with hc | ⟨c', hc', hstep⟩ + · exact reachesCfg_of_mem_reachSet tm c₀ t hc + · exact Relation.ReflTransGen.tail (reachesCfg_of_mem_reachSet tm c₀ t hc') hstep + +/-- Reachability in `t` steps lands in round `t`. -/ +theorem mem_reachSet_of_reachesCfg {c₀ c : Cfg k tm.Q} (h : tm.ReachesCfg c₀ c) : + ∃ t, c ∈ reachSet tm c₀ t := by + induction h with + | refl => exact ⟨0, rfl⟩ + | tail _ hstep ih => + obtain ⟨t, ht⟩ := ih + exact ⟨t + 1, Or.inr ⟨_, ht, hstep⟩⟩ + +/-- Once a round adds nothing, no later round does either. -/ +theorem reachSet_stabilizes (tm : NTM k) (c₀ : Cfg k tm.Q) {s : ℕ} + (h : reachSet tm c₀ (s + 1) ⊆ reachSet tm c₀ s) : + ∀ m, reachSet tm c₀ (s + m) = reachSet tm c₀ s := by + intro m + induction m with + | zero => rfl + | succ m ih => + have hs : s + (m + 1) = (s + m) + 1 := by omega + rw [hs, reachSet_succ] + refine subset_antisymm (fun c hc => ?_) (fun c hc => Or.inl (by rw [ih]; exact hc)) + rcases hc with hc | ⟨c', hc', hst⟩ + · rw [ih] at hc + exact hc + · rw [ih] at hc' + exact h (Or.inr ⟨c', hc', hst⟩) + +/-- Each round is a finite set: it starts as a singleton and each round adds at most two +successors per member. -/ +theorem reachSet_finite (tm : NTM k) (c₀ : Cfg k tm.Q) : ∀ t, (reachSet tm c₀ t).Finite + | 0 => Set.finite_singleton c₀ + | t + 1 => by + refine (reachSet_finite tm c₀ t).union (Set.Finite.subset + (((reachSet_finite tm c₀ t).image (tm.stepCfg false)).union + ((reachSet_finite tm c₀ t).image (tm.stepCfg true))) ?_) + rintro c' ⟨c, hc, -, b, rfl⟩ + cases b + · exact Or.inl ⟨c, hc, rfl⟩ + · exact Or.inr ⟨c, hc, rfl⟩ + +/-! ## The rounds stabilize within the configuration count -/ + +section Finite + +variable {α : Type} [Fintype α] + +/-- The image of a round under a coding map. -/ +private def reachImage (tm : NTM k) (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) (t : ℕ) : Set α := + g '' reachSet tm c₀ t + +omit [Fintype α] in +private theorem reachImage_mono (tm : NTM k) (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) (t : ℕ) : + reachImage tm c₀ g t ⊆ reachImage tm c₀ g (t + 1) := + Set.image_mono (reachSet_subset_succ tm c₀ t) + +omit [Fintype α] in +/-- A round that adds a genuinely new configuration adds a new code too, provided the coding +map separates reachable configurations. -/ +private theorem reachImage_ssubset (tm : NTM k) (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) + (hinj : ∀ {c c' : Cfg k tm.Q}, tm.ReachesCfg c₀ c → tm.ReachesCfg c₀ c' → g c = g c' → c = c') + {t : ℕ} (h : ¬ reachSet tm c₀ (t + 1) ⊆ reachSet tm c₀ t) : + reachImage tm c₀ g t ⊂ reachImage tm c₀ g (t + 1) := by + obtain ⟨c, hc, hcn⟩ := Set.not_subset.mp h + refine ⟨reachImage_mono tm c₀ g t, fun hsub => hcn ?_⟩ + obtain ⟨c', hc', hgc⟩ := hsub ⟨c, hc, rfl⟩ + have := hinj (reachesCfg_of_mem_reachSet tm c₀ (t + 1) hc) + (reachesCfg_of_mem_reachSet tm c₀ t hc') hgc.symm + rwa [this] + +/-- **The rounds stabilize by the number of codes.** As long as the rounds keep growing they +consume a fresh code each time, and there are only `Fintype.card α` of those. -/ +theorem exists_stabilizing_round (tm : NTM k) (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) + (hinj : ∀ {c c' : Cfg k tm.Q}, tm.ReachesCfg c₀ c → tm.ReachesCfg c₀ c' → g c = g c' → c = c') : + ∃ s ≤ Fintype.card α, reachSet tm c₀ (s + 1) ⊆ reachSet tm c₀ s := by + by_contra hcon + have hcon' : ∀ t ≤ Fintype.card α, ¬ reachSet tm c₀ (t + 1) ⊆ reachSet tm c₀ t := + fun t ht hsub => hcon ⟨t, ht, hsub⟩ + have grow : ∀ t ≤ Fintype.card α, t + 1 ≤ (reachImage tm c₀ g t).ncard := by + intro t + induction t with + | zero => + intro _ + have : reachImage tm c₀ g 0 = {g c₀} := by + simp [reachImage, reachSet] + rw [this, Set.ncard_singleton] + | succ t ih => + intro ht + have hss := reachImage_ssubset tm c₀ g hinj (hcon' t (by omega)) + have hlt := Set.ncard_lt_ncard hss (Set.toFinite _) + have := ih (by omega) + omega + have hle : (reachImage tm c₀ g (Fintype.card α)).ncard ≤ Fintype.card α := by + have := Set.ncard_le_ncard (Set.subset_univ (reachImage tm c₀ g (Fintype.card α))) + (Set.finite_univ) + rwa [Set.ncard_univ, Nat.card_eq_fintype_card] at this + have := grow (Fintype.card α) le_rfl + omega + +/-- **With enough rounds the fixpoint is exactly reachability.** The number of rounds needed is +the number of codes, so a polynomial code count makes this a polynomial-round search. -/ +theorem reachesCfg_iff_mem_reachSet' (tm : NTM k) (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) + (hinj : ∀ {c c' : Cfg k tm.Q}, tm.ReachesCfg c₀ c → tm.ReachesCfg c₀ c' → g c = g c' → c = c') + (c : Cfg k tm.Q) : + tm.ReachesCfg c₀ c ↔ c ∈ reachSet tm c₀ (Fintype.card α) := by + refine ⟨fun h => ?_, reachesCfg_of_mem_reachSet tm c₀ _⟩ + obtain ⟨t, ht⟩ := mem_reachSet_of_reachesCfg h + obtain ⟨s, hsN, hstab⟩ := exists_stabilizing_round tm c₀ g hinj + rcases Nat.lt_or_ge t (Fintype.card α) with hlt | hge + · exact reachSet_mono tm c₀ hlt.le ht + · have : reachSet tm c₀ t = reachSet tm c₀ s := by + have := reachSet_stabilizes tm c₀ hstab (t - s) + rwa [show s + (t - s) = t from by omega] at this + rw [this] at ht + exact reachSet_mono tm c₀ hsN ht + +/-- **Running extra rounds is harmless.** An implementation computes a round count it can +evaluate rather than the exact number of codes; any count that reaches the bound is correct. -/ +theorem reachesCfg_iff_mem_reachSet (tm : NTM k) (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) + (hinj : ∀ {c c' : Cfg k tm.Q}, tm.ReachesCfg c₀ c → tm.ReachesCfg c₀ c' → g c = g c' → c = c') + {N : ℕ} (hN : Fintype.card α ≤ N) (c : Cfg k tm.Q) : + tm.ReachesCfg c₀ c ↔ c ∈ reachSet tm c₀ N := + ⟨fun h => reachSet_mono tm c₀ hN + ((reachesCfg_iff_mem_reachSet' tm c₀ g hinj c).mp h), + reachesCfg_of_mem_reachSet tm c₀ N⟩ + +end Finite + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchBits.lean b/Complexitylib/Classes/Containments/Internal/SavitchBits.lean new file mode 100644 index 00000000..4d59e5d3 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchBits.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.FPBridge +public import Complexitylib.Classes.Containments.Internal.WitnessEnum + +/-! +# A fixed-width binary counter inside the polynomial-time algebra + +⚠️ Unreviewed by Bolton + +Savitch's recursion searches for a midpoint by enumerating every bitstring of the +width a configuration code occupies. The enumeration is an ordinary little-endian +increment that wraps around, and the wrap is what tells the search it has run out +of candidates. + +`Complexity.addBit` is that increment as a plain recursion — carry in, carry out, +result — and `Complexity.bumpStep` is the same thing as a left-to-right scan on a +packed state, the shape `Cobham.iterate_mem_FP` iterates. The two agree +(`Complexity.bumpStep_iterate_run`), so the arithmetic can be done on the +recursion and the polynomial-time bound on the scan. + +## Main definitions + +- `Complexity.addBit` — increment a little-endian bitstring, with carry +- `Complexity.bumpBits`, `Complexity.bumpOver` — its two components +- `Complexity.bumpStep` — one step of the scan that computes it +- `Complexity.bumpFlag`, `Complexity.bumpCode` — the packed verdicts + +## Main results + +- `Complexity.addBit_binValLE` — the adder is correct +- `Complexity.bumpBits_length` — the width is preserved +- `Complexity.bumpOver_iff` — the carry fires exactly on the last candidate +- `Complexity.bumpCodeFn_mem_FP`, `Complexity.bumpFlagFn_mem_FP` — both are in `FP` +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-! ## The increment as a recursion -/ + +/-- Add a carry bit into a little-endian bitstring: the carry out and the result. -/ +def addBit : Bool → List Bool → Bool × List Bool + | c, [] => (c, []) + | c, b :: t => ((addBit (c && b) t).1, (xor c b) :: (addBit (c && b) t).2) + +@[simp] theorem addBit_nil (c : Bool) : addBit c [] = (c, []) := rfl + +@[simp] theorem addBit_cons (c b : Bool) (t : List Bool) : + addBit c (b :: t) = ((addBit (c && b) t).1, (xor c b) :: (addBit (c && b) t).2) := rfl + +/-- The increment of a little-endian bitstring, wrapping on overflow. -/ +def bumpBits (w : List Bool) : List Bool := (addBit true w).2 + +/-- Did the increment wrap around? -/ +def bumpOver (w : List Bool) : Bool := (addBit true w).1 + +/-- Adding no carry changes nothing. -/ +@[simp] theorem addBit_false (w : List Bool) : addBit false w = (false, w) := by + induction w with + | nil => rfl + | cons b t ih => simp [addBit, ih] + +/-- The width is preserved. -/ +@[simp] theorem addBit_length (c : Bool) (w : List Bool) : + (addBit c w).2.length = w.length := by + induction w generalizing c with + | nil => rfl + | cons b t ih => simp [addBit, ih] + +@[simp] theorem bumpBits_length (w : List Bool) : (bumpBits w).length = w.length := + addBit_length true w + +/-- **The adder is correct.** -/ +theorem addBit_binValLE (c : Bool) (w : List Bool) : + binValLE (addBit c w).2 + (if (addBit c w).1 then 2 ^ w.length else 0) + = binValLE w + (if c then 1 else 0) := by + induction w generalizing c with + | nil => cases c <;> simp [binValLE] + | cons b t ih => + have h := ih (c && b) + rcases hab : addBit (c && b) t with ⟨d, s⟩ + rw [hab] at h + simp only [addBit_cons, hab, binValLE, List.length_cons, pow_succ] + clear hab ih + cases c <;> cases b <;> cases d <;> simp at h ⊢ <;> omega + +/-- **The carry fires exactly on the last candidate.** -/ +theorem bumpOver_iff (w : List Bool) : + bumpOver w = true ↔ binValLE w = 2 ^ w.length - 1 := by + have h := addBit_binValLE true w + have hlt := binValLE_lt (addBit true w).2 + have hlt' := binValLE_lt w + rw [addBit_length] at hlt + rw [bumpOver] + constructor + · intro hc + rw [hc] at h + simp at h + omega + · intro hv + by_contra hc + simp only [Bool.not_eq_true] at hc + rw [hc] at h + simp at h + omega + +/-- **The increment counts.** -/ +theorem binValLE_bumpBits_of_not_over (w : List Bool) (h : bumpOver w = false) : + binValLE (bumpBits w) = binValLE w + 1 := by + have hb := addBit_binValLE true w + rw [bumpOver] at h + rw [h] at hb + simp at hb + rw [bumpBits] + omega + +/-- Iterating the increment from zero enumerates the candidates in order. -/ +theorem bumpBits_iterate (ℓ : ℕ) : + ∀ j, j < 2 ^ ℓ → bumpBits^[j] (bitsOfLenLE ℓ 0) = bitsOfLenLE ℓ j := by + intro j + induction j with + | zero => intro _; rfl + | succ j ih => + intro hj + have hj' : j < 2 ^ ℓ := by omega + rw [Function.iterate_succ_apply', ih hj'] + have hlen : (bitsOfLenLE ℓ j).length = ℓ := bitsOfLenLE_length ℓ j + have hval : binValLE (bitsOfLenLE ℓ j) = j := binValLE_bitsOfLenLE ℓ j hj' + have hover : bumpOver (bitsOfLenLE ℓ j) = false := by + by_contra hc + simp only [Bool.not_eq_false] at hc + rw [bumpOver_iff, hlen, hval] at hc + omega + have := binValLE_bumpBits_of_not_over _ hover + rw [hval] at this + rw [← bitsOfLenLE_binValLE (bumpBits (bitsOfLenLE ℓ j)), this, bumpBits_length, hlen] + +/-! ## The increment as a scan + +The same increment, written as a left-to-right pass over the string: carry, the +bits already emitted, and the bits still to read. This is the shape +`Cobham.iterate_mem_FP` iterates, and every operation in it is one of the +algebra's. -/ + +/-- One step of the increment scan. -/ +def bumpStep : List Bool × List Bool × List Bool → List Bool × List Bool × List Bool + | (c, acc, []) => (c, acc, []) + | (c, acc, b :: t) => (andBit c [b], acc ++ selectHead c (notBit [b]) [b], t) + +@[simp] theorem bumpStep_nil (c acc : List Bool) : bumpStep (c, acc, []) = (c, acc, []) := rfl + +theorem bumpStep_flag (c b : Bool) (acc t : List Bool) : + bumpStep ([c], acc, b :: t) = ([c && b], acc ++ [xor c b], t) := by + rw [bumpStep] + refine Prod.ext ?_ (Prod.ext ?_ rfl) + · show andBit [c] [b] = [c && b] + cases c <;> cases b <;> rfl + · show acc ++ selectHead [c] (notBit [b]) [b] = acc ++ [xor c b] + cases c <;> cases b <;> rfl + +/-- **The scan computes the increment.** -/ +theorem bumpStep_iterate_run (c : Bool) (acc w : List Bool) : + bumpStep^[w.length] ([c], acc, w) = ([(addBit c w).1], acc ++ (addBit c w).2, []) := by + induction w generalizing c acc with + | nil => simp + | cons b t ih => + rw [List.length_cons, Function.iterate_succ_apply, bumpStep_flag, ih, + addBit_cons] + simp + +/-- The scan never has more in hand than it started with. -/ +theorem bumpStep_iterate_length (c : Bool) (acc w : List Bool) (n : ℕ) : + (bumpStep^[n] ([c], acc, w)).1.length = 1 ∧ + (bumpStep^[n] ([c], acc, w)).2.1.length + (bumpStep^[n] ([c], acc, w)).2.2.length + ≤ acc.length + w.length := by + induction n generalizing c acc w with + | zero => exact ⟨rfl, le_rfl⟩ + | succ n ih => + rw [Function.iterate_succ_apply] + cases w with + | nil => + have := ih c acc [] + simpa using this + | cons b t => + rw [bumpStep_flag] + have := ih (c && b) (acc ++ [xor c b]) t + refine ⟨this.1, le_trans this.2 ?_⟩ + simp + omega + +/-! ## The packed scan -/ + +/-- The packed scan state. -/ +def bumpPack (c acc rest : List Bool) : List Bool := pair c (pair acc rest) + +@[simp] theorem bumpPack_length (c acc rest : List Bool) : + (bumpPack c acc rest).length = 2 * c.length + 2 * acc.length + rest.length + 4 := by + rw [bumpPack, pair_length, pair_length] + omega + +/-- One step of the packed scan. -/ +def bumpStepP (z : List Bool) : List Bool := + selectHead (lenLeFlag (sndBlock (sndBlock z)) [false]) + (pair (andBit (fstBlock z) ((sndBlock (sndBlock z)).take 1)) + (pair (fstBlock (sndBlock z) ++ + selectHead (fstBlock z) (notBit ((sndBlock (sndBlock z)).take 1)) + ((sndBlock (sndBlock z)).take 1)) + ((sndBlock (sndBlock z)).drop 1))) + z + +/-- **The packed step is the unpacked step.** -/ +theorem bumpStepP_pack (c acc rest : List Bool) : + bumpStepP (bumpPack c acc rest) + = bumpPack (bumpStep (c, acc, rest)).1 (bumpStep (c, acc, rest)).2.1 + (bumpStep (c, acc, rest)).2.2 := by + rw [bumpStepP, bumpPack] + simp only [fstBlock_pair, sndBlock_pair] + cases rest with + | nil => + rw [selectHead] + have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl + rw [hflag] + simp [bumpPack] + | cons b t => + have hflag : lenLeFlag (b :: t) [false] = [true] := + (lenLeFlag_eq_true_iff (b :: t) [false]).mpr (by simp) + rw [selectHead, hflag] + simp only [List.head?_cons, reduceIte] + rw [bumpStep, bumpPack] + simp + +/-- **The packed iteration is the unpacked one.** -/ +theorem bumpStepP_iterate (s : List Bool × List Bool × List Bool) (n : ℕ) : + bumpStepP^[n] (bumpPack s.1 s.2.1 s.2.2) + = bumpPack (bumpStep^[n] s).1 (bumpStep^[n] s).2.1 (bumpStep^[n] s).2.2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, bumpStepP_pack, ih (bumpStep s), + Function.iterate_succ_apply] + +/-- The packed iteration, with the state's three components spelled out. -/ +theorem bumpStepP_iterate_args (c acc rest : List Bool) (n : ℕ) : + bumpStepP^[n] (bumpPack c acc rest) + = bumpPack (bumpStep^[n] (c, acc, rest)).1 (bumpStep^[n] (c, acc, rest)).2.1 + (bumpStep^[n] (c, acc, rest)).2.2 := + bumpStepP_iterate (c, acc, rest) n + +/-! ## The verdicts -/ + +/-- The packed scan run to completion. -/ +def bumpRun (w : List Bool) : List Bool := bumpStepP^[w.length] (bumpPack [true] [] w) + +/-- The increment of `w`, computed by the scan. -/ +def bumpCode (w : List Bool) : List Bool := fstBlock (sndBlock (bumpRun w)) + +/-- The carry out of the increment, as a flag. -/ +def bumpFlag (w : List Bool) : List Bool := fstBlock (bumpRun w) + +theorem bumpRun_eq (w : List Bool) : + bumpRun w = bumpPack [bumpOver w] (bumpBits w) [] := by + rw [bumpRun, bumpStepP_iterate_args, bumpStep_iterate_run, bumpOver, bumpBits] + simp + +@[simp] theorem bumpCode_eq (w : List Bool) : bumpCode w = bumpBits w := by + rw [bumpCode, bumpRun_eq, bumpPack] + simp + +@[simp] theorem bumpFlag_eq (w : List Bool) : bumpFlag w = [bumpOver w] := by + rw [bumpFlag, bumpRun_eq, bumpPack] + simp + +/-! ## Both are polynomial-time -/ + +theorem bumpStepP_mem_FP : bumpStepP ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hc := hfst hid + have hw := hsnd hid + have hrest := hsnd hw + have hacc := hfst hw + have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] + have htake : (fun z => (sndBlock (sndBlock z)).take 1) ∈ FP := by + have := Cobham.takeLenFn_mem_FP hone hrest + simpa using this + have hdrop : (fun z => (sndBlock (sndBlock z)).drop 1) ∈ FP := by + have := dropLenFn_mem_FP hone hrest + simpa using this + have hbit : (fun z => selectHead (fstBlock z) + (notBit ((sndBlock (sndBlock z)).take 1)) ((sndBlock (sndBlock z)).take 1)) ∈ FP := + Cobham.selectHeadFn_mem_FP hc (notBitFn_mem_FP htake) htake + exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hrest hone) + (Cobham.pairFn_mem_FP (andBitFn_mem_FP hc htake) + (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hacc hbit) hdrop)) hid + +/-- **The increment is polynomial-time.** -/ +theorem bumpRunFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => bumpRun (a z)) ∈ FP := by + have hinit : (fun z => bumpPack [true] [] (a z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP [true]) + (Cobham.pairFn_mem_FP (constFn_mem_FP []) ha) + have hwidth : (fun z => pair [true] (pair (a z) (a z))) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP [true]) (Cobham.pairFn_mem_FP ha ha) + have hbound : ∀ z, ∀ n ≤ (a z).length, + (bumpStepP^[n] (bumpPack [true] [] (a z))).length + ≤ (pair [true] (pair (a z) (a z))).length := by + intro z n _ + rw [bumpStepP_iterate_args] + obtain ⟨h1, h2⟩ := bumpStep_iterate_length true [] (a z) n + have hone : ([true] : List Bool).length = 1 := rfl + rw [bumpPack_length, pair_length, pair_length] + simp only [List.length_nil] at h2 + omega + exact Cobham.iterate_mem_FP bumpStepP_mem_FP hinit ha hwidth hbound + +theorem bumpCodeFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => bumpCode (a z)) ∈ FP := by + have h1 := mem_FP_comp (bumpRunFn_mem_FP ha) Cobham.sndBlock_mem_FP + have h2 := mem_FP_comp h1 Cobham.fstBlock_mem_FP + simpa [Function.comp, bumpCode] using h2 + +theorem bumpFlagFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => bumpFlag (a z)) ∈ FP := by + have h := mem_FP_comp (bumpRunFn_mem_FP ha) Cobham.fstBlock_mem_FP + simpa [Function.comp, bumpFlag] using h + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchBound.lean b/Complexitylib/Classes/Containments/Internal/SavitchBound.lean new file mode 100644 index 00000000..b8b0f909 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchBound.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.ReachIn +public import Complexitylib.Classes.Containments.Internal.BoundedReach +public import Complexitylib.Classes.NP +public import Complexitylib.Classes.Containments.Internal.PolyWindow + +/-! +# The step bound Savitch's recursion starts from + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.ReachIn` halves a step bound; this file supplies +the bound to start from. A machine using polynomial space has at most `2 ^ poly` configurations, +so reachability is always witnessed within `2 ^ poly` steps, and halving that bound bottoms out +after `poly` levels. That is the whole reason Savitch's recursion is affordable: its depth is +polynomial and each level stores one configuration, itself of polynomial size. + +## Main definitions + +- `codeExpBound` — a polynomial dominating the exponent of the configuration count + +## Main results + +- `card_Code_le_two_pow_poly` — the configuration count is `2` to a polynomial +- `NPSPACE_bounded_reachability_internal` — membership is reachability within `2 ^ poly` steps +- `NPSPACE_subset_PSPACE_of_recursion_internal` — the containment, modulo one machine +-/ + +@[expose] public section + +namespace Complexity + +/-- A polynomial dominating the exponent of the configuration count of a machine with `cardQ` +states, `k` work tapes, and space bounded by `p`. -/ +noncomputable def codeExpBound (cardQ k : ℕ) (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C cardQ + (Polynomial.X + p + Polynomial.C 2) + + Polynomial.C (3 * k) * (p + 1) + Polynomial.C 3 * (p + Polynomial.C 2) + +/-- **The configuration count is `2` to a polynomial.** -/ +theorem card_Code_le_two_pow_poly (Q : Type) [Fintype Q] (k : ℕ) (S : ℕ → ℕ) + (p : Polynomial ℕ) (hS : ∀ n, S n ≤ p.eval n) (n : ℕ) : + Fintype.card (Code Q k n (S n)) ≤ 2 ^ (codeExpBound (Fintype.card Q) k p).eval n := by + refine le_trans (card_Code_le_two_pow Q k n (S n)) (Nat.pow_le_pow_right (by norm_num) ?_) + have h := hS n + simp only [codeExpBound, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, Polynomial.eval_one] + exact Nat.add_le_add (Nat.add_le_add (Nat.add_le_add (le_refl _) (by omega)) + (Nat.mul_le_mul_left _ (by omega))) (Nat.mul_le_mul_left _ (by omega)) + +/-- **A language in `NPSPACE` is reachability within `2 ^ poly` steps.** This is the input to +Savitch's recursion: halving the bound `2 ^ q(|x|)` bottoms out after `q(|x|)` levels, so the +recursion depth is polynomial. -/ +theorem NPSPACE_bounded_reachability_internal {L : Language} (hL : L ∈ NPSPACE) : + ∃ (k : ℕ) (tm : NTM k) (q : Polynomial ℕ), + ∀ x : List Bool, x ∈ L ↔ + ∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ + tm.halted c ∧ c.output.cells 1 = Γ.one := by + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, S, hdec, hS⟩ := hm + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hS + refine ⟨k, tm, codeExpBound (Fintype.card tm.Q) k p, fun x => ?_⟩ + rw [mem_iff_exists_accepting_reachable hdec x] + constructor + · rintro ⟨c, hreach, hhalt, hout⟩ + refine ⟨c, ?_, hhalt, hout⟩ + exact (NTM.reachesCfg_iff_reachesCfgLe tm _ (cfgCode x.length (S x.length)) + (fun hc hc' => NTM.cfgCode_inj_of_reachesCfg hdec x hc hc') + (card_Code_le_two_pow_poly tm.Q k S p hp x.length) c).mp hreach + · rintro ⟨c, hle, hhalt, hout⟩ + refine ⟨c, ?_, hhalt, hout⟩ + exact (NTM.reachesCfg_iff_reachesCfgLe tm _ (cfgCode x.length (S x.length)) + (fun hc hc' => NTM.cfgCode_inj_of_reachesCfg hdec x hc hc') + (card_Code_le_two_pow_poly tm.Q k S p hp x.length) c).mpr hle + + +/-- **`NPSPACE ⊆ PSPACE`, reduced to the existence of one machine.** The hypothesis carries the +space witness for `tm`: without it the configuration graph is unbounded and the step bound +`2 ^ q(|x|)` is not enough to make the search decidable in polynomial space. -/ +theorem NPSPACE_subset_PSPACE_of_recursion_internal + (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (m : ℕ) (q : Polynomial ℕ), + tm.DecidesInSpace L₀ S → S =O (· ^ m) → + ∃ (k' : ℕ) (M : TM k') (r : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (r.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + ((∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ + c.output.cells 1 = Γ.one) → c'.output.cells 1 = Γ.one) ∧ + ((¬ ∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ + c.output.cells 1 = Γ.one) → c'.output.cells 1 = Γ.zero))) : + NPSPACE ⊆ PSPACE := by + intro L hL + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, S, hdec, hS⟩ := hm + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hS + set q : Polynomial ℕ := codeExpBound (Fintype.card tm.Q) k p with hq + have hreach : ∀ x : List Bool, x ∈ L ↔ + ∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ + c.output.cells 1 = Γ.one := by + intro x + rw [mem_iff_exists_accepting_reachable hdec x] + constructor + · rintro ⟨c, hr, hh, ho⟩ + exact ⟨c, (NTM.reachesCfg_iff_reachesCfgLe tm _ (cfgCode x.length (S x.length)) + (fun ha hb => NTM.cfgCode_inj_of_reachesCfg hdec x ha hb) + (card_Code_le_two_pow_poly tm.Q k S p hp x.length) c).mp hr, hh, ho⟩ + · rintro ⟨c, hle, hh, ho⟩ + exact ⟨c, (NTM.reachesCfg_iff_reachesCfgLe tm _ (cfgCode x.length (S x.length)) + (fun ha hb => NTM.cfgCode_inj_of_reachesCfg hdec x ha hb) + (card_Code_le_two_pow_poly tm.Q k S p hp x.length) c).mpr hle, hh, ho⟩ + obtain ⟨k', M, r, hwin, hdecM⟩ := h k tm S L m q hdec hS + refine mem_PSPACE_of_polyWindow M r hwin fun x => ?_ + obtain ⟨c', hr, hh, hone, hzero⟩ := hdecM x + exact ⟨c', hr, hh, fun hx => hone ((hreach x).mp hx), + fun hx => hzero fun hc => hx ((hreach x).mpr hc)⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean b/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean new file mode 100644 index 00000000..11f70fef --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean @@ -0,0 +1,277 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchBits + +/-! +# The tape of Savitch's stack machine + +⚠️ Unreviewed by Bolton + +Savitch's procedure is a recursion of polynomial depth, so it is a stack machine +whose stack is polynomially bounded. This file fixes how that stack is written on +a single bitstring, and gives every field's reader and writer inside the +polynomial-time algebra. + +A **frame** carries the subproblem a level of the recursion is working on: + +* `kind` — `[false]` for *is `v` reachable from `u`*, `[true]` for *is some + accepting configuration reachable from `u`*; +* `ph` — `[false]` while the first half of the interval is being tried, + `[true]` while the second is; +* `lvl` — the level, in unary: `2 ^ |lvl|` steps are allowed; +* `u`, `v` — the two endpoints (`v` is unused by an acceptance frame); +* `m` — the midpoint being tried, which doubles as the enumeration's counter. + +A **stack** is a right-nested chain of pairs, empty stack being the empty string; +`pair` is never empty, so the two are told apart by a single flag. + +The **state** carries the done flag (which is the bit `Complexity.SpaceIter` +watches), the answer, the block ruler the codes are written against, the value a +finished subcall is returning (`[]` while descending), and the stack. + +## Main definitions + +- `Complexity.mkFrame` and `Complexity.frKind`, … — a frame and its fields +- `Complexity.encStack`, `Complexity.stkTop`, `Complexity.stkRest` — the stack +- `Complexity.mkSt` and `Complexity.stDone`, … — the state and its fields + +## Main results + +- the `_mk` simp lemmas — every reader inverts the constructor +- `Complexity.mkFrameFn_mem_FP`, `Complexity.mkStFn_mem_FP`, and the readers' — + all of it is in `FP` +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-! ## Frames -/ + +/-- A frame of Savitch's recursion. -/ +def mkFrame (kind ph lvl u v m : List Bool) : List Bool := + pair kind (pair ph (pair lvl (pair u (pair v m)))) + +/-- Which subproblem the frame is working on. -/ +def frKind (f : List Bool) : List Bool := fstBlock f + +/-- Which half of the interval the frame is trying. -/ +def frPh (f : List Bool) : List Bool := fstBlock (sndBlock f) + +/-- The frame's level, in unary. -/ +def frLvl (f : List Bool) : List Bool := fstBlock (sndBlock (sndBlock f)) + +/-- The frame's source endpoint. -/ +def frU (f : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock f))) + +/-- The frame's target endpoint. -/ +def frV (f : List Bool) : List Bool := + fstBlock (sndBlock (sndBlock (sndBlock (sndBlock f)))) + +/-- The midpoint the frame is trying. -/ +def frM (f : List Bool) : List Bool := + sndBlock (sndBlock (sndBlock (sndBlock (sndBlock f)))) + +@[simp] theorem frKind_mk (kind ph lvl u v m : List Bool) : + frKind (mkFrame kind ph lvl u v m) = kind := by simp [frKind, mkFrame] + +@[simp] theorem frPh_mk (kind ph lvl u v m : List Bool) : + frPh (mkFrame kind ph lvl u v m) = ph := by simp [frPh, mkFrame] + +@[simp] theorem frLvl_mk (kind ph lvl u v m : List Bool) : + frLvl (mkFrame kind ph lvl u v m) = lvl := by simp [frLvl, mkFrame] + +@[simp] theorem frU_mk (kind ph lvl u v m : List Bool) : + frU (mkFrame kind ph lvl u v m) = u := by simp [frU, mkFrame] + +@[simp] theorem frV_mk (kind ph lvl u v m : List Bool) : + frV (mkFrame kind ph lvl u v m) = v := by simp [frV, mkFrame] + +@[simp] theorem frM_mk (kind ph lvl u v m : List Bool) : + frM (mkFrame kind ph lvl u v m) = m := by simp [frM, mkFrame] + +@[simp] theorem mkFrame_length (kind ph lvl u v m : List Bool) : + (mkFrame kind ph lvl u v m).length + = 2 * kind.length + 2 * ph.length + 2 * lvl.length + 2 * u.length + 2 * v.length + + m.length + 10 := by + rw [mkFrame, pair_length, pair_length, pair_length, pair_length, pair_length] + omega + +/-! ## Stacks -/ + +/-- A stack of frames, top first. -/ +def encStack : List (List Bool) → List Bool + | [] => [] + | f :: fs => pair f (encStack fs) + +@[simp] theorem encStack_nil : encStack [] = [] := rfl + +@[simp] theorem encStack_cons (f : List Bool) (fs : List (List Bool)) : + encStack (f :: fs) = pair f (encStack fs) := rfl + +/-- The frame on top of the stack. -/ +def stkTop (S : List Bool) : List Bool := fstBlock S + +/-- The stack below the top frame. -/ +def stkRest (S : List Bool) : List Bool := sndBlock S + +@[simp] theorem stkTop_cons (f : List Bool) (fs : List (List Bool)) : + stkTop (encStack (f :: fs)) = f := by simp [stkTop] + +@[simp] theorem stkRest_cons (f : List Bool) (fs : List (List Bool)) : + stkRest (encStack (f :: fs)) = encStack fs := by simp [stkRest] + +/-- A stack is empty exactly when its encoding is. -/ +theorem encStack_eq_nil_iff (fs : List (List Bool)) : encStack fs = [] ↔ fs = [] := by + cases fs with + | nil => exact ⟨fun _ => rfl, fun _ => rfl⟩ + | cons f fs => + refine ⟨fun h => absurd h ?_, fun h => absurd h (by simp)⟩ + rw [encStack_cons] + intro hc + have := congrArg List.length hc + rw [pair_length] at this + simp at this + +@[simp] theorem encStack_length (fs : List (List Bool)) : + (encStack fs).length = fs.foldr (fun f n => 2 * f.length + 2 + n) 0 := by + induction fs with + | nil => rfl + | cons f fs ih => rw [encStack_cons, pair_length, ih, List.foldr_cons] + +/-! ## The state -/ + +/-- The machine's state: the done flag, the answer, the block ruler, the value a +finished subcall is returning, and the stack. -/ +def mkSt (d a R ret stk : List Bool) : List Bool := + pair d (pair a (pair R (pair ret stk))) + +/-- The done flag — the bit the iteration watches. -/ +def stDone (s : List Bool) : List Bool := fstBlock s + +/-- The answer, once the recursion has produced one. -/ +def stAns (s : List Bool) : List Bool := fstBlock (sndBlock s) + +/-- The block ruler the configuration codes are written against. -/ +def stR (s : List Bool) : List Bool := fstBlock (sndBlock (sndBlock s)) + +/-- The value a finished subcall is returning; `[]` while descending. -/ +def stRet (s : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock s))) + +/-- The stack. -/ +def stStk (s : List Bool) : List Bool := sndBlock (sndBlock (sndBlock (sndBlock s))) + +@[simp] theorem stDone_mk (d a R ret stk : List Bool) : stDone (mkSt d a R ret stk) = d := by + simp [stDone, mkSt] + +@[simp] theorem stAns_mk (d a R ret stk : List Bool) : stAns (mkSt d a R ret stk) = a := by + simp [stAns, mkSt] + +@[simp] theorem stR_mk (d a R ret stk : List Bool) : stR (mkSt d a R ret stk) = R := by + simp [stR, mkSt] + +@[simp] theorem stRet_mk (d a R ret stk : List Bool) : stRet (mkSt d a R ret stk) = ret := by + simp [stRet, mkSt] + +@[simp] theorem stStk_mk (d a R ret stk : List Bool) : stStk (mkSt d a R ret stk) = stk := by + simp [stStk, mkSt] + +@[simp] theorem mkSt_length (d a R ret stk : List Bool) : + (mkSt d a R ret stk).length + = 2 * d.length + 2 * a.length + 2 * R.length + 2 * ret.length + stk.length + 8 := by + rw [mkSt, pair_length, pair_length, pair_length, pair_length] + omega + +/-- The head bit of the state is the done flag. -/ +theorem mkSt_headD (b : Bool) (a R ret stk : List Bool) : + (mkSt [b] a R ret stk).headD false = b := by + rw [mkSt, pair_cons_eq] + rfl + +/-- A state is never empty. -/ +theorem mkSt_ne_nil (d a R ret stk : List Bool) : mkSt d a R ret stk ≠ [] := by + intro h + have := congrArg List.length h + rw [mkSt_length] at this + simp at this + +/-! ## The readers and the constructors are polynomial-time -/ + +theorem fstBlockOf_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => fstBlock (a z)) ∈ FP := by + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + +theorem sndBlockOf_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => sndBlock (a z)) ∈ FP := by + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + +theorem frKindFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => frKind (a z)) ∈ FP := fstBlockOf_mem_FP ha + +theorem frPhFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => frPh (a z)) ∈ FP := fstBlockOf_mem_FP (sndBlockOf_mem_FP ha) + +theorem frLvlFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => frLvl (a z)) ∈ FP := + fstBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP ha)) + +theorem frUFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => frU (a z)) ∈ FP := + fstBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP ha))) + +theorem frVFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => frV (a z)) ∈ FP := + fstBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP + (sndBlockOf_mem_FP ha)))) + +theorem frMFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => frM (a z)) ∈ FP := + sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP + (sndBlockOf_mem_FP ha)))) + +theorem mkFrameFn_mem_FP {kf pf lf uf vf mf : List Bool → List Bool} + (hk : kf ∈ FP) (hp : pf ∈ FP) (hl : lf ∈ FP) (hu : uf ∈ FP) (hv : vf ∈ FP) + (hm : mf ∈ FP) : + (fun z => mkFrame (kf z) (pf z) (lf z) (uf z) (vf z) (mf z)) ∈ FP := + Cobham.pairFn_mem_FP hk (Cobham.pairFn_mem_FP hp (Cobham.pairFn_mem_FP hl + (Cobham.pairFn_mem_FP hu (Cobham.pairFn_mem_FP hv hm)))) + +theorem stkTopFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stkTop (a z)) ∈ FP := fstBlockOf_mem_FP ha + +theorem stkRestFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stkRest (a z)) ∈ FP := sndBlockOf_mem_FP ha + +theorem stDoneFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stDone (a z)) ∈ FP := fstBlockOf_mem_FP ha + +theorem stAnsFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stAns (a z)) ∈ FP := fstBlockOf_mem_FP (sndBlockOf_mem_FP ha) + +theorem stRFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stR (a z)) ∈ FP := + fstBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP ha)) + +theorem stRetFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stRet (a z)) ∈ FP := + fstBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP ha))) + +theorem stStkFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => stStk (a z)) ∈ FP := + sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP (sndBlockOf_mem_FP ha))) + +theorem mkStFn_mem_FP {df af Rf rf sf : List Bool → List Bool} + (hd : df ∈ FP) (ha : af ∈ FP) (hR : Rf ∈ FP) (hr : rf ∈ FP) (hs : sf ∈ FP) : + (fun z => mkSt (df z) (af z) (Rf z) (rf z) (sf z)) ∈ FP := + Cobham.pairFn_mem_FP hd (Cobham.pairFn_mem_FP ha (Cobham.pairFn_mem_FP hR + (Cobham.pairFn_mem_FP hr hs))) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchStep.lean b/Complexitylib/Classes/Containments/Internal/SavitchStep.lean new file mode 100644 index 00000000..50978e79 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchStep.lean @@ -0,0 +1,324 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchFrame +public import Complexitylib.Classes.Containments.Internal.CodeAccept +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble + +/-! +# One step of Savitch's stack machine + +⚠️ Unreviewed by Bolton + +The recursion of Savitch's theorem, written as a single polynomial-time function +on the stack of `Complexitylib.Classes.Containments.Internal.SavitchFrame`. + +A step does exactly one of five things. + +* **Publish** — the done flag is set, so the answer is copied into the flag the + iteration reads. +* **Finish** — the stack is empty, so the root's return value is the answer and + the done flag goes up. +* **Bottom out** — the top frame's level is zero, so its subproblem is one step + of the configuration graph; the frame is popped with its verdict. +* **Descend** — the top frame pushes the half of its interval it is currently + trying. +* **Return** — a subcall has come back: a success either advances the frame to + its second half or finishes it, and a failure advances the midpoint, giving up + when the enumeration wraps. + +## Main definitions + +- `Complexity.baseReach`, `Complexity.baseAcc` — the two base cases +- `Complexity.savStep` — one step of the recursion +- `Complexity.savInit` — the state the recursion starts from +- `Complexity.savG` — the function `SpaceIter.mem_PSPACE_of_iterate` iterates + +## Main results + +- `Complexity.savStep_mem_FP`, `Complexity.savG_mem_FP` — a step is + polynomial-time +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## Reading the state -/ + +/-- Is the string empty, as a flag. -/ +def emptyFlag (y : List Bool) : List Bool := lenLeFlag [] y + +@[simp] theorem emptyFlag_nil : emptyFlag [] = [true] := rfl + +theorem emptyFlag_cons (b : Bool) (y : List Bool) : emptyFlag (b :: y) = [false] := by + rw [emptyFlag, lenLeFlag] + simp [nonemptyFlag, notBit] + +theorem emptyFlag_pair (a b : List Bool) : emptyFlag (pair a b) = [false] := by + cases a with + | nil => rw [pair]; rfl + | cons c a => rw [pair_cons_eq]; exact emptyFlag_cons _ _ + +/-- Drop the leading bit. -/ +def dropOne (y : List Bool) : List Bool := y.drop 1 + +/-- The frame on top of the state's stack. -/ +def savTop (s : List Bool) : List Bool := stkTop (stStk s) + +/-- The stack below the top frame. -/ +def savRest (s : List Bool) : List Bool := stkRest (stStk s) + +/-- The wide ruler a whole configuration code is measured against. -/ +def savRuler (k : ℕ) (R : List Bool) : List Bool := wideRuler (codeBlocks k) R + +/-- The all-zero code: the first midpoint the enumeration tries. -/ +def savZero (k : ℕ) (R : List Bool) : List Bool := padTo (savRuler k R) [] + +@[simp] theorem savZero_length (k : ℕ) (R : List Bool) : + (savZero k R).length = codeBlocks k * R.length := by + rw [savZero, padTo_length, savRuler, wideRuler] + simp [List.length_flatten] + +/-! ## The base cases -/ + +/-- The base case of a reachability frame: `v` is `u`, or one step from it. -/ +noncomputable def baseReach (tm : NTM k) (R u v : List Bool) : List Bool := + orBit (eqFlag u v) + (orBit (eqFlag (nstepFn tm false R u) v) (eqFlag (nstepFn tm true R u) v)) + +/-- The base case of an acceptance frame: an accepting configuration is `u`, or +one step from it. -/ +noncomputable def baseAcc (tm : NTM k) (R rl u : List Bool) : List Bool := + orBit (acceptFlag (stateCode tm.qhalt) R rl u) + (orBit (acceptFlag (stateCode tm.qhalt) R rl (nstepFn tm false R u)) + (acceptFlag (stateCode tm.qhalt) R rl (nstepFn tm true R u))) + +theorem baseReach_flag (tm : NTM k) (R u v : List Bool) : + baseReach tm R u v = [true] ∨ baseReach tm R u v = [false] := by + rw [baseReach] + rcases eqFlag_flag u v with h | h <;> + rcases eqFlag_flag (nstepFn tm false R u) v with h1 | h1 <;> + rcases eqFlag_flag (nstepFn tm true R u) v with h2 | h2 <;> + rw [h, h1, h2] <;> simp [orBit] + +theorem baseAcc_flag (tm : NTM k) (R rl u : List Bool) : + baseAcc tm R rl u = [true] ∨ baseAcc tm R rl u = [false] := by + rw [baseAcc] + rcases acceptFlag_flag (stateCode tm.qhalt) R rl u with h | h <;> + rcases acceptFlag_flag (stateCode tm.qhalt) R rl (nstepFn tm false R u) with h1 | h1 <;> + rcases acceptFlag_flag (stateCode tm.qhalt) R rl (nstepFn tm true R u) with h2 | h2 <;> + rw [h, h1, h2] <;> simp [orBit] + +/-! ## The step -/ + +/-- The child the top frame pushes: the first half of its interval while its +phase is zero, the second half afterwards. -/ +noncomputable def savChild (k : ℕ) (s : List Bool) : List Bool := + selectHead (frPh (savTop s)) + (selectHead (frKind (savTop s)) + (mkFrame [true] [false] (dropOne (frLvl (savTop s))) (frM (savTop s)) + (savZero k (stR s)) (savZero k (stR s))) + (mkFrame [false] [false] (dropOne (frLvl (savTop s))) (frM (savTop s)) + (frV (savTop s)) (savZero k (stR s)))) + (mkFrame [false] [false] (dropOne (frLvl (savTop s))) (frU (savTop s)) + (frM (savTop s)) (savZero k (stR s))) + +/-- A failed subcall: try the next midpoint, or give up if the enumeration has +wrapped. -/ +noncomputable def savAdvance (s : List Bool) : List Bool := + selectHead (bumpFlag (frM (savTop s))) + (mkSt [false] (stAns s) (stR s) [false] (savRest s)) + (mkSt [false] (stAns s) (stR s) [] + (pair (mkFrame (frKind (savTop s)) [false] (frLvl (savTop s)) (frU (savTop s)) + (frV (savTop s)) (bumpCode (frM (savTop s)))) (savRest s))) + +/-- A returning subcall. -/ +noncomputable def savReturn (s : List Bool) : List Bool := + selectHead (stRet s) + (selectHead (frPh (savTop s)) + (mkSt [false] (stAns s) (stR s) [true] (savRest s)) + (mkSt [false] (stAns s) (stR s) [] + (pair (mkFrame (frKind (savTop s)) [true] (frLvl (savTop s)) (frU (savTop s)) + (frV (savTop s)) (frM (savTop s))) (savRest s)))) + (savAdvance s) + +/-- A descending step: bottom out, or push the half being tried. -/ +noncomputable def savDescend (tm : NTM k) (s : List Bool) : List Bool := + selectHead (emptyFlag (frLvl (savTop s))) + (mkSt [false] (stAns s) (stR s) + (selectHead (frKind (savTop s)) + (baseAcc tm (stR s) (savRuler k (stR s)) (frU (savTop s))) + (baseReach tm (stR s) (frU (savTop s)) (frV (savTop s)))) + (savRest s)) + (mkSt [false] (stAns s) (stR s) [] (pair (savChild k s) (stStk s))) + +/-- **One step of Savitch's recursion.** -/ +noncomputable def savStep (tm : NTM k) (s : List Bool) : List Bool := + selectHead (stDone s) + (mkSt (stAns s) (stAns s) (stR s) (stRet s) (stStk s)) + (selectHead (emptyFlag (stStk s)) + (mkSt [true] (stRet s) (stR s) (stRet s) (stStk s)) + (selectHead (emptyFlag (stRet s)) (savDescend tm s) (savReturn s))) + +/-! ## The initial state -/ + +/-- The block ruler of the window, as a function of the input. -/ +noncomputable def savR (qp : Polynomial ℕ) (x : List Bool) : List Bool := polyRuler (2 * qp + 2) x + +theorem savR_eq (qp : Polynomial ℕ) (x : List Bool) : + savR qp x = blockRuler (qp.eval x.length) := (blockRuler_eq_polyRuler qp x).symm + +/-- The state Savitch's recursion starts from: one acceptance frame, at the +top level, on the code of the initial configuration. -/ +noncomputable def savInit (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : List Bool := + mkSt [false] [false] (savR qp x) [] + (pair (mkFrame [true] [false] (polyRuler lp x) + (initRecord tm (savR qp x) x) (savZero k (savR qp x)) (savZero k (savR qp x))) []) + +/-- **The function the space-bounded iteration runs.** The running state is the +first component and the input the second, so the very first call — on +`pair [] x` — is the one that builds the initial state. -/ +noncomputable def savG (tm : NTM k) (qp lp : Polynomial ℕ) (z : List Bool) : List Bool := + pair (selectHead (emptyFlag (fstBlock z)) + (savInit tm qp lp (sndBlock z)) (savStep tm (fstBlock z))) (sndBlock z) + +@[simp] theorem savG_pair (tm : NTM k) (qp lp : Polynomial ℕ) (s x : List Bool) : + savG tm qp lp (pair s x) + = pair (selectHead (emptyFlag s) (savInit tm qp lp x) (savStep tm s)) x := by + rw [savG, fstBlock_pair, sndBlock_pair] + +theorem savG_nil (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : + savG tm qp lp (pair [] x) = pair (savInit tm qp lp x) x := by + rw [savG_pair, emptyFlag_nil, selectHead] + simp + +theorem savG_step (tm : NTM k) (qp lp : Polynomial ℕ) (s x : List Bool) (hs : s ≠ []) : + savG tm qp lp (pair s x) = pair (savStep tm s) x := by + obtain ⟨b, t, rfl⟩ : ∃ b t, s = b :: t := by + cases s with + | nil => exact absurd rfl hs + | cons b t => exact ⟨b, t, rfl⟩ + rw [savG_pair, emptyFlag_cons, selectHead] + simp + +/-! ## The step is polynomial-time -/ + +theorem emptyFlagFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => emptyFlag (a z)) ∈ FP := + lenLeFlagFn_mem_FP (constFn_mem_FP []) ha + +theorem dropOneFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => dropOne (a z)) ∈ FP := by + have := dropLenFn_mem_FP (constFn_mem_FP [false]) ha + simpa [dropOne] using this + +theorem savRulerFn_mem_FP (k : ℕ) {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => savRuler k (a z)) ∈ FP := wideRulerFn_mem_FP ha (codeBlocks k) + +theorem savZeroFn_mem_FP (k : ℕ) {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => savZero k (a z)) ∈ FP := + padToFn_mem_FP (savRulerFn_mem_FP k ha) (constFn_mem_FP []) + +theorem baseReachFn_mem_FP (tm : NTM k) {Rf uf vf : List Bool → List Bool} + (hR : Rf ∈ FP) (hu : uf ∈ FP) (hv : vf ∈ FP) : + (fun z => baseReach tm (Rf z) (uf z) (vf z)) ∈ FP := + orBitFn_mem_FP (eqFlagFn_mem_FP hu hv) + (orBitFn_mem_FP (eqFlagFn_mem_FP (nstepFnFn_mem_FP tm false hR hu) hv) + (eqFlagFn_mem_FP (nstepFnFn_mem_FP tm true hR hu) hv)) + +theorem baseAccFn_mem_FP (tm : NTM k) {Rf rlf uf : List Bool → List Bool} + (hR : Rf ∈ FP) (hrl : rlf ∈ FP) (hu : uf ∈ FP) : + (fun z => baseAcc tm (Rf z) (rlf z) (uf z)) ∈ FP := + orBitFn_mem_FP (acceptFlagFn_mem_FP _ hR hrl hu) + (orBitFn_mem_FP (acceptFlagFn_mem_FP _ hR hrl (nstepFnFn_mem_FP tm false hR hu)) + (acceptFlagFn_mem_FP _ hR hrl (nstepFnFn_mem_FP tm true hR hu))) + +theorem savStep_mem_FP (tm : NTM k) : savStep tm ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hdone := stDoneFn_mem_FP hid + have hans := stAnsFn_mem_FP hid + have hR := stRFn_mem_FP hid + have hret := stRetFn_mem_FP hid + have hstk := stStkFn_mem_FP hid + have htop : (fun z => savTop z) ∈ FP := stkTopFn_mem_FP hstk + have hrest : (fun z => savRest z) ∈ FP := stkRestFn_mem_FP hstk + have hkind := frKindFn_mem_FP htop + have hph := frPhFn_mem_FP htop + have hlvl := frLvlFn_mem_FP htop + have hu := frUFn_mem_FP htop + have hv := frVFn_mem_FP htop + have hm := frMFn_mem_FP htop + have hzero := savZeroFn_mem_FP k hR + have hchild : (fun z => savChild k z) ∈ FP := + Cobham.selectHeadFn_mem_FP hph + (Cobham.selectHeadFn_mem_FP hkind + (mkFrameFn_mem_FP (constFn_mem_FP [true]) (constFn_mem_FP [false]) + (dropOneFn_mem_FP hlvl) hm hzero hzero) + (mkFrameFn_mem_FP (constFn_mem_FP [false]) (constFn_mem_FP [false]) + (dropOneFn_mem_FP hlvl) hm hv hzero)) + (mkFrameFn_mem_FP (constFn_mem_FP [false]) (constFn_mem_FP [false]) + (dropOneFn_mem_FP hlvl) hu hm hzero) + have hadv : (fun z => savAdvance z) ∈ FP := + Cobham.selectHeadFn_mem_FP (bumpFlagFn_mem_FP hm) + (mkStFn_mem_FP (constFn_mem_FP [false]) hans hR (constFn_mem_FP [false]) hrest) + (mkStFn_mem_FP (constFn_mem_FP [false]) hans hR (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (mkFrameFn_mem_FP hkind (constFn_mem_FP [false]) hlvl hu hv + (bumpCodeFn_mem_FP hm)) hrest)) + have hreturn : (fun z => savReturn z) ∈ FP := + Cobham.selectHeadFn_mem_FP hret + (Cobham.selectHeadFn_mem_FP hph + (mkStFn_mem_FP (constFn_mem_FP [false]) hans hR (constFn_mem_FP [true]) hrest) + (mkStFn_mem_FP (constFn_mem_FP [false]) hans hR (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (mkFrameFn_mem_FP hkind (constFn_mem_FP [true]) hlvl hu hv hm) hrest))) + hadv + have hdescend : (fun z => savDescend tm z) ∈ FP := + Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hlvl) + (mkStFn_mem_FP (constFn_mem_FP [false]) hans hR + (Cobham.selectHeadFn_mem_FP hkind + (baseAccFn_mem_FP tm hR (savRulerFn_mem_FP k hR) hu) + (baseReachFn_mem_FP tm hR hu hv)) hrest) + (mkStFn_mem_FP (constFn_mem_FP [false]) hans hR (constFn_mem_FP []) + (Cobham.pairFn_mem_FP hchild hstk)) + exact Cobham.selectHeadFn_mem_FP hdone + (mkStFn_mem_FP hans hans hR hret hstk) + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hstk) + (mkStFn_mem_FP (constFn_mem_FP [true]) hret hR hret hstk) + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hret) hdescend hreturn)) + +theorem savRFn_mem_FP (qp : Polynomial ℕ) {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => savR qp (a z)) ∈ FP := polyRulerFn_mem_FP (2 * qp + 2) ha + +theorem savInitFn_mem_FP (tm : NTM k) (qp lp : Polynomial ℕ) + {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => savInit tm qp lp (a z)) ∈ FP := by + have hR : (fun z => savR qp (a z)) ∈ FP := savRFn_mem_FP qp ha + have hzero : (fun z => savZero k (savR qp (a z))) ∈ FP := savZeroFn_mem_FP k hR + exact mkStFn_mem_FP (constFn_mem_FP [false]) (constFn_mem_FP [false]) hR + (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (mkFrameFn_mem_FP (constFn_mem_FP [true]) (constFn_mem_FP [false]) + (polyRulerFn_mem_FP lp ha) (initRecordFn_mem_FP tm hR ha) hzero hzero) + (constFn_mem_FP [])) + +theorem savG_mem_FP (tm : NTM k) (qp lp : Polynomial ℕ) : savG tm qp lp ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst := fstBlockOf_mem_FP hid + have hsnd := sndBlockOf_mem_FP hid + have hstep : (fun z => savStep tm (fstBlock z)) ∈ FP := by + have := mem_FP_comp hfst (savStep_mem_FP tm) + simpa [Function.comp] using this + exact Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hfst) + (savInitFn_mem_FP tm qp lp hsnd) hstep) hsnd + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SpaceIterate.lean b/Complexitylib/Classes/Containments/Internal/SpaceIterate.lean new file mode 100644 index 00000000..94b0156a --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SpaceIterate.lean @@ -0,0 +1,1292 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal.Iterate +public import Complexitylib.Classes.Containments.Internal.PPTest +public import Complexitylib.Classes.Containments.Internal.PPBody +public import Complexitylib.Classes.Containments.Internal.PPLayout +public import Complexitylib.Models.TuringMachine.Hoare.StartInvariant +public import Complexitylib.Classes.Containments.Internal.PolyWindow + +/-! +# Iterating a polynomial-time function in polynomial space + +⚠️ Unreviewed by Bolton + +A language decided by iterating a polynomial-time function on a polynomially +bounded state is in `PSPACE`, however many iterations it takes: the state is the +only thing that has to be stored, and the iteration count lives in a binary +counter of polynomially many bits. This is the machine-independent way into +`PSPACE`, the counterpart of what Cobham's theorem does for `P` — and it is what +Savitch's theorem needs, since Savitch's recursion is a stack machine whose step +is polynomial-time and whose stack is polynomially bounded. + +The machine reuses the iteration machinery of +`Complexitylib.Classes.P.Cobham.Internal.Iterate` wholesale, on that file's own +layout: `Cobham.iterSetup` puts `pair [] x` in place, `Cobham.iterTail` builds +the entry shape, and `Cobham.iterBody` applies the function once and restores +it. Only the loop driver changes. `TM.forRegTM` counts in unary, which cannot +reach `2 ^ poly`, so the loop here is `TM.loopTM`, as in `PP ⊆ PSPACE` and +`PH ⊆ PSPACE`. + +## No tape is added + +Two of the layout's tapes are free for the loop's own use, so the machine needs +no tapes beyond the ones `Cobham.iterBody` already has — and therefore no +placement, and no parking of tapes a placement would freeze. + +* `Cobham.resIdx`, the result tape, is blank at the start of every iteration: + `TM.applyPre` puts `parkedBlank` there. That is the source the verdict cell is + cleared from. +* `Cobham.rfIdx`, the fuel register of the unary loop that is not running here, + is held fixed by `Cobham.iterBody` whatever it contains. That is where the + iteration counter lives. + +The machine never reads the counter: it is there so that +`TM.loopTM_hoareTime_indexed` can read the iteration index off the tapes for its +termination measure, which is why it may be binary and cost only polynomially +many cells. + +## The loop's shape + +The programmed function signals completion by putting a `1` at the head of its +state, and the loop's test is `TM.writeOutputBitTM` reading the state tape's +first cell — so the loop runs until the computation says it is done, and the +number of iterations never has to be represented. One more application after the +loop puts the verdict at the head of the state, and a second +`TM.writeOutputBitTM` publishes it. + +## Main definitions + +- `Complexity.SpaceIter.slotOf` — the verdict cell as a tape +- `Complexity.SpaceIter.headSym` — the symbol at the head of a state +- `Complexity.SpaceIter.iterBank` — the tape family of an iteration +- `Complexity.SpaceIter.bodyTM`, `testTM` — the loop +- `Complexity.SpaceIter.prologueTM`, `epilogueTM` — the two ends +- `Complexity.SpaceIter.spaceIterTM` — the whole machine +- `Complexity.SpaceIter.windowBound` — the polynomial window it keeps + +## Main results + +- `Complexity.SpaceIter.bodyTM_hoareTime` — one pass applies the function once +- `Complexity.SpaceIter.testTM_hoareTime` — the test publishes the state's head +- `Complexity.SpaceIter.loop_hoareTime` — the loop runs until the state is done +- `Complexity.SpaceIter.loop_keepsWindowOn` — one pass' width bounds the whole loop +- `Complexity.SpaceIter.spaceIterTM_hoareTime` — the machine publishes the answer +- `Complexity.SpaceIter.spaceIterTM_keepsWindow` — and keeps a polynomial window +- `Complexity.SpaceIter.mem_PSPACE_of_iterate` — so the language it decides is in + `PSPACE` +-/ + +@[expose] public section + +namespace Complexity + +namespace SpaceIter + +open TM + +variable {k : ℕ} + +/-! ## The verdict cell -/ + +/-- The output tape holding `s` in its verdict cell. -/ +def slotOf (s : Γ) : Tape := parkedBlank.write s + +@[simp] theorem slotOf_head (s : Γ) : (slotOf s).head = 1 := by + rw [slotOf, Tape.write_head] + rfl + +@[simp] theorem slotOf_cells_one (s : Γ) : (slotOf s).cells 1 = s := by + rw [slotOf, Tape.write, if_neg (by show ¬ (1 : ℕ) = 0; omega)] + show Function.update parkedBlank.cells parkedBlank.head s 1 = s + rw [show parkedBlank.head = 1 from rfl] + exact Function.update_self (β := fun _ => Γ) 1 s parkedBlank.cells + +theorem slotOf_cells_of_ne (s : Γ) {c : ℕ} (hc : c ≠ 1) : + (slotOf s).cells c = parkedBlank.cells c := by + rw [slotOf, Tape.write, if_neg (by show ¬ (1 : ℕ) = 0; omega)] + exact Function.update_of_ne (by simpa using hc) _ _ + +@[simp] theorem slotOf_write (s t : Γ) : (slotOf s).write t = slotOf t := by + refine Tape.ext (by rw [Tape.write_head, slotOf_head, slotOf_head]) (funext fun c => ?_) + by_cases hc : c = 1 + · subst hc + rw [Tape.write, if_neg (by show ¬ (slotOf s).head = 0; rw [slotOf_head]; omega)] + show Function.update (slotOf s).cells (slotOf s).head t 1 = _ + rw [slotOf_head, Function.update_self, slotOf_cells_one] + · rw [Tape.write, if_neg (by show ¬ (slotOf s).head = 0; rw [slotOf_head]; omega)] + show Function.update (slotOf s).cells (slotOf s).head t c = _ + rw [slotOf_head, Function.update_of_ne (by simpa using hc), + slotOf_cells_of_ne s hc, slotOf_cells_of_ne t hc] + +@[simp] theorem slotOf_blank : slotOf Γ.blank = parkedBlank := by + refine Tape.ext (by rw [slotOf_head]; rfl) (funext fun c => ?_) + by_cases hc : c = 1 + · subst hc + rw [slotOf_cells_one] + exact (parkedBlank_cells 1).symm + · exact slotOf_cells_of_ne Γ.blank hc + +theorem slotOf_startInvariant (s : Γ) (hs : s ≠ Γ.start) : + Tape.StartInvariant (slotOf s) := by + refine ⟨?_, fun c hc => ?_⟩ + · rw [slotOf_cells_of_ne s (by omega)] + exact startInvariant_initNil.1 + · by_cases hc1 : c = 1 + · subst hc1 + rw [slotOf_cells_one] + exact hs + · rw [slotOf_cells_of_ne s hc1] + exact startInvariant_initNil.2 c (by omega) + +theorem slotOf_parked (s : Γ) (hs : s ≠ Γ.start) : Parked (slotOf s) := by + refine ⟨by rw [slotOf_head], fun c hc => ?_⟩ + by_cases hc1 : c = 1 + · subst hc1 + rw [slotOf_cells_one] + exact hs + · rw [slotOf_cells_of_ne s hc1] + exact parked_parkedBlank.2 c (by omega) + +/-! ## The symbol at the head of a state -/ + +/-- The symbol at the head of a state tape: the state's first bit, or blank. -/ +def headSym (y : List Bool) : Γ := ((y.map Γ.ofBool)[0]?).getD Γ.blank + +@[simp] theorem headSym_nil : headSym [] = Γ.blank := rfl + +@[simp] theorem headSym_cons (b : Bool) (y : List Bool) : + headSym (b :: y) = Γ.ofBool b := rfl + +theorem headSym_eq_one_iff (y : List Bool) : + (readBackWrite (headSym y)).toΓ = Γ.one ↔ y.headD false = true := by + cases y with + | nil => simp [headSym, readBackWrite] + | cons b y => cases b <;> simp [headSym, readBackWrite, Γ.ofBool, Γw.toΓ] + +theorem toΓ_readBackWrite_ne_start (g : Γ) : (readBackWrite g).toΓ ≠ Γ.start := by + cases g <;> simp [readBackWrite, Γw.toΓ] + +/-! ## Reading the iteration index off the tapes + +`TM.loopTM_hoareTime_indexed` needs the iteration index as a function of the +configuration, for its termination measure. The counter carries it; this is the +ghost read, and nothing computes it. -/ + +theorem natTape_startInvariant (v : ℕ) : Tape.StartInvariant (natTape v) := + ⟨NTM.natTape_cells_zero v, fun j hj => (natTape_parked v).2 j hj⟩ + +theorem natTape_head_one (v : ℕ) : (natTape v).head = 1 := + (Tape.init_move_right_hasBinaryNat v).2.1 + +open Classical in +/-- The value a canonical binary register holds. -/ +noncomputable def ctrValue (t : Tape) : ℕ := + if h : ∃ v, t = natTape v then h.choose else 0 + +@[simp] theorem ctrValue_natTape (v : ℕ) : ctrValue (natTape v) = v := by + classical + have hex : ∃ w, natTape v = natTape w := ⟨v, rfl⟩ + rw [ctrValue, dif_pos hex] + generalize hgen : hex.choose = w + have hc : natTape v = natTape w := hgen ▸ hex.choose_spec + refine hasBinaryNat_value_unique (t := natTape v) ?_ (Tape.init_move_right_hasBinaryNat v) + rw [hc] + exact Tape.init_move_right_hasBinaryNat w + +/-- The loop's index function: how far the counter has advanced past `start`. +The input and output tapes are ignored, but `TM.loopTM_hoareTime_indexed` takes +the index as a function of the whole configuration, so they have to be there. -/ +@[nolint unusedArguments] +noncomputable def loopIdx (k start : ℕ) : + Tape → (Fin (3 + (k + 2) + 0) → Tape) → Tape → ℕ := + fun _ work _ => ctrValue (work rfIdx) - start + +/-! ## The tapes of an iteration -/ + +/-- The tape family at an iteration: the entry shape for `y` on the application +block, the counter on the fuel register, and the two fixed tapes. -/ +noncomputable def iterBank (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (H c : ℕ) : Fin (3 + (k + 2) + 0) → Tape := + fun i => if hi : placeWorkInMiddle 3 (k + 2) i + then TM.applyPre M y inp₀ (placeWorkCoord 3 (k + 2) i hi) + else bookTapes (natTape c) junkT H i + +@[simp] theorem iterBank_app (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) + (j : Fin (k + 2)) : + iterBank M y inp₀ junkT H c (appIdx j) = TM.applyPre M y inp₀ j := by + rw [iterBank, dif_pos (appIdx_middle j)] + congr 1 + exact placeWorkCoord_placeWorkIdx 3 0 j + +theorem iterBank_book (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) + (i : Fin (3 + (k + 2) + 0)) (hi : ¬ placeWorkInMiddle 3 (k + 2) i) : + iterBank M y inp₀ junkT H c i = bookTapes (natTape c) junkT H i := by + rw [iterBank, dif_neg hi] + +@[simp] theorem iterBank_rf (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) : + iterBank M y inp₀ junkT H c rfIdx = natTape c := by + rw [iterBank_book M y inp₀ junkT H c rfIdx rfIdx_not_middle, bookTapes_rf] + +@[simp] theorem iterBank_wf (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) : + iterBank M y inp₀ junkT H c wfIdx = regTape H := by + rw [iterBank_book M y inp₀ junkT H c wfIdx wfIdx_not_middle, bookTapes_wf] + +@[simp] theorem iterBank_junk (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) : + iterBank M y inp₀ junkT H c junkIdx = junkT := by + rw [iterBank_book M y inp₀ junkT H c junkIdx junkIdx_not_middle, bookTapes_junk] + +@[simp] theorem iterBank_res (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) : + iterBank M y inp₀ junkT H c resIdx = parkedBlank := by + rw [resIdx, iterBank_app, TM.applyPre, Fin.snoc_last] + +theorem iterBank_parked (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (hjunkP : Parked junkT) (H c : ℕ) (i : Fin (3 + (k + 2) + 0)) : + Parked (iterBank M y inp₀ junkT H c i) := by + rcases Complexity.layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, iterBank_rf] + exact natTape_parked c + · rw [h, iterBank_wf] + exact parked_regTape H + · rw [h, iterBank_junk] + exact hjunkP + · rw [h, iterBank_app] + exact ⟨le_of_eq (TM.applyPre_head M y inp₀ j).symm, + fun c hc => (TM.applyPre_startInvariant M y inp₀ j).2 c hc⟩ + +/-- Every tape of the bank is parked at cell one. -/ +theorem iterBank_head (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (hjunkh : junkT.head ≤ 1) (H c : ℕ) (i : Fin (3 + (k + 2) + 0)) : + (iterBank M y inp₀ junkT H c i).head ≤ 1 := by + rcases Complexity.layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, iterBank_rf, natTape_head_one] + · rw [h, iterBank_wf] + exact le_of_eq (regT_head H) + · rw [h, iterBank_junk] + exact hjunkh + · rw [h, iterBank_app] + exact le_of_eq (TM.applyPre_head M y inp₀ j) + +/-- A block family is the iteration bank as soon as it has the right tapes. -/ +theorem iterBank_eq (M : TM k) (z : List Bool) (inp₀ junkT : Tape) (H c : ℕ) + (W : Fin (3 + (k + 2) + 0) → Tape) + (happ : ∀ j, W (appIdx j) = TM.applyPre M z inp₀ j) + (hrf : W rfIdx = natTape c) (hwf : W wfIdx = regTape H) (hjunk : W junkIdx = junkT) : + W = iterBank M z inp₀ junkT H c := by + funext i + rcases Complexity.layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, hrf, iterBank_rf] + · rw [h, hwf, iterBank_wf] + · rw [h, hjunk, iterBank_junk] + · rw [h, happ j, iterBank_app] + +/-- A parked bank survives a phase boundary. -/ +theorem iterBank_trans (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (hjunkP : Parked junkT) (H c : ℕ) : + (fun i => transitionTape (iterBank M y inp₀ junkT H c i)) + = iterBank M y inp₀ junkT H c := by + funext i + exact transitionTape_eq_self (iterBank_parked M y inp₀ junkT hjunkP H c i).read_ne_start + +/-- The counter is the only tape that changes when the count does. -/ +theorem iterBank_succ (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) : + iterBank M y inp₀ junkT H (c + 1) + = Function.update (iterBank M y inp₀ junkT H c) rfIdx (natTape (c + 1)) := by + funext i + by_cases hi : i = rfIdx + · rw [hi, Function.update_self, iterBank_rf] + · rw [Function.update_of_ne hi, iterBank, iterBank] + by_cases hm : placeWorkInMiddle 3 (k + 2) i + · rw [dif_pos hm, dif_pos hm] + · rw [dif_neg hm, dif_neg hm] + rcases Complexity.layout_cases i with h | h | h | ⟨j, h⟩ + · exact absurd h hi + · rw [h, bookTapes_wf, bookTapes_wf] + · rw [h, bookTapes_junk, bookTapes_junk] + · exact absurd (h ▸ appIdx_middle j) hm + +/-! ## The machine -/ + +/-- The loop body: clear the verdict cell, apply the function once, bump the +counter. -/ +def bodyTM (M : TM k) : TM (3 + (k + 2) + 0) := + seqTM (seqTM (writeOutputBitTM resIdx) (iterBody M)) (binarySuccTM rfIdx) + +/-- The loop test: publish the head symbol of the state. -/ +def testTM (k : ℕ) : TM (3 + (k + 2) + 0) := writeOutputBitTM (vinIdx (k := k)) + +/-! ## The body's contract -/ + +/-- **Clearing the verdict cell**, from the blank result tape. -/ +theorem clear_hoareTime (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hjunkP : Parked junkT) (H c : ℕ) (s : Γ) + (hs : s ≠ Γ.start) : + (writeOutputBitTM (resIdx (k := k))).HoareTime + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = slotOf s) + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = parkedBlank) 1 := by + have hread : (iterBank M y inp₀ junkT H c (resIdx (k := k))).read = Γ.blank := by + rw [iterBank_res] + show parkedBlank.cells parkedBlank.head = Γ.blank + rw [parkedBlank_cells] + rfl + refine (writeOutputBitTM_hoareTime_frame (resIdx (k := k)) inp₀ + (iterBank M y inp₀ junkT H c) (slotOf s) hinpP + (fun i => iterBank_parked M y inp₀ junkT hjunkP H c i) + (slotOf_parked s hs)).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, hw, ?_⟩ + rw [ho, hread, show (readBackWrite Γ.blank).toΓ = Γ.blank from rfl, slotOf_write, + slotOf_blank] + +/-- **Applying the function once.** -/ +theorem apply_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (y : List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H c : ℕ) + (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) (hGy : (G y).length + 1 ≤ H) : + (iterBody M).HoareTime + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ work = iterBank M (G y) inp₀ junkT H c ∧ + out = parkedBlank) + (T y.length + 1 + tailBound k H (G y).length) := by + have hbody := iterBody_hoareTime M hcomp H y hHy hHT hGy inp₀ hinpP hinpSI + (natTape c) junkT (natTape_parked c) (natTape_startInvariant c) hjunkP hjunkSI + refine (hbody.weaken_pre ?_).strengthen_post ?_ + · rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, ho, fun j => by rw [hw, iterBank_app], by rw [hw, iterBank_rf], + by rw [hw, iterBank_wf], by rw [hw, iterBank_junk]⟩ + · rintro inp work out ⟨hi, ho, hrf, hjunk, hwf, happ⟩ + exact ⟨hi, iterBank_eq M (G y) inp₀ junkT H c work happ hrf hwf hjunk, ho⟩ + +/-- **Bumping the counter.** -/ +theorem bump_hoareTime (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hjunkP : Parked junkT) (H c : ℕ) : + (binarySuccTM (rfIdx (k := k))).HoareTime + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H (c + 1) ∧ + out = parkedBlank) + (binarySuccTime c) := by + refine (binarySuccTM_hoareTime_pinned (rfIdx (k := k)) c inp₀ + (iterBank M y inp₀ junkT H c) parkedBlank (iterBank_rf M y inp₀ junkT H c) + hinpP.read_ne_start + (fun i _ => (iterBank_parked M y inp₀ junkT hjunkP H c i).read_ne_start) + parked_parkedBlank.read_ne_start).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, by rw [hw, iterBank_succ], ho⟩ + +/-- **The loop body's contract.** -/ +theorem bodyTM_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (y : List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H c : ℕ) + (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) (hGy : (G y).length + 1 ≤ H) + (s : Γ) (hs : s ≠ Γ.start) : + (bodyTM M).HoareTime + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = slotOf s) + (fun inp work out => inp = inp₀ ∧ + work = iterBank M (G y) inp₀ junkT H (c + 1) ∧ out = parkedBlank) + (1 + 1 + (T y.length + 1 + tailBound k H (G y).length) + 1 + binarySuccTime c) := by + have htrans : ∀ (z : List Bool) (d : ℕ), ∀ inp work out, + (inp = inp₀ ∧ work = iterBank M z inp₀ junkT H d ∧ out = parkedBlank) → + (transitionInput inp = inp₀ ∧ + (fun i' => transitionTape (work i')) = iterBank M z inp₀ junkT H d ∧ + transitionTape out = parkedBlank) := by + rintro z d inp work out ⟨hi, hw, ho⟩ + refine ⟨by rw [hi, transitionInput_eq_self hinpP.read_ne_start], ?_, ?_⟩ + · rw [hw, iterBank_trans M z inp₀ junkT hjunkP H d] + · rw [ho] + exact transitionTape_eq_self parked_parkedBlank.read_ne_start + refine seqTM_hoareTime _ _ + (seqTM_hoareTime _ _ + (mid' := fun inp work out => inp = inp₀ ∧ + work = iterBank M y inp₀ junkT H c ∧ out = parkedBlank) + (clear_hoareTime M y inp₀ junkT hinpP hjunkP H c s hs) + (htrans y c) + (apply_hoareTime M hcomp y inp₀ junkT hinpP hinpSI hjunkP hjunkSI H c hHy hHT hGy)) + (mid' := fun inp work out => inp = inp₀ ∧ + work = iterBank M (G y) inp₀ junkT H c ∧ out = parkedBlank) + (htrans (G y) c) + (bump_hoareTime M (G y) inp₀ junkT hinpP hjunkP H c) + +/-! ## The test's contract -/ + +/-- The state tape of a bank reads the state's first symbol. -/ +theorem iterBank_vin_read (M : TM k) (y : List Bool) (inp₀ junkT : Tape) (H c : ℕ) : + (iterBank M y inp₀ junkT H c (vinIdx (k := k))).read = headSym y := by + rw [vinIdx, iterBank_app, TM.applyPre, Fin.snoc_castSucc] + show ((TM.retargetInputStartedCfg M y inp₀).work (Fin.last k)).read = headSym y + rw [show (Fin.last k) = (⟨k, by omega⟩ : Fin (k + 1)) from rfl, + TM.retargetInputStartedCfg_work_last] + show (Tape.init (y.map Γ.ofBool)).cells ((Tape.init (y.map Γ.ofBool)).move Dir3.right).head + = headSym y + rw [show ((Tape.init (y.map Γ.ofBool)).move Dir3.right).head = 1 from rfl, + show (1 : ℕ) = 0 + 1 from rfl, Tape.init_cells_succ] + rfl + +/-- **The loop's test.** It publishes the state's first symbol; the programmed +function signals completion by putting a `1` there. -/ +theorem testTM_hoareTime (M : TM k) (y : List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hjunkP : Parked junkT) (H c : ℕ) : + (testTM k).HoareTime + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = slotOf (readBackWrite (headSym y)).toΓ) 1 := by + refine (writeOutputBitTM_hoareTime_frame (vinIdx (k := k)) inp₀ + (iterBank M y inp₀ junkT H c) parkedBlank hinpP + (fun i => iterBank_parked M y inp₀ junkT hjunkP H c i) + parked_parkedBlank).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, hw, ?_⟩ + rw [ho, iterBank_vin_read] + rfl + +/-! ## The loop -/ + +/-- The verdict cell at the start of a pass: blank before the first test, the +previous test's verdict afterwards. -/ +def slotSym (Y : ℕ → List Bool) (j : ℕ) : Γ := + if j = 0 then Γ.blank else (readBackWrite (headSym (Y j))).toΓ + +theorem slotSym_ne_start (Y : ℕ → List Bool) (j : ℕ) : slotSym Y j ≠ Γ.start := by + rw [slotSym] + split + · exact fun h => Γ.noConfusion h + · exact toΓ_readBackWrite_ne_start _ + +/-- The loop's state after `j` passes, with the counter offset by its starting +value. -/ +noncomputable def loopState (M : TM k) (Y : ℕ → List Bool) (inp₀ junkT : Tape) + (H start j : ℕ) : TapePred (3 + (k + 2) + 0) := + fun inp work out => inp = inp₀ ∧ + work = iterBank M (Y j) inp₀ junkT H (start + j) ∧ out = slotOf (slotSym Y j) + +theorem loopState_parked (M : TM k) (Y : ℕ → List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hjunkP : Parked junkT) (H start j : ℕ) : + ∀ inp work out, loopState M Y inp₀ junkT H start j inp work out → + LoopParked inp work out := by + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [hi]; exact hinpP + · intro i; rw [hw] + exact iterBank_parked M (Y j) inp₀ junkT hjunkP H (start + j) i + · rw [ho]; exact slotOf_parked _ (slotSym_ne_start Y j) + · rw [ho] + exact (slotOf_startInvariant _ (slotSym_ne_start Y j)).1 + · rw [ho]; exact slotOf_head _ + +/-- The tapes between the body and the test of a pass: the entry shape for the next +state, with the verdict cell cleared. -/ +noncomputable def midState (M : TM k) (Y : ℕ → List Bool) (inp₀ junkT : Tape) + (H start j : ℕ) : TapePred (3 + (k + 2) + 0) := + fun inp work out => inp = inp₀ ∧ + work = iterBank M (Y (j + 1)) inp₀ junkT H (start + (j + 1)) ∧ out = parkedBlank + +/-- **The body of a pass** applies the function once and bumps the counter. -/ +theorem body_pass (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (Y : ℕ → List Bool) (hY : ∀ i, Y (i + 1) = G (Y i)) + (inp₀ junkT : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H start N : ℕ) + (hHy : ∀ i, i ≤ N → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i < N → 1 + T (Y i).length ≤ H) + (j : ℕ) (hj : j < N) : + (bodyTM M).HoareTime (loopState M Y inp₀ junkT H start j) + (midState M Y inp₀ junkT H start j) + (1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (start + j)) := by + have hGy : (G (Y j)).length + 1 ≤ H := by + rw [← hY j] + exact hHy (j + 1) (by omega) + have hbody := bodyTM_hoareTime M hcomp (Y j) inp₀ junkT hinpP hinpSI hjunkP hjunkSI + H (start + j) (by have := hHy j (by omega); omega) (hHT j hj) hGy + (slotSym Y j) (slotSym_ne_start Y j) + rw [← hY j] at hbody + refine (hbody.weaken_pre ?_).strengthen_post ?_ + · rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, hw, ho⟩ + · rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ?_, ho⟩ + rw [hw, show start + j + 1 = start + (j + 1) from by omega] + +/-- The tapes between the body and the test are parked. -/ +theorem midState_parked (M : TM k) (Y : ℕ → List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hjunkP : Parked junkT) (H start j : ℕ) : + ∀ inp work out, midState M Y inp₀ junkT H start j inp work out → + LoopParked inp work out := by + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [hi]; exact hinpP + · intro i; rw [hw] + exact iterBank_parked M (Y (j + 1)) inp₀ junkT hjunkP H (start + (j + 1)) i + · rw [ho]; exact parked_parkedBlank + · rw [ho] + exact (startInvariant_initNil.move Dir3.right).1 + · rw [ho]; rfl + +/-- **The test of a pass** publishes the next state's head symbol. -/ +theorem test_pass (M : TM k) (Y : ℕ → List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hjunkP : Parked junkT) (H start j : ℕ) : + (testTM k).HoareTime (midState M Y inp₀ junkT H start j) + (loopState M Y inp₀ junkT H start (j + 1)) 1 := by + refine (testTM_hoareTime M (Y (j + 1)) inp₀ junkT hinpP hjunkP H + (start + (j + 1))).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, hw, ?_⟩ + rw [ho, slotSym, if_neg (by omega)] + +/-- **One pass of the loop.** The body applies the function once, and the test finds the +state not yet done, so the loop comes back to its start state one iteration on. -/ +theorem loop_pass (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (Y : ℕ → List Bool) (hY : ∀ i, Y (i + 1) = G (Y i)) + (inp₀ junkT : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H start N : ℕ) + (hHy : ∀ i, i ≤ N → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i < N → 1 + T (Y i).length ≤ H) + (hcont : ∀ i, 0 < i → i < N → (Y i).headD false = false) (b : ℕ) + (hb : ∀ j, j < N → + 1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (start + j) + 1 + 5 ≤ b) : + ∀ j, j < N - 1 → ∀ inp work out, loopState M Y inp₀ junkT H start j inp work out → + ∃ inp' work' out' t, 1 ≤ t ∧ t ≤ b ∧ + (loopTM (bodyTM M) (testTM k)).reachesIn t + ⟨(loopTM (bodyTM M) (testTM k)).qstart, inp, work, out⟩ + ⟨(loopTM (bodyTM M) (testTM k)).qstart, inp', work', out'⟩ ∧ + loopState M Y inp₀ junkT H start (j + 1) inp' work' out' := by + intro j hj inp work out hE + have hjN : j < N := by omega + have hcontinue := loopTM_continue_of_hoare _ _ + (body_pass M hcomp Y hY inp₀ junkT hinpP hinpSI hjunkP hjunkSI H start N hHy hHT j hjN) + (test_pass M Y inp₀ junkT hinpP hjunkP H start j) + (midState_parked M Y inp₀ junkT hinpP hjunkP H start j) ?_ inp work out hE + · obtain ⟨inp', work', out', t, h1t, ht, hreach, hE'⟩ := hcontinue + exact ⟨inp', work', out', t, h1t, le_trans ht (hb j hjN), hreach, hE'⟩ + rintro inp' work' out' hE' + refine ⟨loopState_parked M Y inp₀ junkT hinpP hjunkP H start (j + 1) inp' work' out' hE', + ?_⟩ + obtain ⟨-, -, ho⟩ := hE' + rw [ho, slotOf_cells_one, slotSym, if_neg (by omega)] + intro hcon + have hhd := (headSym_eq_one_iff (Y (j + 1))).mp hcon + rw [hcont (j + 1) (by omega) (by omega)] at hhd + exact Bool.noConfusion hhd + +/-- **The last pass of the loop.** The body applies the function one final time, and the +test finds the state done, so the loop halts. -/ +theorem loop_final (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (Y : ℕ → List Bool) (hY : ∀ i, Y (i + 1) = G (Y i)) + (inp₀ junkT : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H start N : ℕ) + (hN : 1 ≤ N) + (hHy : ∀ i, i ≤ N → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i < N → 1 + T (Y i).length ≤ H) + (hdone : (Y N).headD false = true) (b : ℕ) + (hb : ∀ j, j < N → + 1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (start + j) + 1 + 5 ≤ b) : + ∀ inp work out, loopState M Y inp₀ junkT H start (N - 1) inp work out → + ∃ c' t, t ≤ b ∧ + (loopTM (bodyTM M) (testTM k)).reachesIn t + ⟨(loopTM (bodyTM M) (testTM k)).qstart, inp, work, out⟩ c' ∧ + (loopTM (bodyTM M) (testTM k)).halted c' ∧ + loopState M Y inp₀ junkT H start N c'.input c'.work c'.output := by + intro inp work out hE + have hlast : N - 1 + 1 = N := by omega + have hhalt := loopTM_halt_of_hoare _ _ + (body_pass M hcomp Y hY inp₀ junkT hinpP hinpSI hjunkP hjunkSI H start N hHy hHT + (N - 1) (by omega)) + (test_pass M Y inp₀ junkT hinpP hjunkP H start (N - 1)) + (midState_parked M Y inp₀ junkT hinpP hjunkP H start (N - 1)) ?_ inp work out hE + · obtain ⟨c', t, ht, hreach, hhlt, hpost⟩ := hhalt + refine ⟨c', t, le_trans ht (hb (N - 1) (by omega)), hreach, hhlt, ?_⟩ + rw [← hlast] + exact hpost + rintro inp' work' out' hE' + refine ⟨loopState_parked M Y inp₀ junkT hinpP hjunkP H start (N - 1 + 1) inp' work' + out' hE', ?_⟩ + obtain ⟨-, -, ho⟩ := hE' + rw [ho, slotOf_cells_one, slotSym, if_neg (by omega), hlast] + exact (headSym_eq_one_iff (Y N)).mpr hdone + +/-- **The loop's contract.** The loop runs until the state says it is done: `N` +passes, each applying the function once. -/ +theorem loop_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (Y : ℕ → List Bool) (hY : ∀ i, Y (i + 1) = G (Y i)) + (inp₀ junkT : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H start N : ℕ) + (hN : 1 ≤ N) + (hHy : ∀ i, i ≤ N → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i < N → 1 + T (Y i).length ≤ H) + (hcont : ∀ i, 0 < i → i < N → (Y i).headD false = false) + (hdone : (Y N).headD false = true) (b : ℕ) + (hb : ∀ j, j < N → + 1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (start + j) + 1 + 5 ≤ b) : + (loopTM (bodyTM M) (testTM k)).HoareTime + (loopState M Y inp₀ junkT H start 0) (loopState M Y inp₀ junkT H start N) + ((N - 1 + 1) * b) := by + refine loopTM_hoareTime_indexed _ _ (idx := loopIdx k start) ?_ ?_ ?_ + · rintro j inp work out ⟨hi, hw, ho⟩ + rw [loopIdx, hw, iterBank_rf, ctrValue_natTape] + omega + · intro j hj inp work out hE + obtain ⟨inp', work', out', t, -, ht, hreach, hE'⟩ := + loop_pass M hcomp Y hY inp₀ junkT hinpP hinpSI hjunkP hjunkSI H start N hHy hHT + hcont b hb j hj inp work out hE + exact ⟨inp', work', out', t, ht, hreach, hE'⟩ + · exact loop_final M hcomp Y hY inp₀ junkT hinpP hinpSI hjunkP hjunkSI H start N hN + hHy hHT hdone b hb + +/-- **The loop's window.** Every configuration the loop passes through lies within one +pass of an indexed state, and each indexed state has every head parked at cell one, so a +window one pass wide holds for the whole run — however many passes it takes. -/ +theorem loop_keepsWindowOn (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (Y : ℕ → List Bool) (hY : ∀ i, Y (i + 1) = G (Y i)) + (inp₀ junkT : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H start N : ℕ) + (hN : 1 ≤ N) + (hHy : ∀ i, i ≤ N → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i < N → 1 + T (Y i).length ≤ H) + (hcont : ∀ i, 0 < i → i < N → (Y i).headD false = false) + (hdone : (Y N).headD false = true) (b : ℕ) + (hb : ∀ j, j < N → + 1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (start + j) + 1 + 5 ≤ b) + (lx h₀ : ℕ) (hh₀ : 1 ≤ h₀) (hinph : inp₀.head ≤ lx + h₀ + 1) + (hjunkh : junkT.head ≤ 1) : + (loopTM (bodyTM M) (testTM k)).KeepsWindowOn + (fun c => c.state = (loopTM (bodyTM M) (testTM k)).qstart ∧ + loopState M Y inp₀ junkT H start 0 c.input c.work c.output) lx (h₀ + b) := by + have hkw := loopTM_keepsWindow_indexed (bodyTM M) (testTM k) + (inputLength := lx) (space := h₀ + b) + (loopState M Y inp₀ junkT H start) (N - 1) b + (loop_pass M hcomp Y hY inp₀ junkT hinpP hinpSI hjunkP hjunkSI H start N hHy hHT + hcont b hb) + (fun inp work out hE => by + obtain ⟨c', t, ht, hreach, hhlt, -⟩ := + loop_final M hcomp Y hY inp₀ junkT hinpP hinpSI hjunkP hjunkSI H start N hN + hHy hHT hdone b hb inp work out hE + exact ⟨c', t, ht, hreach, hhlt⟩) + (fun j _ inp work out hE c t ht hreach => by + obtain ⟨hi, hw, ho⟩ := hE + obtain ⟨hbi, hbo, hbw⟩ := + head_le_start_add_of_reachesIn (loopTM (bodyTM M) (testTM k)) hreach + dsimp only at hbi hbo hbw + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have h1 := hbw i + have h2 : (work i).head ≤ 1 := by + rw [hw] + exact iterBank_head M (Y j) inp₀ junkT hjunkh H (start + j) i + omega + · have h1 := hbi + have h2 : inp.head ≤ lx + h₀ + 1 := by rw [hi]; exact hinph + omega + · have h1 := hbo + have h2 : out.head ≤ 1 := by rw [ho]; exact le_of_eq (slotOf_head _) + omega) + rintro c ⟨hst, hE⟩ c' hreach + refine hkw 0 (by omega) c.input c.work c.output hE c' ?_ + rwa [show (⟨(loopTM (bodyTM M) (testTM k)).qstart, c.input, c.work, c.output⟩ : + Cfg (3 + (k + 2) + 0) _) = c from Cfg.ext hst.symm rfl rfl rfl] + + + +/-! ## The prologue + +`Cobham.iterSetup` puts `pair [] x` on the result tape with the bookkeeping +registers loaded, and `Cobham.iterTail` turns that into the entry shape the loop +starts from — exactly the two phases `Cobham.iterTM` opens with. -/ + +/-- The prologue: the setup, then the tail that builds the entry shape. -/ +def prologueTM (k : ℕ) (p : Polynomial ℕ) : TM (3 + (k + 2) + 0) := + seqTM (iterSetup k p) (iterTail k) + +/-- The prologue's running time, which is also the width its window needs. -/ +def proBound (k : ℕ) (p : Polynomial ℕ) (H n : ℕ) : ℕ := + setupBound p n + 1 + tailBound k H (n + 2) + +theorem one_le_proBound (k : ℕ) (p : Polynomial ℕ) (H n : ℕ) : + 1 ≤ proBound k p H n := by + rw [proBound] + omega + +/-- The counter's starting value. `Cobham.iterSetup` leaves `|x|` in unary on the +fuel register, and a unary register of `n` ones read as a binary numeral is +`2 ^ n - 1`. -/ +def startCount (n : ℕ) : ℕ := 2 ^ n - 1 + +theorem regTape_eq_natTape_startCount (n : ℕ) : regTape n = natTape (startCount n) := + NTM.regTape_eq_natTape n + +/-- **The prologue's contract.** From the initial configuration's tapes it reaches +the loop's entry state for `pair [] x`, with the counter at `startCount |x|`. -/ +theorem prologueTM_hoareTime (M : TM k) (p : Polynomial ℕ) (x : List Bool) (H : ℕ) + (hH : H = p.eval x.length) (hHx : x.length + 4 ≤ H) : + (prologueTM k p).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (pair [] x) inp (regTape H) H (startCount x.length) ∧ + out = parkedBlank) + (proBound k p H x.length) := by + rw [proBound] + have hplen : (pair [] x).length = x.length + 2 := by + rw [pair_length] + simp + omega + have hsetup := iterSetup_hoareTime (k := k) p x H hH hHx + -- the seam: the setup's post, pushed through the phase boundary, is the tail's pre + have hseam : ∀ (inp : Tape) (work : Fin (3 + (k + 2) + 0) → Tape) (out : Tape), + (Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + work rfIdx = regTape x.length ∧ work wfIdx = regTape H ∧ + work junkIdx = regTape H) → + (Parked (transitionInput inp) ∧ Tape.StartInvariant (transitionInput inp) ∧ + transitionTape out = parkedBlank ∧ + ((fun i => transitionTape (work i)) resIdx).HasOutput (pair [] x) ∧ + (∀ j : Fin (k + 2), + Tape.StartInvariant ((fun i => transitionTape (work i)) (appIdx j)) ∧ + ((fun i => transitionTape (work i)) (appIdx j)).head ≤ H ∧ + ∀ c, H < c → ((fun i => transitionTape (work i)) (appIdx j)).cells c = Γ.blank) ∧ + (fun i => transitionTape (work i)) rfIdx = regTape x.length ∧ + (fun i => transitionTape (work i)) wfIdx = regTape H ∧ + (fun i => transitionTape (work i)) junkIdx = regTape H) := by + rintro inp work out ⟨hinpSI, rfl, hres, hbnd, hrf, hwf, hjunk⟩ + dsimp only + have hinpEq : transitionInput inp = (⟨max inp.head 1, inp.cells⟩ : Tape) := + move_idleDir_eq_of_startInvariant hinpSI + refine ⟨?_, ?_, transitionTape_eq_self parked_parkedBlank.read_ne_start, ?_, + fun j => ⟨?_, ?_, ?_⟩, ?_, ?_, ?_⟩ + · rw [hinpEq]; exact ⟨le_max_right _ _, fun c hc => hinpSI.2 c hc⟩ + · rw [hinpEq]; exact ⟨hinpSI.1, fun c hc => hinpSI.2 c hc⟩ + · exact (Tape.hasOutput_congr + (transitionTape_cells _ (fun c hc => (hbnd (Fin.last (k + 1))).1.2 c hc)).symm _).mp hres + · refine ⟨?_, fun c hc => ?_⟩ + · rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).1.1 + · rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).1.2 c hc + · rw [transitionTape_of_startInvariant (hbnd j).1] + show max (work (appIdx j)).head 1 ≤ H + have := (hbnd j).2.1 + omega + · intro c hc + rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).2.2 c hc + · show transitionTape (work rfIdx) = regTape x.length + rw [hrf]; exact transitionTape_eq_self (parked_regTape _).read_ne_start + · show transitionTape (work wfIdx) = regTape H + rw [hwf]; exact transitionTape_eq_self (parked_regTape H).read_ne_start + · show transitionTape (work junkIdx) = regTape H + rw [hjunk]; exact transitionTape_eq_self (parked_regTape H).read_ne_start + have htail : (iterTail k).HoareTime + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + work rfIdx = regTape x.length ∧ work wfIdx = regTape H ∧ + work junkIdx = regTape H) + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (pair [] x) inp (regTape H) H (startCount x.length) ∧ + out = parkedBlank) + (tailBound k H (x.length + 2)) := by + rintro inp work out ⟨hP, hSI, ho, hres, hbnd, hrf, hwf, hjunk⟩ + obtain ⟨c', t, ht, hreach, hhalt, hi', ho', hrf', hjunk', hwf', happ'⟩ := + iterTail_hoareTime M H (pair [] x) (by omega) inp hP hSI (regTape x.length) + (regTape H) (parked_regTape _) (startInvariant_regTape _) (parked_regTape H) + (startInvariant_regTape H) inp work out ⟨rfl, ho, hres, hbnd, hrf, hwf, hjunk⟩ + refine ⟨c', t, by rw [hplen] at ht; exact ht, hreach, hhalt, by rw [hi']; exact hP, + by rw [hi']; exact hSI, ?_, ho'⟩ + refine iterBank_eq M (pair [] x) c'.input (regTape H) H (startCount x.length) c'.work + (fun j => by rw [happ' j, hi']) ?_ hwf' hjunk' + rw [hrf', regTape_eq_natTape_startCount] + exact seqTM_hoareTime _ _ hsetup hseam htail + + +/-! ## The epilogue + +The loop leaves the state saying it is done; one more application turns that +state into the one whose head is the answer, and one more publication puts it in +the verdict cell. -/ + +theorem headSym_eq_zero_iff {y : List Bool} (hy : y ≠ []) : + (readBackWrite (headSym y)).toΓ = Γ.zero ↔ y.headD false = false := by + cases y with + | nil => exact absurd rfl hy + | cons b y => cases b <;> simp [headSym, readBackWrite, Γ.ofBool, Γw.toΓ] + +/-- The epilogue: one more application, then publish the state's head. -/ +def epilogueTM (M : TM k) : TM (3 + (k + 2) + 0) := seqTM (bodyTM M) (testTM k) + +/-- **The epilogue's contract.** -/ +theorem epilogueTM_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (y : List Bool) (inp₀ junkT : Tape) + (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) (H c : ℕ) + (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) (hGy : (G y).length + 1 ≤ H) + (s : Γ) (hs : s ≠ Γ.start) : + (epilogueTM M).HoareTime + (fun inp work out => inp = inp₀ ∧ work = iterBank M y inp₀ junkT H c ∧ + out = slotOf s) + (fun inp work out => inp = inp₀ ∧ + work = iterBank M (G y) inp₀ junkT H (c + 1) ∧ + out = slotOf (readBackWrite (headSym (G y))).toΓ) + (1 + 1 + (T y.length + 1 + tailBound k H (G y).length) + 1 + binarySuccTime c + + 1 + 1) := by + refine seqTM_hoareTime _ _ + (bodyTM_hoareTime M hcomp y inp₀ junkT hinpP hinpSI hjunkP hjunkSI H c hHy hHT hGy s hs) + ?_ (testTM_hoareTime M (G y) inp₀ junkT hinpP hjunkP H (c + 1)) + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨by rw [hi, transitionInput_eq_self hinpP.read_ne_start], ?_, ?_⟩ + · rw [hw, iterBank_trans M (G y) inp₀ junkT hjunkP H (c + 1)] + · rw [ho] + exact transitionTape_eq_self parked_parkedBlank.read_ne_start + +/-! ## The whole machine -/ + +/-- The iteration machine: prologue, loop, epilogue. -/ +def spaceIterTM (M : TM k) (p : Polynomial ℕ) : TM (3 + (k + 2) + 0) := + seqTM (seqTM (prologueTM k p) (loopTM (bodyTM M) (testTM k))) (epilogueTM M) + +/-- **The whole machine's contract.** From the initial tapes on `x` it halts with +the head symbol of `Y (N + 1)` in the verdict cell, where `Y` is the orbit of the +programmed function through `pair [] x` and `N` is the first positive index at +which the state says it is done. -/ +theorem spaceIterTM_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (p : Polynomial ℕ) (x : List Bool) (H : ℕ) + (hH : H = p.eval x.length) (hHx : x.length + 4 ≤ H) + (Y : ℕ → List Bool) (hY0 : Y 0 = pair [] x) (hY : ∀ i, Y (i + 1) = G (Y i)) + (N : ℕ) (hN : 1 ≤ N) + (hHy : ∀ i, i ≤ N + 1 → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i ≤ N → 1 + T (Y i).length ≤ H) + (hcont : ∀ i, 0 < i → i < N → (Y i).headD false = false) + (hdone : (Y N).headD false = true) (b : ℕ) + (hb : ∀ j, j ≤ N → + 1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (startCount x.length + j) + 1 + 5 ≤ b) : + (spaceIterTM M p).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => out = slotOf (readBackWrite (headSym (Y (N + 1)))).toΓ) + (proBound k p H x.length + 1 + (N - 1 + 1) * b + 1 + b) := by + set start := startCount x.length with hstart + set junkT : Tape := regTape H with hjunkT + have hjunkP : Parked junkT := parked_regTape H + have hjunkSI : Tape.StartInvariant junkT := startInvariant_regTape H + -- the loop, with the input tape read off the configuration + have hloop : (loopTM (bodyTM M) (testTM k)).HoareTime + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (Y 0) inp junkT H start ∧ out = parkedBlank) + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (Y N) inp junkT H (start + N) ∧ + out = slotOf (slotSym Y N)) ((N - 1 + 1) * b) := by + rintro inp work out ⟨hP, hSI, hw, ho⟩ + obtain ⟨c', t, ht, hreach, hhalt, hi', hw', ho'⟩ := + loop_hoareTime M hcomp Y hY inp junkT hP hSI hjunkP hjunkSI H start N hN + (fun i hi => hHy i (by omega)) (fun i hi => hHT i (by omega)) hcont hdone b + (fun j hj => hb j (by omega)) inp work out + ⟨rfl, by rw [hw, show start + 0 = start from rfl], + by rw [ho, slotSym, if_pos rfl, slotOf_blank]⟩ + exact ⟨c', t, ht, hreach, hhalt, by rw [hi']; exact hP, by rw [hi']; exact hSI, + by rw [hw', hi'], ho'⟩ + -- the epilogue, likewise + have hepi : (epilogueTM M).HoareTime + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (Y N) inp junkT H (start + N) ∧ + out = slotOf (slotSym Y N)) + (fun _inp _work out => out = slotOf (readBackWrite (headSym (Y (N + 1)))).toΓ) b := by + rintro inp work out ⟨hP, hSI, hw, ho⟩ + obtain ⟨c', t, ht, hreach, hhalt, -, -, ho'⟩ := + epilogueTM_hoareTime M hcomp (Y N) inp junkT hP hSI hjunkP hjunkSI H (start + N) + (by have := hHy N (by omega); omega) (hHT N le_rfl) + (by rw [← hY N]; exact hHy (N + 1) le_rfl) (slotSym Y N) (slotSym_ne_start Y N) + inp work out ⟨rfl, hw, ho⟩ + refine ⟨c', t, le_trans ht ?_, hreach, hhalt, ?_⟩ + · have := hb N le_rfl + rw [← hY N] + omega + · rw [ho', hY N] + -- the two seams + have hseam1 : ∀ inp work out, + (Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (pair [] x) inp junkT H start ∧ out = parkedBlank) → + (Parked (transitionInput inp) ∧ Tape.StartInvariant (transitionInput inp) ∧ + (fun i => transitionTape (work i)) = + iterBank M (Y 0) (transitionInput inp) junkT H start ∧ + transitionTape out = parkedBlank) := by + rintro inp work out ⟨hP, hSI, hw, ho⟩ + rw [transitionInput_eq_self hP.read_ne_start] + refine ⟨hP, hSI, ?_, ?_⟩ + · rw [hw, hY0, iterBank_trans M (pair [] x) inp junkT hjunkP H start] + · rw [ho] + exact transitionTape_eq_self parked_parkedBlank.read_ne_start + have hseam2 : ∀ inp work out, + (Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (Y N) inp junkT H (start + N) ∧ out = slotOf (slotSym Y N)) → + (Parked (transitionInput inp) ∧ Tape.StartInvariant (transitionInput inp) ∧ + (fun i => transitionTape (work i)) = + iterBank M (Y N) (transitionInput inp) junkT H (start + N) ∧ + transitionTape out = slotOf (slotSym Y N)) := by + rintro inp work out ⟨hP, hSI, hw, ho⟩ + rw [transitionInput_eq_self hP.read_ne_start] + refine ⟨hP, hSI, ?_, ?_⟩ + · rw [hw, iterBank_trans M (Y N) inp junkT hjunkP H (start + N)] + · rw [ho] + exact transitionTape_eq_self + (slotOf_parked _ (slotSym_ne_start Y N)).read_ne_start + exact seqTM_hoareTime _ _ + (seqTM_hoareTime _ _ (prologueTM_hoareTime M p x H hH hHx) hseam1 hloop) hseam2 hepi + + +/-! ## The machine's window + +The prologue and the epilogue are short, so their windows come from their running +times. The loop's does not — it runs for as long as the programmed computation +does — but every configuration it passes through is within one pass of an indexed +state whose heads are all parked, so one pass' width is enough. -/ + +/-- A halting contract, read as a reachability fact about a configuration already in +the machine's start state. -/ +theorem hoarePostOf {m : ℕ} {tm : TM m} {pre post : TapePred m} {bnd : ℕ} + (h : tm.HoareTime pre post bnd) (c : Cfg m tm.Q) (hst : c.state = tm.qstart) + (hpre : pre c.input c.work c.output) : + ∃ e, tm.reaches c e ∧ tm.halted e ∧ post e.input e.work e.output := by + obtain ⟨e, t, -, hreach, hhalt, hpost⟩ := h c.input c.work c.output hpre + refine ⟨e, ?_, hhalt, hpost⟩ + rw [show (⟨tm.qstart, c.input, c.work, c.output⟩ : Cfg m tm.Q) = c from + Cfg.ext hst.symm rfl rfl rfl] at hreach + exact reaches_of_reachesIn hreach + +/-- **The whole machine's window.** -/ +theorem spaceIterTM_keepsWindow (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (p : Polynomial ℕ) (x : List Bool) (H : ℕ) + (hH : H = p.eval x.length) (hHx : x.length + 4 ≤ H) + (Y : ℕ → List Bool) (hY0 : Y 0 = pair [] x) (hY : ∀ i, Y (i + 1) = G (Y i)) + (N : ℕ) (hN : 1 ≤ N) + (hHy : ∀ i, i ≤ N + 1 → (Y i).length + 1 ≤ H) + (hHT : ∀ i, i ≤ N → 1 + T (Y i).length ≤ H) + (hcont : ∀ i, 0 < i → i < N → (Y i).headD false = false) + (hdone : (Y N).headD false = true) (b : ℕ) + (hb : ∀ j, j ≤ N → + 1 + 1 + (T (Y j).length + 1 + tailBound k H (Y (j + 1)).length) + 1 + + binarySuccTime (startCount x.length + j) + 1 + 5 ≤ b) + (W : ℕ) (hW : proBound k p H x.length + 1 + b ≤ W) : + ∀ c, (spaceIterTM M p).reaches ((spaceIterTM M p).initCfg x) c → + c.WithinDecisionSpace x.length W := by + have hproB1 : 1 ≤ proBound k p H x.length := one_le_proBound k p H x.length + have hs : 1 ≤ W := by omega + set junkT : Tape := regTape H with hjunkTdef + have hjunkP : Parked junkT := parked_regTape H + have hjunkSI : Tape.StartInvariant junkT := startInvariant_regTape H + have hjunkh : junkT.head ≤ 1 := le_of_eq (regT_head H) + set st := startCount x.length with hstdef + -- the prologue, with the head bounds the downstream stages need + have hproHT : (prologueTM k p).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => (Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (pair [] x) inp junkT H st ∧ out = parkedBlank) ∧ + (∀ i, (work i).head ≤ 0 + proBound k p H x.length) ∧ + inp.head ≤ 0 + proBound k p H x.length ∧ + out.head ≤ 0 + proBound k p H x.length) + (proBound k p H x.length) := + (prologueTM_hoareTime M p x H hH hHx).headBound 0 + (by + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨fun i => by rw [hw]; exact le_of_eq (Tape.init_head _), + by rw [hi]; exact le_of_eq (Tape.init_head _), + by rw [ho]; exact le_of_eq (Tape.init_head _)⟩) + -- the loop, from the tapes the prologue leaves + have hloopHT : (loopTM (bodyTM M) (testTM k)).HoareTime + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + inp.head ≤ proBound k p H x.length ∧ + work = iterBank M (Y 0) inp junkT H st ∧ out = parkedBlank) + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + inp.head ≤ proBound k p H x.length ∧ + work = iterBank M (Y N) inp junkT H (st + N) ∧ out = slotOf (slotSym Y N)) + ((N - 1 + 1) * b) := by + rintro inp work out ⟨hP, hSI, hhead, hw, ho⟩ + obtain ⟨c', t, ht, hreach, hhalt, hi', hw', ho'⟩ := + loop_hoareTime M hcomp Y hY inp junkT hP hSI hjunkP hjunkSI H st N hN + (fun i hi => hHy i (by omega)) (fun i hi => hHT i (by omega)) hcont hdone b + (fun j hj => hb j (by omega)) inp work out + ⟨rfl, by rw [hw, show st + 0 = st from rfl], + by rw [ho, slotSym, if_pos rfl, slotOf_blank]⟩ + exact ⟨c', t, ht, hreach, hhalt, by rw [hi']; exact hP, by rw [hi']; exact hSI, + by rw [hi']; exact hhead, by rw [hw', hi'], ho'⟩ + -- the prologue and the loop, as one contract + have hAHT : (seqTM (prologueTM k p) (loopTM (bodyTM M) (testTM k))).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + inp.head ≤ proBound k p H x.length ∧ + work = iterBank M (Y N) inp junkT H (st + N) ∧ out = slotOf (slotSym Y N)) + (proBound k p H x.length + 1 + (N - 1 + 1) * b) := by + refine seqTM_hoareTime _ _ hproHT ?_ hloopHT + rintro inp work out ⟨⟨hP, hSI, hw, ho⟩, hwh, hih, hoh⟩ + rw [transitionInput_eq_self hP.read_ne_start] + refine ⟨hP, hSI, by omega, ?_, ?_⟩ + · rw [hw, hY0, iterBank_trans M (pair [] x) inp junkT hjunkP H st] + · rw [ho] + exact transitionTape_eq_self parked_parkedBlank.read_ne_start + -- the three windows + have w1 : (prologueTM k p).KeepsWindowOn + (fun c => c.state = (prologueTM k p).qstart ∧ + (c.input = Tape.init (x.map Γ.ofBool) ∧ c.work = (fun _ => Tape.init []) ∧ + c.output = Tape.init [])) x.length W := + (keepsWindowOn_of_hoareTime (prologueTM_hoareTime M p x H hH hHx) + (inputLength := x.length) (h₀ := 0) + (fun inp work out hpre i => by rw [hpre.2.1]; exact le_of_eq (Tape.init_head _)) + (fun inp work out hpre => by rw [hpre.1, Tape.init_head]; omega) + (fun inp work out hpre => by rw [hpre.2.2, Tape.init_head]; omega)).mono_space + (by omega) + have w2 : (loopTM (bodyTM M) (testTM k)).KeepsWindowOn + (fun c => c.state = (loopTM (bodyTM M) (testTM k)).qstart ∧ Parked c.input ∧ + Tape.StartInvariant c.input ∧ c.input.head ≤ proBound k p H x.length ∧ + c.work = iterBank M (Y 0) c.input junkT H st ∧ c.output = parkedBlank) + x.length W := by + rintro c ⟨hst, hP, hSI, hhead, hw, ho⟩ c' hreach + refine (loop_keepsWindowOn M hcomp Y hY c.input junkT hP hSI hjunkP hjunkSI H st N hN + (fun i hi => hHy i (by omega)) (fun i hi => hHT i (by omega)) hcont hdone b + (fun j hj => hb j (by omega)) x.length (proBound k p H x.length + 1) (by omega) (by omega) + hjunkh).mono_space (by omega) c ⟨hst, rfl, ?_, ?_⟩ c' hreach + · rw [hw, show st + 0 = st from rfl] + · rw [ho, slotSym, if_pos rfl, slotOf_blank] + have w3 : (epilogueTM M).KeepsWindowOn + (fun c => c.state = (epilogueTM M).qstart ∧ Parked c.input ∧ + Tape.StartInvariant c.input ∧ c.input.head ≤ proBound k p H x.length ∧ + c.work = iterBank M (Y N) c.input junkT H (st + N) ∧ + c.output = slotOf (slotSym Y N)) x.length W := by + rintro c ⟨hst, hP, hSI, hhead, hw, ho⟩ c' hreach + have hbN := hb N le_rfl + refine (keepsWindowOn_of_hoareTime + (epilogueTM_hoareTime M hcomp (Y N) c.input junkT hP hSI hjunkP hjunkSI H (st + N) + (by have := hHy N (by omega); omega) (hHT N le_rfl) + (by rw [← hY N]; exact hHy (N + 1) le_rfl) (slotSym Y N) (slotSym_ne_start Y N)) + (inputLength := x.length) (h₀ := proBound k p H x.length) + (fun inp work out hpre i => by + rw [hpre.2.1] + exact le_trans (iterBank_head M (Y N) c.input junkT hjunkh H (st + N) i) hproB1) + (fun inp work out hpre => by rw [hpre.1]; omega) + (fun inp work out hpre => by + rw [hpre.2.2, slotOf_head] + omega)).mono_space ?_ c ⟨hst, rfl, hw, ho⟩ c' hreach + rw [← hY N] + omega + -- compose + have cA := seqTM_keepsWindowOn (prologueTM k p) (loopTM (bodyTM M) (testTM k)) hs + (mid := fun inp work out => (Parked inp ∧ Tape.StartInvariant inp ∧ + work = iterBank M (pair [] x) inp junkT H st ∧ out = parkedBlank) ∧ + (∀ i, (work i).head ≤ 0 + proBound k p H x.length) ∧ + inp.head ≤ 0 + proBound k p H x.length ∧ + out.head ≤ 0 + proBound k p H x.length) + (fun c hc => by + obtain ⟨hi, hw, ho⟩ := hc.2 + refine ⟨hc.1, ⟨⟨fun i => by rw [hw, Tape.init_head]; omega, + by rw [hi, Tape.init_head]; omega⟩, by rw [ho, Tape.init_head]; omega⟩, + ?_, ?_, ?_⟩ + · rw [hi]; exact Tape.StartInvariant.init_ofBool x + · intro i; rw [hw]; exact Tape.StartInvariant.init_nil + · rw [ho]; exact Tape.StartInvariant.init_nil) + w1 (fun c hc => hoarePostOf hproHT c hc.1 hc.2) w2 + (fun inp work out h => by + obtain ⟨⟨hP, hSI, hw, ho⟩, hwh, hih, hoh⟩ := h + rw [transitionInput_eq_self hP.read_ne_start] + refine ⟨rfl, hP, hSI, ?_, ?_, ?_⟩ + · show inp.head ≤ proBound k p H x.length + omega + · rw [hw, hY0, iterBank_trans M (pair [] x) inp junkT hjunkP H st] + · rw [ho] + exact transitionTape_eq_self parked_parkedBlank.read_ne_start) + have cB := seqTM_keepsWindowOn (seqTM (prologueTM k p) (loopTM (bodyTM M) (testTM k))) + (epilogueTM M) hs + (mid := fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ + inp.head ≤ proBound k p H x.length ∧ + work = iterBank M (Y N) inp junkT H (st + N) ∧ out = slotOf (slotSym Y N)) + (fun c hc => by + obtain ⟨d, hd, rfl⟩ := hc + obtain ⟨hi, hw, ho⟩ := hd.2 + refine ⟨by + rw [show (phase1Wrap (prologueTM k p) (loopTM (bodyTM M) (testTM k)) d).state + = Sum.inl d.state from rfl, hd.1] + rfl, ⟨⟨fun i => ?_, ?_⟩, ?_⟩, ?_, ?_, ?_⟩ + · show (d.work i).head ≤ W + rw [hw, Tape.init_head]; omega + · show d.input.head ≤ x.length + W + 1 + rw [hi, Tape.init_head]; omega + · show d.output.head ≤ W + 1 + rw [ho, Tape.init_head]; omega + · show Tape.StartInvariant d.input + rw [hi]; exact Tape.StartInvariant.init_ofBool x + · show ∀ i, Tape.StartInvariant (d.work i) + intro i; rw [hw]; exact Tape.StartInvariant.init_nil + · show Tape.StartInvariant d.output + rw [ho]; exact Tape.StartInvariant.init_nil) + cA + (fun c hc => by + obtain ⟨d, hd, rfl⟩ := hc + exact hoarePostOf hAHT _ (by + rw [show (phase1Wrap (prologueTM k p) (loopTM (bodyTM M) (testTM k)) d).state + = Sum.inl d.state from rfl, hd.1] + rfl) hd.2) + w3 + (fun inp work out h => by + obtain ⟨hP, hSI, hhead, hw, ho⟩ := h + rw [transitionInput_eq_self hP.read_ne_start] + refine ⟨rfl, hP, hSI, hhead, ?_, ?_⟩ + · rw [hw, iterBank_trans M (Y N) inp junkT hjunkP H (st + N)] + · rw [ho] + exact transitionTape_eq_self (slotOf_parked _ (slotSym_ne_start Y N)).read_ne_start) + intro c hreach + refine cB _ ⟨phase1Wrap (prologueTM k p) (loopTM (bodyTM M) (testTM k)) + ⟨(prologueTM k p).qstart, Tape.init (x.map Γ.ofBool), fun _ => Tape.init [], + Tape.init []⟩, + ⟨⟨(prologueTM k p).qstart, Tape.init (x.map Γ.ofBool), fun _ => Tape.init [], + Tape.init []⟩, ⟨rfl, rfl, rfl, rfl⟩, rfl⟩, rfl⟩ c hreach + + +/-! ## Iterating a polynomial-time function in polynomial space + +Everything above is stated for an explicit `H`, `N` and per-pass bound `b`. Here +they are supplied: `H` is the padding polynomial of `Cobham.iterTM`, `b` is one +pass' running time, and the window is their sum — a polynomial, because the only +unbounded quantity, the iteration count, enters only through the *number of bits* +of the counter. -/ + +/-- One pass' running time, as a function of the input length: an application of +the programmed function, the tail that restores the entry shape, and an increment +of a counter of `n + w(n) + 1` bits. -/ +def passBound (k : ℕ) (tp p r w : Polynomial ℕ) (n : ℕ) : ℕ := + 1 + 1 + (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n)) + 1 + + (2 * (n + w.eval n + 1) + 2) + 1 + 5 + +/-- The machine's window: the prologue, and one pass. -/ +def windowBound (k : ℕ) (tp p r w : Polynomial ℕ) (n : ℕ) : ℕ := + proBound k p (p.eval n) n + 1 + passBound k tp p r w n + +theorem polyBound_windowBound (k : ℕ) (tp p r w : Polynomial ℕ) : + PolyBound (windowBound k tp p r w) := by + have hcomp : PolyBound (fun n => tp.eval (r.eval n)) := + PolyBound.mono (PolyBound.eval (tp.comp r)) + (fun n => le_of_eq (by rw [Polynomial.eval_comp])) + have hr : PolyBound (fun n => r.eval n) := PolyBound.eval r + have hw : PolyBound (fun n => w.eval n) := PolyBound.eval w + have hpass : PolyBound (passBound k tp p r w) := by + rw [show passBound k tp p r w = fun n => + 1 + 1 + (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n)) + 1 + + (2 * (n + w.eval n + 1) + 2) + 1 + 5 from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.add hcomp (PolyBound.const _)) + (polyBound_tailBound k p _ hr))) (PolyBound.const _)) + (PolyBound.add (PolyBound.mul (PolyBound.const 2) + (PolyBound.add (PolyBound.add PolyBound.id hw) (PolyBound.const _))) + (PolyBound.const _))) (PolyBound.const _)) (PolyBound.const _) + rw [show windowBound k tp p r w = fun n => + setupBound p n + 1 + tailBound k (p.eval n) (n + 2) + 1 + passBound k tp p r w n from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (polyBound_setupBound p) (PolyBound.const _)) + (polyBound_tailBound k p _ (PolyBound.add PolyBound.id (PolyBound.const _)))) + (PolyBound.const _)) hpass + +/-- The counter never exceeds `2 ^ (n + w n + 1)`, so it takes `n + w n + 1` bits. -/ +theorem startCount_add_size_le (n j W : ℕ) (hj : j ≤ 2 ^ W) : + (startCount n + j).size ≤ n + W + 1 := by + refine Nat.size_le.mpr ?_ + have h1 : startCount n < 2 ^ n := by + rw [startCount] + have : 1 ≤ 2 ^ n := Nat.one_le_two_pow + omega + have h2 : (2 : ℕ) ^ n ≤ 2 ^ (n + W) := Nat.pow_le_pow_right (by norm_num) (by omega) + have h3 : (2 : ℕ) ^ W ≤ 2 ^ (n + W) := Nat.pow_le_pow_right (by norm_num) (by omega) + have h4 : (2 : ℕ) ^ (n + W + 1) = 2 ^ (n + W) + 2 ^ (n + W) := by ring + omega + +/-- **Iterating a polynomial-time function on a polynomially bounded state is in +`PSPACE`**, however many iterations it takes. The function is applied to +`pair [] x` over and over; it signals completion by putting a `1` at the head of +its state, and the head of the state one application later is the answer. -/ +theorem mem_PSPACE_of_iterate {L : Language} {G : List Bool → List Bool} + (hG : G ∈ FP) (r w : Polynomial ℕ) (Nof : List Bool → ℕ) + (hlen : ∀ (x : List Bool) (i : ℕ), i ≤ Nof x + 1 → + (G^[i] (pair [] x)).length ≤ r.eval x.length) + (hN1 : ∀ x : List Bool, 1 ≤ Nof x) + (hNw : ∀ x : List Bool, Nof x ≤ 2 ^ w.eval x.length) + (hcont : ∀ (x : List Bool) (i : ℕ), 0 < i → i < Nof x → + (G^[i] (pair [] x)).headD false = false) + (hdone : ∀ x : List Bool, (G^[Nof x] (pair [] x)).headD false = true) + (hne : ∀ x : List Bool, G^[Nof x + 1] (pair [] x) ≠ []) + (hans : ∀ x : List Bool, x ∈ L ↔ (G^[Nof x + 1] (pair [] x)).headD false = true) : + L ∈ PSPACE := by + obtain ⟨k, M, tp, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hG + set p : Polynomial ℕ := + Polynomial.X + Polynomial.C 4 + r + Polynomial.C 1 + tp.comp r + Polynomial.C 1 with hpdef + have hpeval : ∀ n, p.eval n = n + 4 + r.eval n + 1 + tp.eval (r.eval n) + 1 := by + intro n + rw [hpdef] + simp [Polynomial.eval_comp] + obtain ⟨q, hq⟩ := polyBound_windowBound k tp p r w + -- the standing instances of the two contracts above, at a fixed input + have key : ∀ x : List Bool, + (∀ i, i ≤ Nof x + 1 → (G^[i] (pair [] x)).length + 1 ≤ p.eval x.length) ∧ + (∀ i, i ≤ Nof x → 1 + tp.eval (G^[i] (pair [] x)).length ≤ p.eval x.length) ∧ + (∀ j, j ≤ Nof x → + 1 + 1 + (tp.eval (G^[j] (pair [] x)).length + 1 + + tailBound k (p.eval x.length) (G^[j + 1] (pair [] x)).length) + 1 + + binarySuccTime (startCount x.length + j) + 1 + 5 ≤ + passBound k tp p r w x.length) := by + intro x + have hmono : ∀ i, i ≤ Nof x + 1 → + tp.eval (G^[i] (pair [] x)).length ≤ tp.eval (r.eval x.length) := fun i hi => + polynomial_eval_mono_nat tp (hlen x i hi) + refine ⟨fun i hi => by have := hlen x i hi; have := hpeval x.length; omega, + fun i hi => by have := hmono i (by omega); have := hpeval x.length; omega, + fun j hj => ?_⟩ + have h1 := hmono j (by omega) + have h2 := tailBound_mono k (p.eval x.length) (hlen x (j + 1) (by omega)) + have h3 : binarySuccTime (startCount x.length + j) ≤ + 2 * (x.length + w.eval x.length + 1) + 2 := by + have h4 := binarySuccTime_le (startCount x.length + j) + have h5 := startCount_add_size_le x.length j (w.eval x.length) + (le_trans hj (hNw x)) + omega + rw [passBound] + omega + refine mem_PSPACE_of_polyWindow (spaceIterTM M p) q (fun x c' hreach => ?_) (fun x => ?_) + · obtain ⟨hHy, hHT, hb⟩ := key x + exact spaceIterTM_keepsWindow M hcomp p x (p.eval x.length) rfl + (by have := hpeval x.length; omega) (fun i => G^[i] (pair [] x)) (by simp) + (fun i => Function.iterate_succ_apply' G i (pair [] x)) (Nof x) (hN1 x) hHy hHT + (hcont x) (hdone x) (passBound k tp p r w x.length) hb (q.eval x.length) + (hq x.length) c' hreach + · obtain ⟨hHy, hHT, hb⟩ := key x + obtain ⟨c', t, -, hreach, hhalt, hpost⟩ := + spaceIterTM_hoareTime M hcomp p x (p.eval x.length) rfl + (by have := hpeval x.length; omega) (fun i => G^[i] (pair [] x)) (by simp) + (fun i => Function.iterate_succ_apply' G i (pair [] x)) (Nof x) (hN1 x) hHy hHT + (hcont x) (hdone x) (passBound k tp p r w x.length) hb + (Tape.init (x.map Γ.ofBool)) (fun _ => Tape.init []) (Tape.init []) ⟨rfl, rfl, rfl⟩ + refine ⟨c', reaches_of_reachesIn hreach, hhalt, fun hx => ?_, fun hx => ?_⟩ + · rw [hpost, slotOf_cells_one] + exact (headSym_eq_one_iff _).mpr ((hans x).mp hx) + · rw [hpost, slotOf_cells_one] + refine (headSym_eq_zero_iff (hne x)).mpr ?_ + cases hbb : (G^[Nof x + 1] (pair [] x)).headD false with + | false => rfl + | true => exact absurd ((hans x).mpr hbb) hx + +end SpaceIter + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/TallyLoopIndexed.lean b/Complexitylib/Classes/Containments/Internal/TallyLoopIndexed.lean new file mode 100644 index 00000000..3ffe4e8b --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/TallyLoopIndexed.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PPParts + +/-! +# A counting loop whose resting tapes change with the count + +⚠️ Unreviewed by Bolton + +`NTM.tallyLoop_hoareTime_of_hoare` pins the tapes the tally state does not name to one bank, the +same at every index. That is right for a loop whose only state is its counters — the path-counting +machine of `PP ⊆ PSPACE` — but not for one carrying something alongside them. + +The witness enumerator of `PH ⊆ PSPACE` is such a loop: its witness tape advances with the +counter, so the bank it rests in is a function of the count. These are the same two rules with +that bank indexed; the proofs are unchanged apart from the index. + +## Main results + +- `NTM.tallyLoop_hoareTime_of_hoare_indexed` — the loop's contract, with an indexed resting bank +- `NTM.tallyLoop_keepsWindow_of_hoare_indexed` — its window, one iteration wide +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +/-- **The counting loop, with a bank that changes with the count.** -/ +theorem tallyLoop_hoareTime_of_hoare_indexed {n : ℕ} (tmBody tmTest : TM n) + (cIdx aIdx rIdx : Fin n) + (I : Tape) (rest : ℕ → Fin n → Tape) (P : ℕ → Bool) (mid : ℕ → TM.TapePred n) + (N bBody bTest : ℕ) (hN : 1 ≤ N) + (hI : TM.Parked I) (hrest : ∀ v i, TM.Parked (rest v i)) + (hbody : ∀ v, v < N → + tmBody.HoareTime (tallyPre cIdx aIdx rIdx I (rest v) P v) (mid v) bBody) + (hmid : ∀ v inp work out, mid v inp work out → TM.LoopParked inp work out) + (htest : ∀ v, v < N → + tmTest.HoareTime (mid v) (tallyPost cIdx aIdx rIdx I (rest (v + 1)) P N (v + 1)) bTest) : + (TM.loopTM tmBody tmTest).HoareTime + (tallyPre cIdx aIdx rIdx I (rest 0) P 0) + (tallyPost cIdx aIdx rIdx I (rest N) P N N) + (N * (bBody + bTest + 5)) := by + have hsucc : N - 1 + 1 = N := by omega + refine (TM.loopTM_hoareTime_indexed tmBody tmTest + (E := fun j => tallyPre cIdx aIdx rIdx I (rest j) P j) + (post := tallyPost cIdx aIdx rIdx I (rest N) P N N) + (N := N - 1) (b := bBody + bTest + 5) + (idx := tallyIdx cIdx) ?_ ?_ ?_).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (le_of_eq (by rw [hsucc])) + · intro j inp work out h + exact tallyIdx_tallyPre cIdx aIdx rIdx I (rest j) P j h + · intro j hj inp work out h + have hjN : j < N := by omega + have hne : ∀ a b c, tallyPost cIdx aIdx rIdx I (rest (j + 1)) P N (j + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 ≠ Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I (rest (j + 1)) P hI (hrest (j + 1)) N + (j + 1) hp, ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_neg (show ¬ (j + 1 = N) by omega)] + exact fun hcon => absurd (outSlot_cells_one_eq_one_iff Γw.zero |>.mp hcon) (by decide) + obtain ⟨inp', work', out', t, -, ht, hreach, hp'⟩ := + TM.loopTM_continue_of_hoare tmBody tmTest (hbody j hjN) (htest j hjN) + (fun a b c hm => hmid j a b c hm) hne inp work out h + obtain ⟨hi', hw', ho'⟩ := hp' + exact ⟨inp', work', out', t, ht, hreach, hi', hw', Γw.zero, by decide, + by rw [ho', if_neg (by omega)]⟩ + · intro inp work out h + have hjN : N - 1 < N := by omega + have hhalt : ∀ a b c, tallyPost cIdx aIdx rIdx I (rest (N - 1 + 1)) P N (N - 1 + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 = Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I (rest (N - 1 + 1)) P hI (hrest _) N _ hp, + ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_pos hsucc] + exact (outSlot_cells_one_eq_one_iff Γw.one).mpr rfl + obtain ⟨c', t, ht, hreach, hstate, hpost⟩ := + TM.loopTM_halt_of_hoare tmBody tmTest (hbody (N - 1) hjN) (htest (N - 1) hjN) + (fun a b c hm => hmid (N - 1) a b c hm) hhalt inp work out h + exact ⟨c', t, ht, hreach, hstate, by rw [hsucc] at hpost; exact hpost⟩ + + + + +/-- **Its window, one iteration wide.** -/ +theorem tallyLoop_keepsWindow_of_hoare_indexed {n : ℕ} (tmBody tmTest : TM n) + (cIdx aIdx rIdx : Fin n) + (I : Tape) (rest : ℕ → Fin n → Tape) (P : ℕ → Bool) (mid : ℕ → TM.TapePred n) + (N bBody bTest inputLength : ℕ) (hN : 1 ≤ N) + (hI : TM.Parked I) (hrest : ∀ v i, TM.Parked (rest v i)) + (hIhead : I.head ≤ inputLength + 1) (hrestHead : ∀ v i, (rest v i).head ≤ 1) + (hbody : ∀ v, v < N → + tmBody.HoareTime (tallyPre cIdx aIdx rIdx I (rest v) P v) (mid v) bBody) + (hmid : ∀ v inp work out, mid v inp work out → TM.LoopParked inp work out) + (htest : ∀ v, v < N → + tmTest.HoareTime (mid v) (tallyPost cIdx aIdx rIdx I (rest (v + 1)) P N (v + 1)) bTest) : + ∀ inp work out, tallyPre cIdx aIdx rIdx I (rest 0) P 0 inp work out → + ∀ c, (TM.loopTM tmBody tmTest).reaches + ⟨(TM.loopTM tmBody tmTest).qstart, inp, work, out⟩ c → + c.WithinDecisionSpace inputLength (1 + (bBody + bTest + 5)) := by + have hsucc : N - 1 + 1 = N := by omega + refine TM.loopTM_keepsWindow_indexed_of_parked tmBody tmTest + (fun j => tallyPre cIdx aIdx rIdx I (rest j) P j) (N - 1) (bBody + bTest + 5) ?_ ?_ ?_ 0 + (by omega) + · intro j hj inp work out h + have hjN : j < N := by omega + have hne : ∀ a b c, tallyPost cIdx aIdx rIdx I (rest (j + 1)) P N (j + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 ≠ Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I (rest (j + 1)) P hI (hrest (j + 1)) N + (j + 1) hp, ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_neg (show ¬ (j + 1 = N) by omega)] + exact fun hcon => absurd (outSlot_cells_one_eq_one_iff Γw.zero |>.mp hcon) (by decide) + obtain ⟨inp', work', out', t, ht1, ht, hreach, hp'⟩ := + TM.loopTM_continue_of_hoare tmBody tmTest (hbody j hjN) (htest j hjN) + (fun a b c hm => hmid j a b c hm) hne inp work out h + obtain ⟨hi', hw', ho'⟩ := hp' + exact ⟨inp', work', out', t, ht1, ht, hreach, hi', hw', Γw.zero, by decide, + by rw [ho', if_neg (by omega)]⟩ + · intro inp work out h + have hjN : N - 1 < N := by omega + have hhalt : ∀ a b c, tallyPost cIdx aIdx rIdx I (rest (N - 1 + 1)) P N (N - 1 + 1) a b c → + TM.LoopParked a b c ∧ c.cells 1 = Γ.one := by + intro a b c hp + refine ⟨tallyPost_loopParked cIdx aIdx rIdx I (rest (N - 1 + 1)) P hI (hrest _) N _ hp, + ?_⟩ + obtain ⟨-, -, rfl⟩ := hp + rw [if_pos hsucc] + exact (outSlot_cells_one_eq_one_iff Γw.one).mpr rfl + obtain ⟨c', t, ht, hreach, hstate, -⟩ := + TM.loopTM_halt_of_hoare tmBody tmTest (hbody (N - 1) hjN) (htest (N - 1) hjN) + (fun a b c hm => hmid (N - 1) a b c hm) hhalt inp work out h + exact ⟨c', t, ht, hreach, hstate⟩ + · rintro j - inp work out ⟨rfl, rfl, s, -, rfl⟩ + refine ⟨fun i => ?_, hIhead, le_of_eq rfl⟩ + simp only [tallyWork] + split + · exact le_of_eq rfl + · split + · exact le_of_eq rfl + · split + · exact le_of_eq rfl + · exact hrestHead j i + + +end NTM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/WitnessEnum.lean b/Complexitylib/Classes/Containments/Internal/WitnessEnum.lean new file mode 100644 index 00000000..306d3f3d --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/WitnessEnum.lean @@ -0,0 +1,483 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH +public import Mathlib.Data.Nat.Bits + +/-! +# Enumerating the witnesses of a bounded existential + +⚠️ Unreviewed by Bolton + +`polyExistsLang` quantifies over witnesses `w` with `|w| ≤ p |x|`. A machine cannot quantify; it +counts. This file replaces the quantifier over strings by a quantifier over a *length* and a +*value* — the two numbers a loop actually iterates — by exhibiting the round trip between a +bitstring and its length-plus-binary-value. + +Nothing here is about machines: it is the arithmetic that makes an enumeration faithful. + +## Main definitions + +- `binVal` — the big-endian value of a bitstring +- `bitsOfLen` — the bitstring of a given length and value + +## Main results + +- `bitsOfLen_binVal`, `binVal_bitsOfLen` — the round trip, both ways: a bijection between + bitstrings and length-plus-value pairs +- `exists_bounded_iff`, `exists_bounded_iff_le` — the bounded existential over strings is one + over two numbers, in either bit order +- `choicesOfNat`, `natOfChoices` — choice sequences as counter values, for the path-counting + machine +- `bitsOfLenLE_getElem`, `choicesOfNat_apply` — each bit of the enumeration is a bit of the + counter, in the form a tape encoding produces +- `binValLE_bits`, `bits_injective` — the canonical counter representation determines its value +- `getD_eq_bit` — reading a bitstring past its end agrees with reading the number's bits +- `dropTop`, `topPlus`, `exists_bounded_iff_count` — the same existential as a single count, over + the counter values below `2 ^ (m + 1)` +- `bumpLE`, `dropTop_succ` — the witness advances in step with the counter, so a machine can + carry it on a tape instead of computing it +-/ + +@[expose] public section + +namespace Complexity + +/-- The big-endian value of a bitstring. -/ +def binVal : List Bool → ℕ + | [] => 0 + | b :: w => (if b then 2 ^ w.length else 0) + binVal w + +/-- The bitstring of a given length and value, big-endian. -/ +def bitsOfLen : ℕ → ℕ → List Bool + | 0, _ => [] + | ℓ + 1, v => decide (v / 2 ^ ℓ % 2 = 1) :: bitsOfLen ℓ (v % 2 ^ ℓ) + +@[simp] theorem bitsOfLen_length (ℓ v : ℕ) : (bitsOfLen ℓ v).length = ℓ := by + induction ℓ generalizing v with + | zero => rfl + | succ ℓ ih => simp [bitsOfLen, ih] + +/-- A bitstring's value fits in its length. -/ +theorem binVal_lt (w : List Bool) : binVal w < 2 ^ w.length := by + induction w with + | nil => simp [binVal] + | cons b w ih => + have h2 : (0 : ℕ) < 2 ^ w.length := by positivity + simp only [binVal, List.length_cons, pow_succ] + cases b <;> simp <;> omega + +/-- **The round trip.** A bitstring is recovered from its length together with its value, so +iterating over lengths and values enumerates every bitstring exactly once. -/ +theorem bitsOfLen_binVal (w : List Bool) : bitsOfLen w.length (binVal w) = w := by + induction w with + | nil => rfl + | cons b w ih => + have hlt := binVal_lt w + have hdiv : binVal (b :: w) / 2 ^ w.length = if b then 1 else 0 := by + simp only [binVal] + cases b <;> simp [Nat.div_eq_of_lt hlt] + have hmod : binVal (b :: w) % 2 ^ w.length = binVal w := by + simp only [binVal] + cases b <;> simp [Nat.mod_eq_of_lt hlt] + simp only [bitsOfLen, hdiv, hmod, ih] + cases b <;> simp + +/-- **The other half of the round trip.** The value of the bitstring of length `ℓ` and value `v` +is `v` again, provided `v` fits. Together with `bitsOfLen_binVal` this makes the correspondence a +bijection, which is what lets a loop's counter *be* the witness: incrementing the counter advances +the witness by exactly one place in the enumeration. -/ +theorem binVal_bitsOfLen : ∀ (ℓ v : ℕ), v < 2 ^ ℓ → binVal (bitsOfLen ℓ v) = v := by + intro ℓ + induction ℓ with + | zero => + intro v hv + simp only [pow_zero] at hv + simp [bitsOfLen, binVal] + omega + | succ ℓ ih => + intro v hv + have h2 : (0 : ℕ) < 2 ^ ℓ := by positivity + have hmodlt : v % 2 ^ ℓ < 2 ^ ℓ := Nat.mod_lt _ h2 + have hdm : 2 ^ ℓ * (v / 2 ^ ℓ) + v % 2 ^ ℓ = v := Nat.div_add_mod v (2 ^ ℓ) + have hdiv2 : v / 2 ^ ℓ < 2 := by + have : v < 2 ^ ℓ * 2 := by + have : (2 : ℕ) ^ (ℓ + 1) = 2 ^ ℓ * 2 := by ring + omega + exact Nat.div_lt_of_lt_mul (by omega) + have hmod2 : v / 2 ^ ℓ % 2 = v / 2 ^ ℓ := Nat.mod_eq_of_lt hdiv2 + simp only [bitsOfLen, binVal, bitsOfLen_length, ih _ hmodlt, hmod2] + by_cases hb : v / 2 ^ ℓ = 1 + · rw [hb] at hdm + simp [hb] + omega + · have hb0 : v / 2 ^ ℓ = 0 := by omega + rw [hb0] at hdm + simp [hb0] + omega + +/-- **A bounded existential over strings is a bounded existential over two numbers.** This is the +form a counting loop can implement: iterate the length, then the value. -/ +theorem exists_bounded_iff (m : ℕ) (P : List Bool → Prop) : + (∃ w : List Bool, w.length ≤ m ∧ P w) ↔ ∃ ℓ ≤ m, ∃ v < 2 ^ ℓ, P (bitsOfLen ℓ v) := by + constructor + · rintro ⟨w, hlen, hP⟩ + exact ⟨w.length, hlen, binVal w, binVal_lt w, by rwa [bitsOfLen_binVal]⟩ + · rintro ⟨ℓ, hℓ, v, -, hP⟩ + exact ⟨bitsOfLen ℓ v, by simpa using hℓ, hP⟩ + + +/-! ## The little-endian enumeration + +Every binary subroutine in the library — `TM.binarySuccTM` and the rest — uses canonical +little-endian bit lists. Since the *order* in which witnesses are enumerated is immaterial, only +that the enumeration is a bijection, the machine should use the convention its counter already +speaks. These are the little-endian counterparts of the definitions above. -/ + +/-- The little-endian value of a bitstring. -/ +def binValLE : List Bool → ℕ + | [] => 0 + | b :: w => (if b then 1 else 0) + 2 * binValLE w + +/-- The little-endian bitstring of a given length and value. -/ +def bitsOfLenLE : ℕ → ℕ → List Bool + | 0, _ => [] + | ℓ + 1, v => decide (v % 2 = 1) :: bitsOfLenLE ℓ (v / 2) + +@[simp] theorem bitsOfLenLE_length (ℓ v : ℕ) : (bitsOfLenLE ℓ v).length = ℓ := by + induction ℓ generalizing v with + | zero => rfl + | succ ℓ ih => simp [bitsOfLenLE, ih] + +theorem binValLE_lt (w : List Bool) : binValLE w < 2 ^ w.length := by + induction w with + | nil => simp [binValLE] + | cons b w ih => + simp only [binValLE, List.length_cons, pow_succ] + cases b <;> simp <;> omega + +/-- The round trip, one way. -/ +theorem bitsOfLenLE_binValLE (w : List Bool) : bitsOfLenLE w.length (binValLE w) = w := by + induction w with + | nil => rfl + | cons b w ih => + have hmod : binValLE (b :: w) % 2 = if b then 1 else 0 := by + simp only [binValLE] + cases b <;> simp [Nat.add_mul_mod_self_left] + have hdiv : binValLE (b :: w) / 2 = binValLE w := by + simp only [binValLE] + cases b <;> simp [Nat.add_mul_div_left] + simp only [bitsOfLenLE, hmod, hdiv, ih] + cases b <;> simp + +/-- The round trip, the other way. -/ +theorem binValLE_bitsOfLenLE : ∀ (ℓ v : ℕ), v < 2 ^ ℓ → binValLE (bitsOfLenLE ℓ v) = v := by + intro ℓ + induction ℓ with + | zero => + intro v hv + simp only [pow_zero] at hv + simp [bitsOfLenLE, binValLE] + omega + | succ ℓ ih => + intro v hv + have hhalf : v / 2 < 2 ^ ℓ := by + have : (2 : ℕ) ^ (ℓ + 1) = 2 ^ ℓ * 2 := by ring + omega + have hdm : 2 * (v / 2) + v % 2 = v := by omega + simp only [bitsOfLenLE, binValLE, ih _ hhalf] + by_cases hb : v % 2 = 1 + · simp [hb] + omega + · simp [hb] + omega + +/-- **The little-endian form of the enumeration.** -/ +theorem exists_bounded_iff_le (m : ℕ) (P : List Bool → Prop) : + (∃ w : List Bool, w.length ≤ m ∧ P w) ↔ ∃ ℓ ≤ m, ∃ v < 2 ^ ℓ, P (bitsOfLenLE ℓ v) := by + constructor + · rintro ⟨w, hlen, hP⟩ + exact ⟨w.length, hlen, binValLE w, binValLE_lt w, by rwa [bitsOfLenLE_binValLE]⟩ + · rintro ⟨ℓ, hℓ, v, -, hP⟩ + exact ⟨bitsOfLenLE ℓ v, by simpa using hℓ, hP⟩ + + +/-! ## Choice sequences as counter values + +The counting machine iterates a binary counter, but `NTM.acceptCount` ranges over functions +`Fin T → Bool`. These convert between the two, reusing the bitstring enumeration. -/ + +/-- The choice sequence of length `T` with counter value `v`. -/ +def choicesOfNat (T v : ℕ) : Fin T → Bool := + fun j => (bitsOfLenLE T v)[j.val]'(by simp) + +/-- The counter value of a choice sequence. -/ +def natOfChoices (T : ℕ) (ch : Fin T → Bool) : ℕ := binValLE (List.ofFn ch) + +theorem natOfChoices_lt (T : ℕ) (ch : Fin T → Bool) : natOfChoices T ch < 2 ^ T := by + have h := binValLE_lt (List.ofFn ch) + rwa [List.length_ofFn] at h + +theorem choicesOfNat_natOfChoices (T : ℕ) (ch : Fin T → Bool) : + choicesOfNat T (natOfChoices T ch) = ch := by + have hlen : (List.ofFn ch).length = T := List.length_ofFn + have hround : bitsOfLenLE T (natOfChoices T ch) = List.ofFn ch := by + have h := bitsOfLenLE_binValLE (List.ofFn ch) + rwa [hlen] at h + funext j + simp only [choicesOfNat] + simp [hround] + +theorem natOfChoices_choicesOfNat (T v : ℕ) (hv : v < 2 ^ T) : + natOfChoices T (choicesOfNat T v) = v := by + have hofFn : List.ofFn (choicesOfNat T v) = bitsOfLenLE T v := by + apply List.ext_getElem + · simp + · intro i h₁ h₂ + simp [choicesOfNat] + rw [natOfChoices, hofFn, binValLE_bitsOfLenLE T v hv] + + +/-- **Each bit of the enumeration is a bit of the counter.** The `j`-th entry of the length-`ℓ` +little-endian string for `v` is bit `j` of `v`. This is the form in which the correspondence meets +a tape: whatever encoding a counter tape uses, its `j`-th cell holds this bit — and cells beyond +the counter's own digits read as `false`, which is bit `j` of `v` too. -/ +theorem bitsOfLenLE_getElem : + ∀ (ℓ v j : ℕ) (h : j < ℓ), (bitsOfLenLE ℓ v)[j]'(by simpa using h) + = decide (v / 2 ^ j % 2 = 1) := by + intro ℓ + induction ℓ with + | zero => intro v j h; omega + | succ ℓ ih => + intro v j h + cases j with + | zero => simp [bitsOfLenLE] + | succ j => + have hj : j < ℓ := by omega + have hstep := ih (v / 2) j hj + simp only [bitsOfLenLE, List.getElem_cons_succ] + rw [hstep, Nat.div_div_eq_div_mul, pow_succ, Nat.mul_comm] + +/-- The `j`-th choice bit of counter value `v` is bit `j` of `v`. -/ +theorem choicesOfNat_apply (T v : ℕ) (j : Fin T) : + choicesOfNat T v j = decide (v / 2 ^ j.val % 2 = 1) := + bitsOfLenLE_getElem T v j.val j.isLt + + +/-! ## Canonical bits and their value + +The library's counter subroutines represent a number by `Nat.bits`. Reading that representation +back as a value is `binValLE`, and the two are mutually inverse — which is what makes a counter +tape determine the number it holds. -/ + +/-- **The canonical representation reads back as its value.** -/ +theorem binValLE_bits : ∀ n : ℕ, binValLE n.bits = n := by + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + match n, ih with + | 0, _ => rfl + | (m + 1), ih => + rcases Nat.even_or_odd (m + 1) with ⟨q, hq⟩ | ⟨q, hq⟩ + · have hq0 : q ≠ 0 := by omega + have h2 : m + 1 = 2 * q := by omega + rw [h2, Nat.bit0_bits q hq0, binValLE, ih q (by omega)] + simp + · have h2 : m + 1 = 2 * q + 1 := by omega + rw [h2, Nat.bit1_bits q, binValLE, ih q (by omega)] + simp + omega + +/-- The canonical representation determines the number. -/ +theorem bits_injective : Function.Injective Nat.bits := by + intro a b h + rw [← binValLE_bits a, ← binValLE_bits b, h] + + +/-- **Reading a bitstring past its end agrees with reading the number's bits.** Entry `j` of a +little-endian string, taken as `false` beyond the end, is bit `j` of the number it denotes — the +high bits of that number being zero. This is what lets a counter tape be read as a choice +sequence with no padding step. -/ +theorem getD_eq_bit : ∀ (w : List Bool) (j : ℕ), + w.getD j false = decide (binValLE w / 2 ^ j % 2 = 1) := by + intro w + induction w with + | nil => + intro j + simp [binValLE, List.getD] + | cons b w ih => + intro j + cases j with + | zero => + simp only [pow_zero, Nat.div_one, binValLE, List.getD] + cases b <;> simp [Nat.add_mul_mod_self_left] + | succ j => + have hstep : binValLE (b :: w) / 2 ^ (j + 1) = binValLE w / 2 ^ j := by + simp only [binValLE, pow_succ] + rw [Nat.mul_comm (2 ^ j) 2, ← Nat.div_div_eq_div_mul] + cases b <;> simp [Nat.add_mul_div_left] + have hgd : (b :: w).getD (j + 1) false = w.getD j false := rfl + rw [hgd, hstep, ih j] + +/-! ## The single-counter enumeration + +A nested loop over a length and then a value is two loops; a machine that enumerates witnesses +would rather run one. Appending a marker bit turns the enumeration into a plain count: the +numbers in `[1, 2 ^ (m + 1))` are in bijection with the bitstrings of length at most `m`, a +number denoting its canonical bits with the leading one removed. -/ + +/-- The witness a counter value denotes: the value's canonical bits, less the leading one. -/ +def dropTop (v : ℕ) : List Bool := v.bits.dropLast + +/-- The counter value at which a witness is enumerated: its value with a marker bit above it. -/ +def topPlus (w : List Bool) : ℕ := binValLE w + 2 ^ w.length + +theorem one_le_topPlus (w : List Bool) : 1 ≤ topPlus w := + le_trans Nat.one_le_two_pow (Nat.le_add_left _ _) + +/-- **The marker bit is the leading one.** -/ +theorem bits_topPlus : ∀ w : List Bool, (topPlus w).bits = w ++ [true] + | [] => by decide + | b :: w => by + have hpos : topPlus w ≠ 0 := by have := one_le_topPlus w; omega + have hsplit : topPlus (b :: w) = 2 * topPlus w + (if b then 1 else 0) := by + simp only [topPlus, binValLE, List.length_cons, pow_succ] + cases b <;> simp <;> ring + cases b with + | false => + have h0 : topPlus (false :: w) = 2 * topPlus w := by rw [hsplit]; simp + rw [h0, Nat.bit0_bits _ hpos, bits_topPlus w] + rfl + | true => + have h1 : topPlus (true :: w) = 2 * topPlus w + 1 := by rw [hsplit]; simp + rw [h1, Nat.bit1_bits, bits_topPlus w] + rfl + +/-- **The round trip.** -/ +theorem dropTop_topPlus (w : List Bool) : dropTop (topPlus w) = w := by + rw [dropTop, bits_topPlus] + simp + +theorem topPlus_lt {m : ℕ} {w : List Bool} (h : w.length ≤ m) : topPlus w < 2 ^ (m + 1) := by + have hv := binValLE_lt w + have hmono : (2 : ℕ) ^ w.length ≤ 2 ^ m := Nat.pow_le_pow_right (by norm_num) h + have : topPlus w < 2 ^ w.length + 2 ^ w.length := by + rw [topPlus]; omega + calc topPlus w < 2 ^ w.length + 2 ^ w.length := this + _ ≤ 2 ^ m + 2 ^ m := by omega + _ = 2 ^ (m + 1) := by ring + +/-- A counter value below `2 ^ (m + 1)` denotes a witness of length at most `m`. -/ +theorem length_dropTop_le {m v : ℕ} (hv : v < 2 ^ (m + 1)) : (dropTop v).length ≤ m := by + have hsize : v.size ≤ m + 1 := Nat.size_le.mpr hv + have hlen : v.bits.length = v.size := Nat.size_eq_bits_len v + rw [dropTop, List.length_dropLast, hlen] + omega + +/-- **The bounded existential is a count.** A witness of length at most `m` exists exactly when +some counter value below `2 ^ (m + 1)` denotes one — a single loop over a single register, with +the same shape the path-counting machine of `PP ⊆ PSPACE` already runs. + +The enumeration is not injective at the bottom — `0` and `1` both denote the empty witness — but +it does not have to be: only that every witness is denoted, and that every value denotes one. -/ +theorem exists_bounded_iff_count (m : ℕ) (P : List Bool → Prop) : + (∃ w : List Bool, w.length ≤ m ∧ P w) ↔ ∃ v < 2 ^ (m + 1), P (dropTop v) := by + constructor + · rintro ⟨w, hlen, hP⟩ + exact ⟨topPlus w, topPlus_lt hlen, by rwa [dropTop_topPlus]⟩ + · rintro ⟨v, hlt, hP⟩ + exact ⟨dropTop v, length_dropTop_le hlt, hP⟩ + +/-! ## Enumerating the witness alongside the counter + +The machine will not compute `dropTop` from the counter; it will carry the witness on a tape of +its own and advance it in step with the counter. `bumpLE` is that advance — the counter's +increment seen through `dropTop`. It is the ordinary little-endian increment except at the end of +the string, where the carry *extends* the witness by a zero instead of writing a one: the bit it +would have written is the counter's leading one, which `dropTop` discards. -/ + +/-- One step of the witness enumeration: increment the string, extending it on overflow. -/ +def bumpLE : List Bool → List Bool + | [] => [false] + | false :: w => true :: w + | true :: w => false :: bumpLE w + +@[simp] theorem topPlus_nil : topPlus [] = 1 := rfl + +/-- **The advance is the counter's increment.** -/ +theorem topPlus_bumpLE : ∀ w : List Bool, topPlus (bumpLE w) = topPlus w + 1 + | [] => rfl + | false :: w => by + simp only [bumpLE, topPlus, binValLE, List.length_cons] + simp + omega + | true :: w => by + have ih := topPlus_bumpLE w + have hdouble : ∀ u : List Bool, topPlus (false :: u) = 2 * topPlus u := by + intro u + simp only [topPlus, binValLE, List.length_cons, pow_succ] + simp + omega + rw [bumpLE, hdouble, ih] + simp only [topPlus, binValLE, List.length_cons, pow_succ] + simp + omega + +/-- **A positive number's canonical bits end in one**, so they are its witness and that one. -/ +theorem bits_eq_dropTop : ∀ v : ℕ, 1 ≤ v → v.bits = dropTop v ++ [true] := by + intro v + induction v using Nat.strong_induction_on with + | _ v ih => + match v, ih with + | 0, _ => intro h; omega + | (m + 1), ih => + intro _ + have key : ∀ (b : Bool) (q : ℕ), 1 ≤ q → q < m + 1 → (m + 1).bits = b :: q.bits → + (m + 1).bits = dropTop (m + 1) ++ [true] := by + intro b q hq0 hlt hb + have hqb := ih q hlt hq0 + have hd : dropTop (m + 1) = b :: dropTop q := by + show (m + 1).bits.dropLast = b :: q.bits.dropLast + rw [hb, hqb, List.dropLast_cons_of_ne_nil (by simp), List.dropLast_concat] + rw [hb, hqb, hd] + rfl + rcases Nat.even_or_odd (m + 1) with ⟨q, hq⟩ | ⟨q, hq⟩ + · have hb : (m + 1).bits = false :: q.bits := by + rw [show m + 1 = 2 * q from by omega]; exact Nat.bit0_bits q (by omega) + exact key false q (by omega) (by omega) hb + · rcases Nat.eq_zero_or_pos q with hq0 | hq0 + · rw [show m + 1 = 1 from by omega] + rfl + · have hb : (m + 1).bits = true :: q.bits := by + rw [show m + 1 = 2 * q + 1 from by omega]; exact Nat.bit1_bits q + exact key true q hq0 (by omega) hb + +/-- **The counter is recovered from its witness.** -/ +theorem topPlus_dropTop {v : ℕ} (h : 1 ≤ v) : topPlus (dropTop v) = v := + bits_injective ((bits_topPlus _).trans (bits_eq_dropTop v h).symm) + +/-- **The witness advances with the counter.** This is the loop invariant the enumerating machine +carries: one tape holds the counter, another holds the witness it denotes, and each iteration +advances both. -/ +theorem dropTop_succ {v : ℕ} (h : 1 ≤ v) : dropTop (v + 1) = bumpLE (dropTop v) := by + conv_lhs => rw [← topPlus_dropTop h, ← topPlus_bumpLE] + exact dropTop_topPlus _ + +/-- **Every witness of the admitted lengths is still reached**, with the counter starting at one: +the value `0`, which the count above admits, denotes the same empty witness as `1`. -/ +theorem exists_bounded_iff_count_pos (m : ℕ) (P : List Bool → Prop) : + (∃ w : List Bool, w.length ≤ m ∧ P w) ↔ + ∃ v, 1 ≤ v ∧ v < 2 ^ (m + 1) ∧ P (dropTop v) := by + rw [exists_bounded_iff_count] + constructor + · rintro ⟨v, hlt, hP⟩ + rcases Nat.eq_zero_or_pos v with rfl | hv + · exact ⟨1, le_refl 1, Nat.one_lt_two_pow (by omega), hP⟩ + · exact ⟨v, hv, hlt, hP⟩ + · rintro ⟨v, -, hlt, hP⟩ + exact ⟨v, hlt, hP⟩ + +end Complexity diff --git a/Complexitylib/Classes/Containments/NLSubsetCoNL.lean b/Complexitylib/Classes/Containments/NLSubsetCoNL.lean new file mode 100644 index 00000000..aba707e7 --- /dev/null +++ b/Complexitylib/Classes/Containments/NLSubsetCoNL.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.L +public import Complexitylib.Classes.Containments.Defs +public import Complexitylib.Classes.Containments.Internal.InductiveCounting + +/-! +# `NL ⊆ coNL` + +⚠️ Unreviewed by Bolton + +Nondeterministic logarithmic space is closed under complement — the +Immerman–Szelepcsényi theorem. + +The proof is inductive counting. Write `r_i` for the number of configurations reachable from the +initial one within `i` steps. Given `r_i`, a nondeterministic logspace machine can verify +`r_(i+1)` by cycling over all configurations and, for each, guessing and checking a short path; +the count certifies that no configuration was missed. Running this to the end yields the exact +number of reachable configurations, and a machine that knows that number can reject exactly when +no accepting configuration is reachable. + +## Progress + +The two statements the argument turns on are proved. `NL_complement_characterization` says what +has to be certified: an input is outside the language exactly when *every* configuration the +bounded search reaches fails to be accepting — a universally quantified statement over the +rounds. `inductive_counting_certificate` says why guessing suffices: a subset of a round that is +at least as large as the round *is* the round, so a machine that has verified `r_i` distinct +members, and has not seen `c` among them, may conclude `c` is not in round `i`. That is how a +negative fact gets certified positively, with only the count `r_i` stored. + +## What the proof still needs + +- The guessing procedure and its space accounting: for each round, cycle over all configurations, + guess membership, verify a guessed member by a guessed path, and compare the tally against the + stored `r_i`. The delicate part is that every branch either aborts or agrees on the count. +- Configurations enumerable in logarithmic space, which the coding of + `Complexitylib.Classes.Containments.Internal.ConfigCount` supplies. + +## Main results + +- `NL_complement_characterization` — what the complement of an `NL` language says +- `inductive_counting_certificate` — the counting principle that makes the guessing sound +- `NL_subset_coNL_of_counting` — the containment, granted one machine + +## TODO + +- Build the counting machine and discharge the hypothesis of `NL_subset_coNL_of_counting`. + `CoNLSubsetNL.coNL_subset_NL_of_NL_subset_coNL` then gives the reverse inclusion, so this + single direction settles `NL = coNL`. +-/ + +@[expose] public section + +namespace Complexity + +/-- **`NL ⊆ coNL`** (Immerman–Szelepcsényi): nondeterministic logarithmic space is closed +under complement, by inductive counting of the reachable configurations. -/ +def NLSubsetCoNL : Prop := NL ⊆ coNL + +/-- **The complement of an `NL` language, spelled out.** An input is outside the language exactly +when every configuration reached by the bounded search of `NLSubsetP.NL_bounded_reachability` +fails to be accepting. Inductive counting exists to certify this universally quantified +statement nondeterministically. -/ +theorem NL_complement_characterization {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (A B : ℕ), + ∀ x : List Bool, x ∉ L ↔ + ∀ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + ¬ (tm.halted c ∧ c.output.cells 1 = Γ.one) := + NL_complement_characterization_internal hL + +/-- **The counting principle behind inductive counting.** A subset of a round of the search that +is at least as large as the round is the whole round. A machine that has verified as many +distinct members of round `i` as the round contains, without meeting `c`, has therefore proved +the negative fact `c ∉ round i` — while storing only the count. -/ +theorem inductive_counting_certificate {k : ℕ} (tm : NTM k) (c₀ : Cfg k tm.Q) (i : ℕ) + {T : Set (Cfg k tm.Q)} (hsub : T ⊆ NTM.reachSet tm c₀ i) + (hcard : (NTM.reachSet tm c₀ i).ncard ≤ T.ncard) : T = NTM.reachSet tm c₀ i := + NTM.reachSet_eq_of_ncard_le tm c₀ i hsub hcard + + +/-- **`NL ⊆ coNL`, reduced to the existence of one machine.** For a log-space machine `tm` — the +space witness is part of the hypothesis — and a polynomial round bound, exhibit a nondeterministic +log-space transducer deciding the *negative* condition, that no configuration the bounded search +reaches is accepting. `inductive_counting_certificate` is the principle that makes that +certifiable by guessing while storing only a count. -/ +theorem NL_subset_coNL_of_counting + (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (A B : ℕ), + tm.DecidesInSpace L₀ S → S =O (fun n => Nat.log 2 n) → + ∃ (k' : ℕ) (M : NTM k') (C D : ℕ), M.IsTransducer ∧ + M.DecidesInSpace + {x : List Bool | ∀ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + ¬ (tm.halted c ∧ c.output.cells 1 = Γ.one)} + (logWindow C D)) : + NL ⊆ coNL := + NL_subset_coNL_of_counting_internal h + +end Complexity diff --git a/Complexitylib/Classes/Containments/NLSubsetP.lean b/Complexitylib/Classes/Containments/NLSubsetP.lean new file mode 100644 index 00000000..1bed0679 --- /dev/null +++ b/Complexitylib/Classes/Containments/NLSubsetP.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.L +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.Containments.Defs +public import Complexitylib.Classes.Containments.Internal.BoundedReach +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble + +/-! +# `NL ⊆ P` + +⚠️ Unreviewed by Bolton + +Nondeterministic logarithmic space is contained in deterministic polynomial time. + +On an input of length `n`, a machine using `O(log n)` work space has only polynomially many +configurations: a state, an input head position, and `O(log n)` cells of work tape. The machine +accepts exactly when some accepting configuration is reachable from the initial one in the +configuration graph, and reachability in a polynomially sized graph is decidable in polynomial +time by breadth-first search. + +## How it is proved + +The graph half comes first. `NL_bounded_reachability` eliminates every trace of nondeterminism +from the membership condition, and `mem_iff_exists_accepting_reachable` states it as bare +reachability: `x` is in the language exactly when some accepting configuration is reachable from +the initial one. + +The search half is *programmed*, not assembled. Cobham's theorem (`CobhamFP_eq_FP`) says a +function is polynomial-time exactly when it belongs to the machine-independent algebra, so the +search is built by composing polynomial-time functions: + +- `Cobham.cfgCode` packs a configuration into `2(k+2)+1` fixed-width blocks and `Cobham.stepFn` + is the encoded step of a *deterministic* machine; `NTM.succ_iff` reduces an edge of the + configuration graph to a step of one of the two `NTM.branchTM`s, so both successors are + available (`Complexitylib.Classes.Containments.Internal.CodeStep`); +- the visited set is a run of records, one code each, and the search is a worklist: one step + expands one record, appending each successor that a scan does not already find + (`Internal.BlockMember`, `Internal.BlockSearch`); +- `Cobham.iterate_mem_FP` is the loop — it turns a polynomial-time step, a ruler and a width + bound into a polynomial-time iteration, and every loop here is an instance of it; +- the records are distinct codes of reachable configurations, so there are at most as many as + there are configurations — polynomially many, by `exists_config_bound` — which both bounds the + state and makes the run saturate (`Internal.BlockSearchCorrect`); +- acceptance is read off a record after driving its output head back to cell `0` with + `Cobham.rewindFn` (`Internal.CodeRewind`, `Internal.CodeAccept`), and a final scan looks for an + accepting record (`Internal.BlockAccept`). + +`Internal.NLSearchAssemble` runs the search for as many steps as there are configurations and +turns the verdict into `P` membership with `mem_P_of_decisionFn`. + +An earlier plan routed the search through `Complexitylib.Models.RandomAccessMachine` instead. +That still needs a compiler from RAM programs back to Turing machines, which the library does +not have; the algebra needs no such bridge. + +## Main results + +- `NL_subset_P` — the containment +- `coNL_subset_P` — its corollary, since `P` is closed under complement +- `NL_bounded_reachability` — membership as a bounded search in the configuration graph +-/ + +@[expose] public section + +namespace Complexity + +/-- **`NL ⊆ P`**: reachability in the polynomially sized configuration graph of a +logspace-bounded machine is decidable in polynomial time. -/ +def NLSubsetP : Prop := NL ⊆ P + +/-- **A language in `NL` is a polynomially bounded reachability search.** There is a machine +whose configuration graph decides membership: `x` is in the language exactly when an accepting +configuration turns up within `A · (|x| + 1) ^ B` rounds of successor-closure from the initial +configuration. Nondeterminism, choice sequences, time bounds, and asymptotic quantifiers have +all been discharged; only the search remains. -/ +theorem NL_bounded_reachability {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (A B : ℕ), + ∀ x : List Bool, x ∈ L ↔ + ∃ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + tm.halted c ∧ c.output.cells 1 = Γ.one := + NL_bounded_reachability_internal hL + + +/-- **`NL ⊆ P`**: the configuration graph of a log-space nondeterministic machine has +polynomially many nodes, and a worklist search walks all of it in polynomial time. The search is +programmed rather than assembled: Cobham's theorem (`CobhamFP_eq_FP`) makes membership in `FP` a +matter of composing polynomial-time functions, `Cobham.stepFn` supplies the encoded machine step, +and `Cobham.iterate_mem_FP` supplies the loops. -/ +theorem NL_subset_P : NL ⊆ P := + NL_subset_P_internal + +/-- **`coNL ⊆ P`**: `P` is closed under complement, so the containment passes to the +complementary class — with no appeal to the Immerman–Szelepcsényi theorem. -/ +theorem coNL_subset_P : coNL ⊆ P := by + intro L hL + have h : Lᶜ ∈ P := NL_subset_P hL + have h' : (Lᶜ)ᶜ ∈ P := P_compl h + rwa [compl_compl] at h' + +/-- **`NL ⊆ P`, reduced to the existence of one machine.** For a log-space machine `tm` — the +space witness is part of the hypothesis, since without it the configuration graph is unbounded — +and a polynomial round bound, exhibit a deterministic machine running in explicit polynomial time +that decides whether the bounded breadth-first search turns up an accepting configuration. This +is the reduction the proof above does *not* take: the search is programmed as a polynomial-time +function instead of assembled as a machine. -/ +theorem NL_subset_P_of_search + (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (A B : ℕ), + tm.DecidesInSpace L₀ S → S =O (fun n => Nat.log 2 n) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + M.DecidesInTime + {x : List Bool | ∃ c ∈ NTM.reachSet tm (tm.initCfg x) (A * (x.length + 1) ^ B), + tm.halted c ∧ c.output.cells 1 = Γ.one} + (fun n => q.eval n)) : + NL ⊆ P := + NL_subset_P_of_search_internal h + +end Complexity diff --git a/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean b/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean new file mode 100644 index 00000000..ff2f4a2a --- /dev/null +++ b/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.Containments.Defs +public import Complexitylib.Classes.Containments.Internal.SavitchBound +public import Complexitylib.Classes.Containments.Internal.SpaceIterate +public import Complexitylib.Classes.Containments.Internal.SavitchStep +public import Complexitylib.Classes.NP + +/-! +# `NPSPACE ⊆ PSPACE` + +⚠️ Unreviewed by Bolton + +Savitch's theorem: nondeterminism costs only a squaring of space. + +The reachability predicate `Reach(u, v, 2^i)` — is `v` reachable from `u` in at most `2^i` steps — +satisfies `Reach(u, v, 2^i) ↔ ∃ m, Reach(u, m, 2^(i-1)) ∧ Reach(m, v, 2^(i-1))`. Recursing on `i` +and reusing the same space for the two subcalls costs `O(S)` bits per level and `O(log 2^S) = O(S)` +levels, so a machine using space `S` is simulated deterministically in space `O(S²)` — polynomial +space is closed under this squaring. + +## Progress + +The combinatorial core is done. `savitch_halving` below is the midpoint identity the recursion +turns on, in the form the machine uses it: a step bound of `2 ^ (i + 1)` splits into two +independent subproblems with bound `2 ^ i`, so the recursion has depth `i` and each level stores +exactly one midpoint configuration. `savitch_reaches_within_codes` supplies the base fact that +makes the depth finite: a walk longer than the number of configuration codes repeats a +configuration, so reachability is always witnessed within that many steps. + +`NPSPACE_bounded_reachability` puts the two together: membership in a language of `NPSPACE` is +reachability within `2 ^ q(|x|)` steps for an explicit polynomial `q`. Halving that bound +`q(|x|)` times reaches a single step, so the recursion depth is polynomial — and each level +stores one configuration, which a polynomially space-bounded machine can afford. + +## What the proof still needs + +A space-accounted implementation of the recursion. The route, following `NL ⊆ P`, is to write +the recursion as a *pure function* and let a general tool supply the machine: + +- Savitch's procedure is a stack machine. Its stack holds one frame per level — a level counter, + the two endpoints and the midpoint being tried — so it is polynomially bounded, and one step of + it (push, pop, or advance the midpoint) is a polynomial-time function of the stack, computable + with the block toolkit of `Complexitylib.Classes.Containments.Internal.BlockMember` and the + encoded machine step `Complexity.nstepFn` that `NL ⊆ P` already uses. +- What is missing is the tool that turns such a function into a `PSPACE` machine: *iterating a + polynomial-time function on a polynomially bounded state is in `PSPACE`*, however many + iterations it takes. `Complexitylib.Classes.Containments.Internal.SpaceIterate` is building it. + The iteration machinery is already there — `Cobham.iterSetup` and `Cobham.iterBody` from the + completeness half of Cobham's theorem apply the function once and restore the entry shape — and + only the loop driver has to change: `TM.forRegTM` counts in unary, which cannot reach + `2 ^ poly`, so the loop runs against a binary counter, exactly as in `PP ⊆ PSPACE` and + `PH ⊆ PSPACE`. Its window comes from `TM.loopTM_keepsWindowOn_phases`, with each iteration's + window read off that iteration's (polynomial) running time. + +This tool is what `IP ⊆ PSPACE` will need too: a game-tree value is another +polynomially-bounded stack recursion. + +## Main results + +- `savitch_halving` — the midpoint recursion at a halved step bound +- `savitch_reaches_within_codes` — reachability is witnessed within the number of codes +- `NPSPACE_bounded_reachability` — membership is reachability within `2 ^ poly` steps +- `NPSPACE_subset_PSPACE_of_recursion` — the containment, granted one machine + +## TODO + +- Finish `Internal.SpaceIterate`, program Savitch's stack step as a polynomial-time function, + and combine with `PSPACE_subset_NPSPACE` for `PSPACE = NPSPACE`. +-/ + +@[expose] public section + +namespace Complexity + +/-- **`NPSPACE ⊆ PSPACE`** (Savitch): halving the path length recursively simulates a +nondeterministic space-`S` machine deterministically in space `O(S²)`. -/ +def NPSPACESubsetPSPACE : Prop := NPSPACE ⊆ PSPACE + +/-- **The recursion Savitch's machine runs.** A step bound of `2 ^ (i + 1)` is met exactly when +some midpoint configuration is reachable within `2 ^ i` steps and reaches the target within +`2 ^ i` steps. Recursing on `i` costs one stored midpoint per level and bottoms out at `i = 0`, +where the question is a single step of the configuration graph. -/ +theorem savitch_halving {k : ℕ} (tm : NTM k) (i : ℕ) (c c' : Cfg k tm.Q) : + tm.ReachesCfgLe (2 ^ (i + 1)) c c' ↔ + ∃ mid, tm.ReachesCfgLe (2 ^ i) c mid ∧ tm.ReachesCfgLe (2 ^ i) mid c' := + NTM.reachesCfgLe_two_pow_succ_iff tm i c c' + +/-- **Reachability is witnessed within the number of configuration codes.** Any coding map that +separates the reachable configurations bounds the length of a walk that has to be searched: a +longer walk repeats a configuration and the repetition can be cut out. This is what makes the +recursion depth of `savitch_halving` finite. -/ +theorem savitch_reaches_within_codes {k : ℕ} {α : Type} [Fintype α] (tm : NTM k) + (c₀ : Cfg k tm.Q) (g : Cfg k tm.Q → α) + (hinj : ∀ {c c' : Cfg k tm.Q}, tm.ReachesCfg c₀ c → tm.ReachesCfg c₀ c' → g c = g c' → c = c') + {N : ℕ} (hN : Fintype.card α ≤ N) (c : Cfg k tm.Q) : + tm.ReachesCfg c₀ c ↔ tm.ReachesCfgLe N c₀ c := + NTM.reachesCfg_iff_reachesCfgLe tm c₀ g hinj hN c + +/-- **A language in `NPSPACE` is reachability within `2 ^ poly` steps.** This is what +`savitch_halving` is applied to: the step bound `2 ^ q(|x|)` halves `q(|x|)` times before +reaching a single step, so the recursion has polynomial depth, and each of its levels stores one +configuration of a polynomially space-bounded machine. -/ +theorem NPSPACE_bounded_reachability {L : Language} (hL : L ∈ NPSPACE) : + ∃ (k : ℕ) (tm : NTM k) (q : Polynomial ℕ), + ∀ x : List Bool, x ∈ L ↔ + ∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ + tm.halted c ∧ c.output.cells 1 = Γ.one := + NPSPACE_bounded_reachability_internal hL + +/-- Savitch's theorem settles the equality, given the immediate inclusion. -/ +theorem PSPACE_eq_NPSPACE_of (h : NPSPACESubsetPSPACE) (h' : PSPACE ⊆ NPSPACE) : + PSPACE = NPSPACE := + subset_antisymm h' h + + +/-- **`NPSPACE ⊆ PSPACE`, reduced to the existence of one machine.** For a space-bounded machine +`tm` — the space witness is part of the hypothesis — and a polynomial `q`, exhibit a deterministic +machine keeping a polynomial window that decides whether an accepting configuration is reachable +within `2 ^ q(|x|)` steps. `savitch_halving` is the recursion that makes that search affordable; +implementing it with exact space accounting is what remains. -/ +theorem NPSPACE_subset_PSPACE_of_recursion + (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (m : ℕ) (q : Polynomial ℕ), + tm.DecidesInSpace L₀ S → S =O (· ^ m) → + ∃ (k' : ℕ) (M : TM k') (r : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (r.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + ((∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ + c.output.cells 1 = Γ.one) → c'.output.cells 1 = Γ.one) ∧ + ((¬ ∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ + c.output.cells 1 = Γ.one) → c'.output.cells 1 = Γ.zero))) : + NPSPACE ⊆ PSPACE := + NPSPACE_subset_PSPACE_of_recursion_internal h + +end Complexity diff --git a/Complexitylib/Classes/Containments/PHSubsetPSPACE.lean b/Complexitylib/Classes/Containments/PHSubsetPSPACE.lean new file mode 100644 index 00000000..ea398a1b --- /dev/null +++ b/Complexitylib/Classes/Containments/PHSubsetPSPACE.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PH +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.Containments.Internal.PHSubsetPSPACE + +/-! +# `PH ⊆ PSPACE` + +⚠️ Unreviewed by Bolton + +The polynomial hierarchy is contained in polynomial space. + +A language at level `Σ_k` is defined by `k` alternating polynomially bounded quantifiers over a +polynomial-time matrix. Polynomial space can evaluate the whole prefix directly: enumerate the +witness strings of each quantifier in turn, reusing the same tape for each, and combine the +results with the connective the quantifier calls for. Only one witness per level is stored at a +time, so the space used is the sum of the witness lengths — polynomial. + +## Progress + +The containment is proved — see `PH_subset_PSPACE`. The rest of this section records how. + +The induction on the level is done. `PH_subset_PSPACE_of` below reduces the containment to two +closure properties of `PSPACE` and nothing else — closure under complement, and closure under a +polynomially bounded existential quantifier. The base case `P ⊆ PSPACE` is already available, and +neither remaining obligation mentions the hierarchy, so each can be attacked on its own. + +One of the two is now proved. **`PSPACE` is closed under complement** (`PSPACE_compl`): the same +machine runs, then rewinds its output head to the verdict cell and flips the bit, and the rewind +only moves heads leftward or off the left marker, so it costs one extra cell and no more. The +delicate point is that the space predicate constrains *every* reachable configuration, not just +the final one; see `Complexitylib.Classes.Containments.Internal.ComplementSpace`. + +The other is proved too. **`PSPACE` is closed under a polynomially bounded existential**: a +machine enumerates the witness strings of bounded length on a work tape, reusing that tape for +each, and runs the matrix machine on the pair — for which +`Complexitylib.Models.TuringMachine.Combinators.Apply` supplies work-tape-resident evaluation. +The counter and the witness advance together, so a single register below `p |x| + 1` bits drives +the whole enumeration, and the loop's running time — exponential — never enters the space +accounting. See `Complexitylib.Classes.Containments.Internal.PHBounds`. + +## Main results + +- `PSPACE_compl` — `PSPACE` is closed under complement +- `SigmaP_subset_PSPACE_of` — every level, granted the two closure properties +- `PH_subset_PSPACE_of` — the containment, granted the same two +- `PH_subset_PSPACE_of_polyExists` — the containment, granted the existential alone +- `mem_polyExistsLang_iff_numeric` — what the enumerating machine has to decide (two numeric + quantifiers; no quantifier over witness strings survives) +- `PH_subset_PSPACE_of_polyExistsLang` — the containment, granted one concrete statement +- `PH_subset_PSPACE_of_enumerator` — the containment, granted one machine +- `PH_subset_PSPACE` — the containment + +-/ + +@[expose] public section + +namespace Complexity + +/-- **`PH ⊆ PSPACE`**: the alternating quantifier prefix of a level of the hierarchy is +evaluated in place, one witness at a time. -/ +def PHSubsetPSPACE : Prop := PH ⊆ PSPACE + +/-- Every level of the hierarchy lies in `PSPACE`, granted that `PSPACE` is closed under +complement and under a polynomially bounded existential quantifier. -/ +theorem SigmaP_subset_PSPACE_of + (hcompl : ∀ L ∈ PSPACE, Lᶜ ∈ PSPACE) + (hex : polyExistsClass PSPACE ⊆ PSPACE) : + ∀ n, SigmaP n ⊆ PSPACE := + SigmaP_subset_PSPACE_of_internal hcompl hex + +/-- **`PH ⊆ PSPACE`, reduced to two closure properties of `PSPACE`.** The alternating prefix is +consumed one quantifier at a time: a complement flips the verdict, and an existential is +evaluated by trying every witness in place. Neither hypothesis mentions the hierarchy. -/ +theorem PH_subset_PSPACE_of + (hcompl : ∀ L ∈ PSPACE, Lᶜ ∈ PSPACE) + (hex : polyExistsClass PSPACE ⊆ PSPACE) : + PH ⊆ PSPACE := + PH_subset_PSPACE_of_internal hcompl hex + +/-- **`PH ⊆ PSPACE`, modulo a single closure property.** Closure under complement is proved +(`PSPACE_compl`), so evaluating a polynomially bounded existential in place is all that is left +between the library and the containment. -/ +theorem PH_subset_PSPACE_of_polyExists (hex : polyExistsClass PSPACE ⊆ PSPACE) : + PH ⊆ PSPACE := + PH_subset_PSPACE_of_polyExists_internal hex + + +/-- **`PH ⊆ PSPACE`, reduced to a single concrete obligation.** Closure under complement is +proved (`PSPACE_compl`), and the class-level plumbing is discharged; all that is left is to +decide one bounded existential in polynomial space, for one polynomial and one polynomially +space-bounded language. -/ +theorem PH_subset_PSPACE_of_polyExistsLang + (h : ∀ (p : Polynomial ℕ) (L' : Language), L' ∈ PSPACE → polyExistsLang p L' ∈ PSPACE) : + PH ⊆ PSPACE := + PH_subset_PSPACE_of_polyExistsLang_internal h + + + +/-- **`PH ⊆ PSPACE`, reduced to the existence of one machine.** For each polynomial `p` and each +polynomially space-bounded `L'`, exhibit a machine that keeps a polynomial window and decides the +bounded existential `polyExistsLang p L'`; the containment follows. Closure under complement is +already proved, and `mem_polyExistsLang_iff_numeric` states the membership condition that machine +must decide, as two numeric quantifiers over a witness length and value. -/ +theorem PH_subset_PSPACE_of_enumerator + (h : ∀ (p : Polynomial ℕ) (L' : Language), L' ∈ PSPACE → + ∃ (k : ℕ) (tm : TM k) (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k tm.Q), tm.reaches (tm.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ polyExistsLang p L' → c'.output.cells 1 = Γ.one) ∧ + (x ∉ polyExistsLang p L' → c'.output.cells 1 = Γ.zero))) : + PH ⊆ PSPACE := + PH_subset_PSPACE_of_enumerator_internal h + +/-- **`PH ⊆ PSPACE`**: every level of the polynomial hierarchy is decided in polynomial space. +The alternating prefix is consumed one quantifier at a time — a complement flips the verdict, and +an existential is evaluated by enumerating its witnesses in place, one at a time on a single work +tape. -/ +theorem PH_subset_PSPACE : PH ⊆ PSPACE := + PH_subset_PSPACE_internal + +end Complexity diff --git a/Complexitylib/Classes/Containments/PPSubsetPSPACE.lean b/Complexitylib/Classes/Containments/PPSubsetPSPACE.lean new file mode 100644 index 00000000..8bb896d9 --- /dev/null +++ b/Complexitylib/Classes/Containments/PPSubsetPSPACE.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Randomized +public import Complexitylib.Classes.Containments.Internal.PPSubsetPSPACE +public import Complexitylib.Classes.P.Defs + +/-! +# `PP ⊆ PSPACE` + +⚠️ Unreviewed by Bolton + +Probabilistic polynomial time with unbounded error is contained in polynomial space. + +Membership in `PP` compares the number of accepting computation paths with half of the total. A +deterministic machine can enumerate the choice sequences one at a time — each is only polynomially +long — simulating the machine on each and keeping a running count. The counter needs as many bits +as the number of paths has digits, which is polynomial, and each simulation reuses the same space. + +## The machine + +`NTM.ppMachine` is the enumerator. It parks every head past the left marker, writes the horizon +`2 ^ p |x| ` into a register by Horner-evaluating `p` on the input length, then loops: for each +counter value it simulates one path of the source machine — the counter tape *is* the choice +tape — bumps whichever tally the verdict names, and wipes its scratch space before the next pass. +The loop ends when the counter reaches the horizon, and the epilogue compares the two tallies. + +Space is the point of the construction, and it is not "space ≤ time": the loop runs `2 ^ p |x|` +times. Each pass is bounded on its own, and the wipe restores the bank the next pass starts from, +so a window one iteration wide holds for the whole run. + +One wrinkle shapes the simulation. No stage of a composed machine can be entered with a head at +cell zero, so the simulated machine's first transition would have to ignore its choice bit; +`NTM.delayNTM` prefixes two such steps, doubling the accepting count, which the horizon's own +doubling absorbs exactly (`NTM.delayNTM_char`). A source that starts halted has no accepting path +at all and is handled separately, by a machine that publishes `0`. + +## Main results + +- `NTM.acceptProb_gt_half_iff` — the threshold as an integer comparison +- `PP_integer_characterization` — `PP` with no rational arithmetic left in it +- `PP_subset_PSPACE_of_counter` — the containment, granted one machine +- `PP_subset_PSPACE_of_tallyMachine` — the same, with the obligation reduced to a machine + deciding one arithmetic predicate +- `PP_subset_PSPACE` — the containment + +## TODO + +- `BPP ⊆ PSPACE` now follows from `BPP_subset_PP`; state it where the randomized classes are + related. +-/ + +@[expose] public section + +namespace Complexity + +/-- **`PP ⊆ PSPACE`**: count accepting paths by enumerating choice sequences in place. -/ +theorem PP_subset_PSPACE : PP ⊆ PSPACE := PP_subset_PSPACE_internal + +/-- **`PP` with no rational arithmetic left.** A language of `PP` is decided by comparing twice +the number of accepting choice sequences against their total count `2 ^ T` — a comparison of two +naturals of polynomially many bits, which is what the enumerating machine actually computes. -/ +theorem PP_integer_characterization {L : Language} (hL : L ∈ PP) : + ∃ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ) (m : ℕ), + tm.AllPathsHaltIn f ∧ f =O (· ^ m) ∧ + ∀ x : List Bool, x ∈ L ↔ + 2 ^ f x.length < 2 * tm.acceptCount x (f x.length) := + PP_integer_characterization_internal hL + + +/-- **`PP ⊆ PSPACE`, reduced to the existence of one machine.** For each probabilistic machine +and time bound, exhibit a deterministic machine that keeps a polynomial window and decides the +integer comparison `2 ^ T < 2 · acceptCount`. The rational threshold is already eliminated by +`PP_integer_characterization`, so neither probability nor asymptotics survive in the obligation: +what is left is an enumerator over choice sequences with a binary counter. -/ +theorem PP_subset_PSPACE_of_counter + (h : ∀ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ), tm.AllPathsHaltIn f → (∃ m, f =O (· ^ m)) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + (2 ^ f x.length < 2 * tm.acceptCount x (f x.length) → + c'.output.cells 1 = Γ.one) ∧ + (¬ (2 ^ f x.length < 2 * tm.acceptCount x (f x.length)) → + c'.output.cells 1 = Γ.zero))) : + PP ⊆ PSPACE := + PP_subset_PSPACE_of_counter_internal h + + + +/-- **`PP ⊆ PSPACE`, reduced to a machine deciding one arithmetic predicate.** The sharpest form +of the obligation: exhibit a machine keeping a polynomial window that decides whether the +accepting tally exceeds the rejecting one, counting over a horizon `p |x|` it can evaluate. +Probability, rationals, the quantifier over `Fin T → Bool`, and the protocol's own time function +have all been eliminated — see `NTM.mem_iff_tally_lt_tally_poly` for the chain. -/ +theorem PP_subset_PSPACE_of_tallyMachine + (h : ∀ (k : ℕ) (tm : NTM k) (f : ℕ → ℕ) (p : Polynomial ℕ), + tm.AllPathsHaltIn f → (∀ n, f n ≤ p.eval n) → + ∃ (k' : ℕ) (M : TM k') (q : Polynomial ℕ), + (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → + c'.WithinDecisionSpace x.length (q.eval x.length)) ∧ + (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ + ((NTM.tally (fun v => !NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length) < + NTM.tally (fun v => NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length)) → c'.output.cells 1 = Γ.one) ∧ + (¬ (NTM.tally (fun v => !NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length) < + NTM.tally (fun v => NTM.acceptsAt tm x (p.eval x.length) v) + (2 ^ p.eval x.length)) → c'.output.cells 1 = Γ.zero))) : + PP ⊆ PSPACE := + PP_subset_PSPACE_of_tallyMachine_internal h + + +end Complexity diff --git a/Complexitylib/Classes/Containments/PSPACESubsetEXP.lean b/Complexitylib/Classes/Containments/PSPACESubsetEXP.lean new file mode 100644 index 00000000..aa1b4aa7 --- /dev/null +++ b/Complexitylib/Classes/Containments/PSPACESubsetEXP.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.PSPACESubsetEXP + +/-! +# `PSPACE ⊆ EXP` + +⚠️ Unreviewed by Bolton + +Polynomial space is contained in exponential time. + +A machine using space `S(n)` has only `2^O(S(n))` configurations that respect its space bound, so +a deterministic run visits each at most once before halting: a repeat would make the run periodic +and pull an earlier halt, contradicting minimality. The halting time is therefore bounded by the +configuration count, and the *same machine* — no simulation is needed — decides the language in +exponential time. + +The proof is in `Complexitylib.Classes.Containments.Internal.PSPACESubsetEXP`. Its one subtlety +is that `Cfg.WithinDecisionSpace` bounds head *positions* but says nothing about tape *contents*; +`TM.Windowed` supplies the missing invariant — a head that never leaves the window can never write +outside it — which is what makes the configuration count finite. + +## Main results + +- `PSPACE_subset_EXP` — the containment +-/ + +@[expose] public section + +namespace Complexity + +/-- **`PSPACE ⊆ EXP`**: a space-bounded machine halts within its configuration count. -/ +theorem PSPACE_subset_EXP : PSPACE ⊆ EXP := PSPACE_subset_EXP_internal + +end Complexity diff --git a/Complexitylib/Classes/Containments/PSPACESubsetIP.lean b/Complexitylib/Classes/Containments/PSPACESubsetIP.lean new file mode 100644 index 00000000..60acf607 --- /dev/null +++ b/Complexitylib/Classes/Containments/PSPACESubsetIP.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.IPSubsetPSPACE +public import Complexitylib.Classes.Interactive +public import Complexitylib.Classes.P.Defs + +/-! +# `PSPACE ⊆ IP` + +⚠️ Unreviewed by Bolton + +Shamir's theorem, the hard half of `IP = PSPACE`. + +Take a `PSPACE`-complete problem — validity of a quantified Boolean formula — and arithmetize it: +replace the Boolean connectives by polynomial operations over a finite field, so that the formula's +truth value becomes the value of an iterated sum and product. The prover then convinces the +verifier of that value by the sum-check protocol, one variable at a time, with a degree-reduction +step interleaved to keep the intermediate polynomials small. + +## What the proof needs + +- A `PSPACE`-complete problem and the reduction to it — `Complexitylib.SAT.QBF` has the syntax. +- Arithmetization over a finite field, and the sum-check protocol with its soundness bound. +- The interactive machinery of `Complexitylib.Classes.Interactive` to package the protocol. + +## TODO + +- Prove it. This is the deepest single theorem on the roadmap's long-term track. +-/ + +@[expose] public section + +namespace Complexity + +/-- **`PSPACE ⊆ IP`** (Shamir): arithmetize a quantified Boolean formula and run sum-check. -/ +def PSPACESubsetIP : Prop := PSPACE ⊆ IP + +/-- The two halves together are Shamir's theorem. -/ +theorem IP_eq_PSPACE_of (h : IPSubsetPSPACE) (h' : PSPACESubsetIP) : IP = PSPACE := + subset_antisymm (h : IP ⊆ PSPACE) (h' : PSPACE ⊆ IP) + +end Complexity diff --git a/Complexitylib/Classes/Containments/PSPACESubsetNPSPACE.lean b/Complexitylib/Classes/Containments/PSPACESubsetNPSPACE.lean new file mode 100644 index 00000000..0e2fc271 --- /dev/null +++ b/Complexitylib/Classes/Containments/PSPACESubsetNPSPACE.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.NP +public import Complexitylib.Classes.Containments + +/-! +# `PSPACE ⊆ NPSPACE` + +⚠️ Unreviewed by Bolton + +Deterministic polynomial space is contained in nondeterministic polynomial space. + +This direction is immediate: a deterministic decider is a nondeterministic one whose two +transition functions agree, so each `DSPACE` level embeds in the corresponding `NSPACE` level. +The converse is Savitch's theorem — see `NPSPACESubsetPSPACE`. +-/ + +@[expose] public section + +namespace Complexity + +/-- **`PSPACE ⊆ NPSPACE`**: every deterministic space-bounded decider is a nondeterministic +one, level by level. -/ +theorem PSPACE_subset_NPSPACE : PSPACE ⊆ NPSPACE := by + intro L hL + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp hL + exact Set.mem_iUnion.mpr ⟨k, DSPACE_subset_NSPACE _ hk⟩ + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean b/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean index 8a0a9a86..db6e68a0 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/BlockLoop.lean @@ -381,6 +381,103 @@ theorem anyShiftAux_mem {n : ℕ} (tm : NTM k) (b : Bool) show recNotation _ _ _ (gι v) (Fin.tail fun i => ![gι, gu, gx, gτ, gρ, gσ, gr, gwit] i v) = _ rw [htail, recNotation_anyShift] +/-! ## Membership among blocks -/ + +/-- Flag: the block `c` occurs among the width-`|τ|` blocks of `s` indexed by the ruler. -/ +def memBlockAux (τ s c : List Bool) : List Bool → List Bool + | [] => [false] + | _ :: y => orBit (eqFlag c (blockOf τ s y)) (memBlockAux τ s c y) + +theorem memBlockAux_flag (τ s c ι : List Bool) : + memBlockAux τ s c ι = [true] ∨ memBlockAux τ s c ι = [false] := by + induction ι with + | nil => exact Or.inr rfl + | cons β y ih => exact orBit_flag (eqFlag_flag _ _) ih + +/-- **The membership test is an existential over block indices.** -/ +theorem memBlockAux_eq_true_iff (τ s c ι : List Bool) : + memBlockAux τ s c ι = [true] ↔ ∃ i < ι.length, blockAtIdx τ.length s i = c := by + induction ι with + | nil => simp [memBlockAux] + | cons β y ih => + rw [memBlockAux, orBit_eq_true_iff (eqFlag_flag _ _) (memBlockAux_flag _ _ _ _), ih, + eqFlag_eq_true_iff, blockOf_eq, List.length_cons] + constructor + · rintro (h | ⟨i, hi, hv⟩) + · exact ⟨y.length, by omega, h.symm⟩ + · exact ⟨i, by omega, hv⟩ + · rintro ⟨i, hi, hv⟩ + rcases Nat.lt_or_ge i y.length with hlt | hge + · exact Or.inr ⟨i, hlt, hv⟩ + · have : i = y.length := by omega + subst this + exact Or.inl hv.symm + +/-- The step of the membership recursion. -/ +private def memStep (w : Fin 5 → List Bool) : List Bool := + orBit (eqFlag (w 4) (blockOf (w 2) (w 3) (w 0))) (w 1) + +private theorem memStep_mem : Cobham memStep := + (orFn (eqFlag_mem (Cobham.proj 4) + (blockOf_mem (Cobham.proj 2) (Cobham.proj 3) (Cobham.proj 0))) + (Cobham.proj 1)).of_eq fun _ => rfl + +private theorem recNotation_memBlock (τ s c ι : List Bool) : + recNotation (fun _ : Fin 3 → List Bool => ([false] : List Bool)) memStep memStep ι + ![τ, s, c] = memBlockAux τ s c ι := by + induction ι with + | nil => rfl + | cons β y ih => + rw [recNotation_cons, memBlockAux] + cases β <;> + · show memStep (Fin.cons y (Fin.cons _ ![τ, s, c])) = _ + rw [memStep] + show orBit (eqFlag c (blockOf τ s y)) + (recNotation (fun _ : Fin 3 → List Bool => ([false] : List Bool)) memStep memStep y + ![τ, s, c]) = _ + rw [ih] + +private theorem recNotation_memBlock_length (ι : List Bool) (v : Fin 3 → List Bool) : + (recNotation (fun _ : Fin 3 → List Bool => ([false] : List Bool)) memStep memStep ι v).length + ≤ 1 := by + induction ι with + | nil => simp + | cons β y ih => + rw [recNotation_cons] + have hstep : ∀ (a b : List Bool) (w' : Fin 3 → List Bool), + (memStep (Fin.cons a (Fin.cons b w'))).length ≤ 1 := by + intro a b w' + rw [memStep, orBit_length] + cases β <;> simpa using hstep y _ v + +/-- **The membership test is in the algebra.** -/ +theorem memBlockAux_mem {n : ℕ} {gτ gs gc gι : (Fin n → List Bool) → List Bool} + (hτ : Cobham gτ) (hs : Cobham gs) (hc : Cobham gc) (hι : Cobham gι) : + Cobham fun v : Fin n → List Bool => memBlockAux (gτ v) (gs v) (gc v) (gι v) := by + have hrec := Cobham.boundedRec (g := fun _ : Fin 3 → List Bool => ([false] : List Bool)) + (h₀ := memStep) (h₁ := memStep) + (j := fun _ : Fin 4 → List Bool => ([false] : List Bool)) + (Cobham.const _) memStep_mem memStep_mem (Cobham.const _) + (by + intro ι v + simpa using recNotation_memBlock_length ι v) + have hg : ∀ i : Fin 4, Cobham (![gι, gτ, gs, gc] i) := by + intro i + match i with + | 0 => exact hι + | 1 => exact hτ + | 2 => exact hs + | 3 => exact hc + refine (Cobham.comp hrec hg).of_eq fun v => ?_ + have htail : (Fin.tail fun i => ![gι, gτ, gs, gc] i v) = ![gτ v, gs v, gc v] := by + funext i + match i with + | 0 => rfl + | 1 => rfl + | 2 => rfl + show recNotation _ _ _ (gι v) (Fin.tail fun i => ![gι, gτ, gs, gc] i v) = _ + rw [htail, recNotation_memBlock] + end Cobham end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean b/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean index 64b10f1a..f6b8dfc2 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean @@ -876,13 +876,9 @@ theorem iterTM_computesInTime (M : TM k) {G : List Bool → List Bool} {tp : Pol `Complexity.iterBound` is a sum of products of polynomial evaluations, so the closure API of `Complexitylib.Asymptotics.PolyBound` bounds it directly. -/ -theorem polyBound_iterBound (k : ℕ) (tp p r : Polynomial ℕ) : - PolyBound (iterBound k tp p r) := by - have hcomp : PolyBound (fun n => tp.eval (r.eval n)) := - PolyBound.mono (PolyBound.eval (tp.comp r)) - (fun n => le_of_eq (by rw [Polynomial.eval_comp])) +/-- `Complexity.setupBound` is polynomially bounded. -/ +theorem polyBound_setupBound (p : Polynomial ℕ) : PolyBound (setupBound p) := by have hp : PolyBound (fun n => p.eval n) := PolyBound.eval p - have hr : PolyBound (fun n => r.eval n) := PolyBound.eval r have hpow : PolyBound (fun n => (n + 1) ^ (polyCoeffs p).length) := PolyBound.pow (PolyBound.add PolyBound.id (PolyBound.const 1)) _ have hM : PolyBound (fun n => polyM p n) := by @@ -899,42 +895,54 @@ theorem polyBound_iterBound (k : ℕ) (tp p r : Polynomial ℕ) : rw [show (fun n => layerBudget (polyM p n)) = fun n => 4 * opBudget (polyM p n) + 3 from rfl] exact PolyBound.add (PolyBound.mul (PolyBound.const _) hop) (PolyBound.const _) - have hsetup : PolyBound (setupBound p) := by - rw [show setupBound p = fun n => 1 + 1 + (2 * n + 4) + 1 + - (opBudget (polyM p n) + 1 + - ((p.natDegree + 1) * (layerBudget (polyM p n) + 1) + 1)) + 1 + (n + 3) from rfl] - exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add - (PolyBound.add (PolyBound.const _) (PolyBound.const _)) - (PolyBound.add (PolyBound.mul (PolyBound.const 2) PolyBound.id) (PolyBound.const _))) - (PolyBound.const _)) - (PolyBound.add (PolyBound.add hop (PolyBound.const _)) - (PolyBound.add - (PolyBound.mul (PolyBound.const _) (PolyBound.add hlayer (PolyBound.const _))) - (PolyBound.const _)))) - (PolyBound.const _)) (PolyBound.add PolyBound.id (PolyBound.const _)) + rw [show setupBound p = fun n => 1 + 1 + (2 * n + 4) + 1 + + (opBudget (polyM p n) + 1 + + ((p.natDegree + 1) * (layerBudget (polyM p n) + 1) + 1)) + 1 + (n + 3) from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.mul (PolyBound.const 2) PolyBound.id) (PolyBound.const _))) + (PolyBound.const _)) + (PolyBound.add (PolyBound.add hop (PolyBound.const _)) + (PolyBound.add + (PolyBound.mul (PolyBound.const _) (PolyBound.add hlayer (PolyBound.const _))) + (PolyBound.const _)))) + (PolyBound.const _)) (PolyBound.add PolyBound.id (PolyBound.const _)) + +/-- `Complexity.tailBound` is polynomially bounded in the input length, for any +polynomially bounded result length. -/ +theorem polyBound_tailBound (k : ℕ) (p : Polynomial ℕ) (m : ℕ → ℕ) (hm : PolyBound m) : + PolyBound (fun n => tailBound k (p.eval n) (m n)) := by + have hp : PolyBound (fun n => p.eval n) := PolyBound.eval p + rw [show (fun n => tailBound k (p.eval n) (m n)) = fun n => + 1 + 1 + (p.eval n + 1 + 2) + 1 + + ((k + 1) * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + ((k + 1) * (p.eval n + 4) + 1)) + 1 + + (2 * m n + 5 + 1 + + (1 * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + (1 * (p.eval n + 4) + 1))) from rfl] + have hbase : PolyBound (fun n => p.eval n + 4) := PolyBound.add hp (PolyBound.const _) + have hk : PolyBound (fun n => (k + 1) * (p.eval n + 4)) := + PolyBound.mul (PolyBound.const _) hbase + have h1 : PolyBound (fun n => 1 * (p.eval n + 4)) := PolyBound.mul (PolyBound.const _) hbase + have h4 : PolyBound (fun n => p.eval n * 4) := PolyBound.mul hp (PolyBound.const _) + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.add hp (PolyBound.const _)) (PolyBound.const _))) + (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add hk h4) (PolyBound.const _)) + (PolyBound.const _)) (PolyBound.add hk (PolyBound.const _)))) (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.mul (PolyBound.const 2) hm) + (PolyBound.const _)) (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add h1 h4) (PolyBound.const _)) + (PolyBound.const _)) (PolyBound.add h1 (PolyBound.const _)))) + +theorem polyBound_iterBound (k : ℕ) (tp p r : Polynomial ℕ) : + PolyBound (iterBound k tp p r) := by + have hcomp : PolyBound (fun n => tp.eval (r.eval n)) := + PolyBound.mono (PolyBound.eval (tp.comp r)) + (fun n => le_of_eq (by rw [Polynomial.eval_comp])) + have hr : PolyBound (fun n => r.eval n) := PolyBound.eval r + have hsetup : PolyBound (setupBound p) := polyBound_setupBound p have htail : ∀ m : ℕ → ℕ, PolyBound m → - PolyBound (fun n => tailBound k (p.eval n) (m n)) := by - intro m hm - rw [show (fun n => tailBound k (p.eval n) (m n)) = fun n => - 1 + 1 + (p.eval n + 1 + 2) + 1 + - ((k + 1) * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + ((k + 1) * (p.eval n + 4) + 1)) + 1 + - (2 * m n + 5 + 1 + - (1 * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + (1 * (p.eval n + 4) + 1))) from rfl] - have hbase : PolyBound (fun n => p.eval n + 4) := PolyBound.add hp (PolyBound.const _) - have hk : PolyBound (fun n => (k + 1) * (p.eval n + 4)) := - PolyBound.mul (PolyBound.const _) hbase - have h1 : PolyBound (fun n => 1 * (p.eval n + 4)) := PolyBound.mul (PolyBound.const _) hbase - have h4 : PolyBound (fun n => p.eval n * 4) := PolyBound.mul hp (PolyBound.const _) - exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add - (PolyBound.add (PolyBound.const _) (PolyBound.const _)) - (PolyBound.add (PolyBound.add hp (PolyBound.const _)) (PolyBound.const _))) - (PolyBound.const _)) - (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add hk h4) (PolyBound.const _)) - (PolyBound.const _)) (PolyBound.add hk (PolyBound.const _)))) (PolyBound.const _)) - (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.mul (PolyBound.const 2) hm) - (PolyBound.const _)) (PolyBound.const _)) - (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add h1 h4) (PolyBound.const _)) - (PolyBound.const _)) (PolyBound.add h1 (PolyBound.const _)))) + PolyBound (fun n => tailBound k (p.eval n) (m n)) := polyBound_tailBound k p rw [show iterBound k tp p r = fun n => setupBound p n + 1 + (tailBound k (p.eval n) (n + 2) + 1 + (n * (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n) + 2) + (n + 2)) + 1 + diff --git a/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean b/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean index 3fb6b3a8..44551105 100644 --- a/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean +++ b/Complexitylib/Classes/P/Cobham/Internal/StringOps.lean @@ -273,6 +273,94 @@ theorem xorSuffix_mem {n : ℕ} {ga gb : (Fin n → List Bool) → List Bool} show recNotation _ _ _ (ga v) (Fin.tail fun i => ![ga, gb] i v) = _ rw [hb2, recNotation_xor] +/-! ## Equality of strings -/ + +/-- Flag: every bit of `x` is `false`. -/ +def allZeroFlag : List Bool → List Bool + | [] => [true] + | true :: _ => [false] + | false :: x => allZeroFlag x + +@[simp] theorem allZeroFlag_nil : allZeroFlag [] = [true] := rfl + +theorem allZeroFlag_flag (x : List Bool) : allZeroFlag x = [true] ∨ allZeroFlag x = [false] := by + induction x with + | nil => exact Or.inl rfl + | cons b x ih => + cases b + · exact ih + · exact Or.inr rfl + +@[simp] theorem allZeroFlag_eq_true_iff (x : List Bool) : + allZeroFlag x = [true] ↔ ∀ b ∈ x, b = false := by + induction x with + | nil => simp + | cons b x ih => + cases b + · simpa [allZeroFlag] using ih + · simp [allZeroFlag] + +private theorem recNotation_allZero (x : List Bool) (v : Fin 0 → List Bool) : + recNotation (fun _ : Fin 0 → List Bool => ([true] : List Bool)) + (fun w : Fin 2 → List Bool => w 1) + (fun _ : Fin 2 → List Bool => ([false] : List Bool)) x v = allZeroFlag x := by + induction x with + | nil => rfl + | cons b x ih => + cases b + · simpa [allZeroFlag] using ih + · rfl + +/-- **The all-zero test is in the algebra.** -/ +theorem allZeroFlag_mem_one : Cobham fun v : Fin 1 → List Bool => allZeroFlag (v 0) := by + have hrec := Cobham.boundedRec (g := fun _ : Fin 0 → List Bool => ([true] : List Bool)) + (h₀ := fun w : Fin 2 → List Bool => w 1) + (h₁ := fun _ : Fin 2 → List Bool => ([false] : List Bool)) + (j := fun _ : Fin 1 → List Bool => ([false] : List Bool)) + (Cobham.const _) (Cobham.proj 1) (Cobham.const _) (Cobham.const _) + (by + intro x v + rw [recNotation_allZero] + rcases allZeroFlag_flag x with h | h <;> simp [h]) + exact hrec.of_eq fun v => recNotation_allZero (v 0) _ + +theorem allZeroFlag_mem {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : + Cobham fun v : Fin n → List Bool => allZeroFlag (g v) := + (Cobham.comp allZeroFlag_mem_one fun _ : Fin 1 => hg).of_eq fun _ => rfl + +/-- Flag: the two strings are equal. -/ +def eqFlag (a b : List Bool) : List Bool := andBit (lenEqFlag a b) (allZeroFlag (xorSuffix a b)) + +theorem eqFlag_flag (a b : List Bool) : eqFlag a b = [true] ∨ eqFlag a b = [false] := + andBit_flag _ _ + +@[simp] theorem eqFlag_eq_true_iff (a b : List Bool) : eqFlag a b = [true] ↔ a = b := by + rw [eqFlag, andBit_eq_true_iff (lenEqFlag_flag a b) (allZeroFlag_flag _), + lenEqFlag_eq_true_iff, allZeroFlag_eq_true_iff] + constructor + · rintro ⟨hlen, hzero⟩ + rw [xorSuffix_eq_zipWith_of_length a b hlen] at hzero + refine List.ext_getElem hlen fun i h₁ h₂ => ?_ + have hlt : i < (List.zipWith xor a b).length := by + rw [List.length_zipWith] + omega + have hmem := List.getElem_mem hlt + have hval := hzero _ hmem + rw [List.getElem_zipWith] at hval + cases ha : a[i] <;> cases hb : b[i] <;> simp_all + · rintro rfl + refine ⟨rfl, fun c hc => ?_⟩ + rw [xorSuffix_eq_zipWith_of_length a a rfl] at hc + obtain ⟨i, hi, rfl⟩ := List.getElem_of_mem hc + rw [List.getElem_zipWith] + simp + +/-- **String equality is in the algebra.** -/ +theorem eqFlag_mem {n : ℕ} {ga gb : (Fin n → List Bool) → List Bool} + (ha : Cobham ga) (hb : Cobham gb) : + Cobham fun v : Fin n → List Bool => eqFlag (ga v) (gb v) := + (andFn (lenEqFlag_mem ha hb) (allZeroFlag_mem (xorSuffix_mem ha hb))).of_eq fun _ => rfl + end Cobham end Complexity diff --git a/Complexitylib/Models.lean b/Complexitylib/Models.lean index 997a6ac1..f01c8323 100644 --- a/Complexitylib/Models.lean +++ b/Complexitylib/Models.lean @@ -9,6 +9,7 @@ public import Complexitylib.Models.TuringMachine public import Complexitylib.Models.TuringMachine.Trace public import Complexitylib.Models.TuringMachine.Trace.DetPrefix public import Complexitylib.Models.TuringMachine.SingleTape +public import Complexitylib.Models.TuringMachine.Branch public import Complexitylib.Models.TuringMachine.ChoiceTape public import Complexitylib.Models.TuringMachine.Combinators public import Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork @@ -40,6 +41,7 @@ public import Complexitylib.Models.TuringMachine.Subroutines.BinaryPolynomial public import Complexitylib.Models.TuringMachine.Subroutines.BinaryFor public import Complexitylib.Models.TuringMachine.Subroutines.BinaryLength public import Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryBump public import Complexitylib.Models.TuringMachine.Subroutines.BinarySucc public import Complexitylib.Models.TuringMachine.Subroutines.ClearWork public import Complexitylib.Models.TuringMachine.Subroutines.CopyOutput diff --git a/Complexitylib/Models/TuringMachine/Branch.lean b/Complexitylib/Models/TuringMachine/Branch.lean new file mode 100644 index 00000000..bdd2caf0 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Branch.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.ChoiceTape + +/-! +# Fixing a nondeterministic branch + +⚠️ Unreviewed by Bolton + +An `NTM`'s transition function is a `Bool` away from a `TM`'s, so fixing the +`Bool` turns it into a deterministic machine. Unlike `NTM.choiceTM`, which reads +one choice bit per step off a tape and therefore runs a whole path, `branchTM` +fixes the *same* choice for every step: it is the one-step successor operator of +the configuration graph, not a path. + +That is what a search of the configuration graph needs. Deterministic machinery +— the encoded step `Complexity.Cobham.stepFn` of Cobham's algebra above all — +applies to a `TM` and not to an `NTM`, so an edge of the graph is taken by one +of the two `branchTM`s (`Complexity.NTM.succ_iff`, where the graph is +defined). + +## Main definitions + +- `NTM.branchTM` — the deterministic machine that always takes branch `b` + +## Main results + +- `NTM.branchTM_stepCfg` — its step is the branch's step +- `NTM.branchTM_step`, `NTM.branchTM_step_of_halted` — the step, halted or not +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} + +/-- The deterministic machine that always takes branch `b`. -/ +def branchTM (tm : NTM k) (b : Bool) : TM k where + Q := tm.Q + decEq := tm.decEq + finQ := tm.finQ + qstart := tm.qstart + qhalt := tm.qhalt + δ := tm.δ b + δ_right_of_start := tm.δ_right_of_start b + +@[simp] theorem branchTM_Q (tm : NTM k) (b : Bool) : (tm.branchTM b).Q = tm.Q := rfl + +@[simp] theorem branchTM_qstart (tm : NTM k) (b : Bool) : + (tm.branchTM b).qstart = tm.qstart := rfl + +@[simp] theorem branchTM_qhalt (tm : NTM k) (b : Bool) : + (tm.branchTM b).qhalt = tm.qhalt := rfl + +@[simp] theorem branchTM_δ (tm : NTM k) (b : Bool) : (tm.branchTM b).δ = tm.δ b := rfl + +/-- One step of the fixed branch is one step of the nondeterministic machine on that +branch. -/ +@[simp] theorem branchTM_stepCfg (tm : NTM k) (b : Bool) (c : Cfg k tm.Q) : + (tm.branchTM b).stepCfg c = tm.stepCfg b c := rfl + +/-- A non-halted configuration steps to the branch's successor. -/ +theorem branchTM_step (tm : NTM k) (b : Bool) {c : Cfg k tm.Q} (h : c.state ≠ tm.qhalt) : + (tm.branchTM b).step c = some (tm.stepCfg b c) := + TM.step_of_not_halted _ h + +/-- A halted configuration has no successor on either branch. -/ +theorem branchTM_step_of_halted (tm : NTM k) (b : Bool) {c : Cfg k tm.Q} + (h : c.state = tm.qhalt) : (tm.branchTM b).step c = none := by + rw [TM.step] + exact if_pos (show c.state = (tm.branchTM b).qhalt from h) + +end NTM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/ApplyDecide.lean b/Complexitylib/Models/TuringMachine/Combinators/ApplyDecide.lean new file mode 100644 index 00000000..87c832a5 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/ApplyDecide.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Combinators.Apply +public import Complexitylib.Models.TuringMachine.Combinators.Internal.RetargetWindow +public import Complexitylib.Models.TuringMachine.Hoare.SpaceFrame + +/-! +# Running a decider from a work tape onto a work tape + +⚠️ Unreviewed by Bolton + +`TM.applyTM` is stated for a machine computing a *function*: its contract asks for +`TM.ComputesInTime` and delivers `Tape.HasOutput`. A machine deciding a language is not a +transducer — nothing is claimed about its output tape beyond cell one — so a caller that wants to +run a decider inside a loop needs the same seam stated for a verdict. + +That is what this file supplies. The proofs are the ones behind `TM.applyTM_hoareTime` and +`TM.applyTM_hoareTime_frame`, with `TM.retargetInputStarted_decidesVirtual` in place of its +computing counterpart. + +## Main results + +- `TM.retargetInputStarted_hoareTime_decide` — the virtual-input seam, for a decider +- `TM.applyTM_hoareTime_decide` — the work-to-work evaluator's contract, for a decider +- `TM.applyTM_hoareTime_decide_frame` — the same with the disturbance framed, which is what a + loop body needs in order to reset for the next call +- `TM.applyTM_hoareTime_decide_space_frame` — the frame taken from the source's *space* bound + rather than its running time, which is the only version a space-bounded caller can afford +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : ℕ} + +/-- **The virtual-input seam, for a decider.** Started on the canonical entry configuration with +`y` on the last work tape, the wrapper halts inside the source's time bound with the source's +verdict on `y` in cell one of the real output. -/ +theorem retargetInputStarted_hoareTime_decide (M : TM k) {L : Language} {T : ℕ → ℕ} + (hdec : M.DecidesInTime L T) (y : List Bool) : + (retargetInputStarted M).HoareTime + (fun inp work out => + work = (retargetInputStartedCfg M y inp).work ∧ + out = (Tape.init []).move Dir3.right) + (fun _inp _work out => + (y ∈ L → out.cells 1 = Γ.one) ∧ (y ∉ L → out.cells 1 = Γ.zero)) + (T y.length) := by + intro inp work out hpre + obtain ⟨c', t, ht, hreach, hhalt, hone, hzero⟩ := + retargetInputStarted_decidesVirtual M hdec y inp + have hstart : + ({ state := (retargetInputStarted M).qstart, input := inp, + work := work, output := out } : Cfg (k + 1) M.Q) = + retargetInputStartedCfg M y inp := + Cfg.ext rfl rfl hpre.1 hpre.2 + refine ⟨c', t, ht, ?_, hhalt, hone, hzero⟩ + convert hreach using 1 + +/-- **The work-to-work evaluator, for a decider.** The verdict lands in cell one of the fresh +last work tape, and the real output stays the parked blank tape a wipe needs. -/ +theorem applyTM_hoareTime_decide (M : TM k) {L : Language} {T : ℕ → ℕ} + (hdec : M.DecidesInTime L T) (y : List Bool) : + (applyTM M).HoareTime + (fun inp work out => + ((fun i : Fin (k + 1) => work (Fin.castSucc i)) + = (retargetInputStartedCfg M y inp).work) ∧ + work (Fin.last (k + 1)) = parkedBlank ∧ + out = parkedBlank) + (fun _inp work out => + ((y ∈ L → (work (Fin.last (k + 1))).cells 1 = Γ.one) ∧ + (y ∉ L → (work (Fin.last (k + 1))).cells 1 = Γ.zero)) ∧ + out = parkedBlank) + (T y.length) := by + have h := retargetOutput_hoareTime (retargetInputStarted M) + (retargetInputStarted_hoareTime_decide M hdec y) + intro inp work out hpre + obtain ⟨h1, h2, h3⟩ := hpre + exact h inp work out ⟨⟨h1, h2⟩, h3⟩ + +/-- **The decider's evaluator, with its disturbance framed.** Beyond the verdict, this records +what a caller needs in order to reset for a second call: every tape's head is still within `H`, +and every cell beyond `H` is still blank. Both follow from the run being `T |y|`-bounded and +every entry tape being parked and blank past `|y|`. -/ +theorem applyTM_hoareTime_decide_frame (M : TM k) {L : Language} {T : ℕ → ℕ} + (hdec : M.DecidesInTime L T) (y : List Bool) (inp₀ : Tape) (hinp : Parked inp₀) + (hinpSI : Tape.StartInvariant inp₀) + (H : ℕ) (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) : + (applyTM M).HoareTime + (fun inp work out => inp = inp₀ ∧ work = applyPre M y inp₀ ∧ out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + ((y ∈ L → (work (Fin.last (k + 1))).cells 1 = Γ.one) ∧ + (y ∉ L → (work (Fin.last (k + 1))).cells 1 = Γ.zero)) ∧ + ∀ i, Tape.StartInvariant (work i) ∧ (work i).head ≤ H ∧ + ∀ j, H < j → (work i).cells j = Γ.blank) + (T y.length) := by + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + rw [hi, hw, ho] + obtain ⟨c', t, ht, hreach, hhalt, hVerdict, hOutEq⟩ := + applyTM_hoareTime_decide M hdec y inp₀ (applyPre M y inp₀) parkedBlank + ⟨(applyPre_spec M y inp₀).1, (applyPre_spec M y inp₀).2, rfl⟩ + have hinpEq : c'.input = inp₀ := + reachesIn_input_eq_of_idlesInput (applyTM_idlesInput M) hreach hinp + have hSI := reachesIn_startInvariant hreach hinpSI + (fun i => applyPre_startInvariant M y inp₀ i) + (show Tape.StartInvariant parkedBlank from startInvariant_initNil.move Dir3.right) + refine ⟨c', t, ht, hreach, hhalt, hinpEq, hOutEq, hVerdict, + fun i => ⟨hSI.2.1 i, ?_, fun j hj => ?_⟩⟩ + · have hh := (head_le_start_add_of_reachesIn (applyTM M) hreach).2.2 i + rw [show ((⟨(applyTM M).qstart, inp₀, applyPre M y inp₀, parkedBlank⟩ : + Cfg (k + 2) (applyTM M).Q).work i).head = 1 from applyPre_head M y inp₀ i] at hh + omega + · rw [reachesIn_work_cells_far hreach i j + (by rw [applyPre_head M y inp₀ i]; omega)] + exact applyPre_cells_blank M y inp₀ i j (by omega) + +/-- The evaluator's entry configuration is the retargeted one, which is the form the window +theorems are stated about. -/ +theorem applyTM_entry_eq (M : TM k) (y : List Bool) (realInput : Tape) : + (⟨(applyTM M).qstart, realInput, applyPre M y realInput, parkedBlank⟩ : + Cfg (k + 2) (applyTM M).Q) + = (retargetInputStarted M).retargetCfg (retargetInputStartedCfg M y realInput) := by + refine Cfg.ext rfl rfl (funext fun i => ?_) rfl + by_cases hi : i.val < k + 1 + · have hidx : (Fin.castSucc (⟨i.val, hi⟩ : Fin (k + 1)) : Fin (k + 2)) = i := Fin.ext rfl + show applyPre M y realInput i + = (if h : i.val < k + 1 then (retargetInputStartedCfg M y realInput).work ⟨i.val, h⟩ + else (retargetInputStartedCfg M y realInput).output) + rw [dif_pos hi, ← congrFun (applyPre_spec M y realInput).1 ⟨i.val, hi⟩, hidx] + · have hlast : i = Fin.last (k + 1) := Fin.ext (by + have h1 := i.isLt + have h2 : (Fin.last (k + 1)).val = k + 1 := rfl + omega) + show applyPre M y realInput i + = (if h : i.val < k + 1 then (retargetInputStartedCfg M y realInput).work ⟨i.val, h⟩ + else (retargetInputStartedCfg M y realInput).output) + rw [dif_neg hi, hlast, (applyPre_spec M y realInput).2] + rfl + +/-- **The decider's evaluator, framed by its space bound.** The disturbance is bounded by the +source machine's *space*, not by its running time: a space-bounded machine may run for +exponentially many steps, and a caller that had to wipe that many cells could not stay in +polynomial space. -/ +theorem applyTM_hoareTime_decide_space_frame (M : TM k) {L : Language} {T S : ℕ → ℕ} + (hdecT : M.DecidesInTime L T) (hdecS : M.DecidesInSpace L S) + (y : List Bool) (inp₀ : Tape) (hinp : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (H : ℕ) (hHS : y.length + S y.length + 2 ≤ H) : + (applyTM M).HoareTime + (fun inp work out => inp = inp₀ ∧ work = applyPre M y inp₀ ∧ out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + ((y ∈ L → (work (Fin.last (k + 1))).cells 1 = Γ.one) ∧ + (y ∉ L → (work (Fin.last (k + 1))).cells 1 = Γ.zero)) ∧ + ∀ i, Tape.StartInvariant (work i) ∧ (work i).head ≤ H ∧ + ∀ j, H < j → (work i).cells j = Γ.blank) + (T y.length) := by + have hne : M.qstart ≠ M.qhalt := qstart_ne_qhalt_of_decidesInTime M hdecT + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + rw [hi, hw, ho] + obtain ⟨c', t, ht, hreach, hhalt, hVerdict, hOutEq⟩ := + applyTM_hoareTime_decide M hdecT y inp₀ (applyPre M y inp₀) parkedBlank + ⟨(applyPre_spec M y inp₀).1, (applyPre_spec M y inp₀).2, rfl⟩ + have hinpEq : c'.input = inp₀ := + reachesIn_input_eq_of_idlesInput (applyTM_idlesInput M) hreach hinp + have hSI := reachesIn_startInvariant hreach hinpSI + (fun i => applyPre_startInvariant M y inp₀ i) + (show Tape.StartInvariant parkedBlank from startInvariant_initNil.move Dir3.right) + have hwin : ∀ D, (applyTM M).reaches + (⟨(applyTM M).qstart, inp₀, applyPre M y inp₀, parkedBlank⟩ : + Cfg (k + 2) (applyTM M).Q) D → + ∀ i, (D.work i).head ≤ H := by + intro D hD i + rw [applyTM_entry_eq M y inp₀] at hD + have := applyTM_keepsWindow_of_decidesInSpace M hdecS hne y inp₀ hinpSI + (inputLength := inp₀.head) (space := y.length + S y.length + 1) (le_refl _) + (by omega) D hD + have hle := this.1.1 i + omega + refine ⟨c', t, ht, hreach, hhalt, hinpEq, hOutEq, hVerdict, + fun i => ⟨hSI.2.1 i, ?_, fun j hj => ?_⟩⟩ + · exact hwin c' (reaches_of_reachesIn hreach) i + · refine work_cells_far_of_reachesIn H hreach hwin (fun i' p hp => ?_) i j hj + exact applyPre_cells_blank M y inp₀ i' p (by omega) + + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/IdleHeads.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/IdleHeads.lean new file mode 100644 index 00000000..b9c68945 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/IdleHeads.lean @@ -0,0 +1,375 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Subroutines.ParkAll +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Loop +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Seq +public import Complexitylib.Models.TuringMachine.Combinators.Internal.If + +/-! +# Heads that idle never drift outward + +Space accounting for the phase machinery of the combinators rests on one fact. Between phases, +and throughout the rewind and check phases, every tape is moved by `idleDir` — and on a tape +carrying its left marker that sends the head to exactly `max head 1`: it bounces off cell `0` +and otherwise stands still. So however many steps a rewind takes, no head drifts outward, and a +space bound established before the phase survives it with no additive slack. + +The output tape is the exception: it is walked left to the marker and then one cell right, which +is still within `max head 1`. + +## Main results + +- `TM.head_writeAndMove_idleDir_le_max` — an idle write-and-move stays within `max head 1` +- `TM.seq_head_bound` — the step `seqTM` interposes between its two simulations idles every tape +- `TM.loop_head_bound` — every phase of `loopTM` outside the two simulations keeps every head + within `max head 1` +- `TM.if_head_bound` — the same for `ifTM` +- `TM.loop_idle_step_state`, `TM.if_idle_step_state` — an interposed step lands only at + another interposed phase or at a start state +- `TM.loopTM_rewind_loop_frame` — the rewind phase of `loopTM` leaves the input and work + tapes identical, heads included +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- A head that only ever moves right off the left marker stays within `max head 1`. -/ +theorem head_move_le_max (t : Tape) (d : Dir3) (hd : d = Dir3.right → t.head = 0) : + (t.move d).head ≤ max t.head 1 := by + cases d + · show t.head - 1 ≤ _ + omega + · show t.head + 1 ≤ _ + rw [hd rfl] + omega + · show t.head ≤ _ + omega + +/-- The same for a write followed by a move: writing does not move the head. -/ +theorem head_writeAndMove_le_max (t : Tape) (w : Γw) (d : Dir3) + (hd : d = Dir3.right → t.head = 0) : + (t.writeAndMove w d).head ≤ max t.head 1 := by + show ((t.write w.toΓ).move d).head ≤ _ + have h : (t.write w.toΓ).head = t.head := Tape.write_head _ _ + have := head_move_le_max (t.write w.toΓ) d (by rw [h]; exact hd) + rw [h] at this + exact this + +/-- An idle move never leaves `max head 1`. -/ +theorem head_move_idleDir_le_max {t : Tape} (h : t.StartInvariant) : + (t.move (idleDir t.read)).head ≤ max t.head 1 := by + rw [move_idleDir_eq_of_startInvariant h] + +/-- An idle write-and-move never leaves `max head 1`. -/ +theorem head_writeAndMove_idleDir_le_max (t : Tape) (w : Γw) (h : t.StartInvariant) : + (t.writeAndMove w (idleDir t.read)).head ≤ max t.head 1 := by + refine head_writeAndMove_le_max t w _ fun hd => ?_ + by_contra hne + exact absurd hd (by rw [idleDir, if_neg (h.read_ne_start (by omega))]; nofun) + +/-- **The single step `seqTM` interposes between its two simulations idles every tape.** -/ +theorem seq_head_bound (tm₁ tm₂ : TM n) {c c' : Cfg n (seqTM tm₁ tm₂).Q} + (hstate : c.state = Sum.inl tm₁.qhalt) + (hstep : (seqTM tm₁ tm₂).step c = some c') + (hinp : c.input.StartInvariant) (hwork : ∀ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.head ≤ max c.input.head 1 ∧ + (∀ i, (c'.work i).head ≤ max (c.work i).head 1) ∧ + c'.output.head ≤ max c.output.head 1 := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [seqTM, hstate, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + +/-- **Outside its two simulation phases, `loopTM` never grows a head beyond `max head 1`.** +The phase transitions and the rewind and check phases all idle the input and work tapes, and +move the output head right only off the left marker. -/ +theorem loop_head_bound (tmBody tmTest : TM n) {c c' : Cfg n (loopTM tmBody tmTest).Q} + (hbody : ∀ q, c.state = Sum.inl q → q = tmBody.qhalt) + (htest : ∀ q, c.state = Sum.inr (Sum.inr q) → q = tmTest.qhalt) + (hstep : (loopTM tmBody tmTest).step c = some c') + (hinp : c.input.StartInvariant) (hwork : ∀ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.head ≤ max c.input.head 1 ∧ + (∀ i, (c'.work i).head ≤ max (c.work i).head 1) ∧ + c'.output.head ≤ max c.output.head 1 := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + rcases hstate : c.state with q | phq + · have hq : q = tmBody.qhalt := hbody q hstate + subst hq + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [loopTM, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + · rcases phq with ph | q + · cases ph with + | rewindOut => + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [loopTM] + · split <;> exact head_move_idleDir_le_max hinp + · split <;> exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · split + · rename_i hread + refine head_writeAndMove_le_max _ _ _ fun _ => ?_ + by_contra hh + exact (hout.2 c.output.head (by omega)) hread + · exact head_writeAndMove_le_max _ _ _ (by nofun) + | check => + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [loopTM] + · split <;> exact head_move_idleDir_le_max hinp + · split <;> exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · split <;> exact head_writeAndMove_idleDir_le_max _ _ hout + | done => exact absurd hstate hne + · have hq : q = tmTest.qhalt := htest q hstate + subst hq + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [loopTM, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + +/-- **Outside its three simulation phases, `ifTM` never grows a head beyond `max head 1`.** -/ +theorem if_head_bound (tmTest tmThen tmElse : TM n) + {c c' : Cfg n (ifTM tmTest tmThen tmElse).Q} + (ht : ∀ q, c.state = Sum.inl q → q = tmTest.qhalt) + (hthen : ∀ q, c.state = Sum.inr (Sum.inr (Sum.inl q)) → q = tmThen.qhalt) + (helse : ∀ q, c.state = Sum.inr (Sum.inr (Sum.inr q)) → q = tmElse.qhalt) + (hstep : (ifTM tmTest tmThen tmElse).step c = some c') + (hinp : c.input.StartInvariant) (hwork : ∀ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.head ≤ max c.input.head 1 ∧ + (∀ i, (c'.work i).head ≤ max (c.work i).head 1) ∧ + c'.output.head ≤ max c.output.head 1 := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + rcases hstate : c.state with q | phq + · have hq : q = tmTest.qhalt := ht q hstate + subst hq + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [ifTM, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + · rcases phq with ph | bq + · cases ph with + | rewindOut => + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [ifTM] + · split <;> exact head_move_idleDir_le_max hinp + · split <;> exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · split + · rename_i hread + refine head_writeAndMove_le_max _ _ _ fun _ => ?_ + by_contra hh + exact (hout.2 c.output.head (by omega)) hread + · exact head_writeAndMove_le_max _ _ _ (by nofun) + | check => + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [ifTM] + · split <;> exact head_move_idleDir_le_max hinp + · split <;> exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · split <;> exact head_writeAndMove_idleDir_le_max _ _ hout + | done => exact absurd hstate hne + · rcases bq with q | q + · have hq : q = tmThen.qhalt := hthen q hstate + subst hq + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [ifTM, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + · have hq : q = tmElse.qhalt := helse q hstate + subst hq + refine ⟨?_, fun i => ?_, ?_⟩ <;> simp only [ifTM, ↓reduceIte] + · exact head_move_idleDir_le_max hinp + · exact head_writeAndMove_idleDir_le_max _ _ (hwork i) + · exact head_writeAndMove_idleDir_le_max _ _ hout + +/-- **Outside its three simulations, `ifTM` steps only to an interposed phase or to a branch's +start state.** -/ +theorem if_idle_step_state (tmTest tmThen tmElse : TM n) + {c c' : Cfg n (ifTM tmTest tmThen tmElse).Q} + (ht : ∀ q, c.state = Sum.inl q → q = tmTest.qhalt) + (hthen : ∀ q, c.state = Sum.inr (Sum.inr (Sum.inl q)) → q = tmThen.qhalt) + (helse : ∀ q, c.state = Sum.inr (Sum.inr (Sum.inr q)) → q = tmElse.qhalt) + (hstep : (ifTM tmTest tmThen tmElse).step c = some c') : + (∃ ph, c'.state = Sum.inr (Sum.inl ph)) ∨ + c'.state = Sum.inr (Sum.inr (Sum.inl tmThen.qstart)) ∨ + c'.state = Sum.inr (Sum.inr (Sum.inr tmElse.qstart)) := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + rcases hstate : c.state with q | phq + · have hq : q = tmTest.qhalt := ht q hstate + subst hq + exact Or.inl ⟨IfPhase.rewindOut, by simp only [ifTM, ↓reduceIte]⟩ + · rcases phq with ph | bq + · cases ph with + | rewindOut => + by_cases hread : c.output.read = Γ.start + · exact Or.inl ⟨IfPhase.check, by simp only [ifTM, hread, ↓reduceIte]⟩ + · exact Or.inl ⟨IfPhase.rewindOut, by simp only [ifTM, hread, ↓reduceIte]⟩ + | check => + by_cases hread : c.output.read = Γ.one + · exact Or.inr (Or.inl (by simp only [ifTM, hread, ↓reduceIte])) + · exact Or.inr (Or.inr (by simp only [ifTM, hread, ↓reduceIte])) + | done => exact absurd hstate hne + · rcases bq with q | q + · have hq : q = tmThen.qhalt := hthen q hstate + subst hq + exact Or.inl ⟨IfPhase.done, by simp only [ifTM, ↓reduceIte]⟩ + · have hq : q = tmElse.qhalt := helse q hstate + subst hq + exact Or.inl ⟨IfPhase.done, by simp only [ifTM, ↓reduceIte]⟩ + +/-- From one of the interposed phases, `loopTM` moves either to another such phase or back to the +body's start state. -/ +theorem loop_phase_step_state (tmBody tmTest : TM n) {c c' : Cfg n (loopTM tmBody tmTest).Q} + {ph : LoopPhase} (hstate : c.state = Sum.inr (Sum.inl ph)) + (hstep : (loopTM tmBody tmTest).step c = some c') : + (∃ ph', c'.state = Sum.inr (Sum.inl ph')) ∨ c'.state = Sum.inl tmBody.qstart := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + cases ph with + | rewindOut => + by_cases hread : c.output.read = Γ.start + · exact Or.inl ⟨LoopPhase.check, by simp only [loopTM, hstate, hread, ↓reduceIte]⟩ + · exact Or.inl ⟨LoopPhase.rewindOut, by simp only [loopTM, hstate, hread, ↓reduceIte]⟩ + | check => + by_cases hread : c.output.read = Γ.one + · exact Or.inl ⟨LoopPhase.done, by simp only [loopTM, hstate, hread, ↓reduceIte]⟩ + · exact Or.inr (by simp only [loopTM, hstate, hread, ↓reduceIte]) + | done => exact absurd hstate hne + +/-- **An interposed step lands at a start state or at another interposed phase.** So the only way +back into the body or the test is through their start states — which is what lets a loop invariant +be re-established once per iteration. -/ +theorem loop_idle_step_state (tmBody tmTest : TM n) {c c' : Cfg n (loopTM tmBody tmTest).Q} + (hb : ∀ q, c.state = Sum.inl q → q = tmBody.qhalt) + (ht : ∀ q, c.state = Sum.inr (Sum.inr q) → q = tmTest.qhalt) + (hstep : (loopTM tmBody tmTest).step c = some c') : + (∀ q, c'.state = Sum.inl q → q = tmBody.qstart) ∧ + (∀ q, c'.state = Sum.inr (Sum.inr q) → q = tmTest.qstart) := by + have hne := state_ne_qhalt_of_step hstep + rcases hstate : c.state with q | phq + · have hq : q = tmBody.qhalt := hb q hstate + subst hq + have hc : c = loopBodyWrap tmBody tmTest ⟨tmBody.qhalt, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + rw [hc, loopTM_body_to_test tmBody tmTest rfl] at hstep + rw [← Option.some_inj.mp hstep] + exact ⟨fun _ h => absurd h (by nofun), fun _ h => by injection h.symm with h'; injection h'⟩ + · rcases phq with ph | q + · rcases loop_phase_step_state tmBody tmTest hstate hstep with ⟨ph', hph'⟩ | hqs + · exact ⟨fun _ h => absurd (h.symm.trans hph') (by nofun), + fun _ h => absurd (h.symm.trans hph') (by nofun)⟩ + · exact ⟨fun _ h => by injection h.symm.trans hqs, + fun _ h => absurd (h.symm.trans hqs) (by nofun)⟩ + · have hq : q = tmTest.qhalt := ht q hstate + subst hq + have hc : c = loopTestWrap tmBody tmTest ⟨tmTest.qhalt, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + rw [hc, loopTM_test_to_rewind tmBody tmTest rfl] at hstep + rw [← Option.some_inj.mp hstep] + exact ⟨fun _ h => absurd h (by nofun), fun _ h => by injection h.symm with h'; injection h'⟩ + +/-! ## The rewind phase leaves the input and work tapes alone -/ + +/-- One leftward rewind step of `loopTM`, framed: the input and work tapes are untouched. -/ +theorem loop_rewind_step_left_frame (tmBody tmTest : TM n) + (c : Cfg n (loopTM tmBody tmTest).Q) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hread_ne : c.output.read ≠ Γ.start) + (_hc0 : c.output.cells 0 = Γ.start) (_hns : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hih : c.input.head ≥ 1) (hins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (hwh : ∀ i, (c.work i).head ≥ 1) (hwns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.rewindOut) ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · simp only [Tape.writeAndMove, Tape.move] + rw [toΓ_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read] + split + · omega + · simp + · simp only [Tape.writeAndMove, Tape.move_cells] + rw [toΓ_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read] + split + · rfl + · exact Function.update_eq_self _ _ + · exact tape_move_idleDir_stable c.input hih hins + · funext i + exact tape_writeAndMove_stable (c.work i) (hwh i) (hwns i) + +/-- The final rewind step of `loopTM`, framed. -/ +theorem loop_rewind_step_base_frame (tmBody tmTest : TM n) + (c : Cfg n (loopTM tmBody tmTest).Q) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hread : c.output.read = Γ.start) + (_hc0 : c.output.cells 0 = Γ.start) (hnostart : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hih : c.input.head ≥ 1) (hins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (hwh : ∀ i, (c.work i).head ≥ 1) (hwns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + have hhead : c.output.head = 0 := by + by_contra hcon + have hge : c.output.head ≥ 1 := by omega + exact hnostart c.output.head hge (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + · exact tape_move_idleDir_stable c.input hih hins + · funext i + exact tape_writeAndMove_stable (c.work i) (hwh i) (hwns i) + +/-- **The rewind phase of `loopTM`, framed.** From `rewindOut` with the output head at `p`, the +machine reaches `check` in `p + 1` steps with the output head at cell 1, the output cells +unchanged, and the input and work tapes *identical* — heads included. This is what lets a loop +invariant on the work tapes survive the phase and be re-established for the next iteration. -/ +theorem loopTM_rewind_loop_frame (tmBody tmTest : TM n) (p : ℕ) + (c : Cfg n (loopTM tmBody tmTest).Q) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hc0 : c.output.cells 0 = Γ.start) (hns : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hp : c.output.head = p) + (hih : c.input.head ≥ 1) (hins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (hwh : ∀ i, (c.work i).head ≥ 1) (hwns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c_check, + (loopTM tmBody tmTest).reachesIn (p + 1) c c_check ∧ + c_check.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c_check.output.head = 1 ∧ + c_check.output.cells = c.output.cells ∧ + c_check.input = c.input ∧ + c_check.work = c.work := + exists_reachesIn_of_rewindStep_frame (loopTM tmBody tmTest) + (fun d h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₈ => + loop_rewind_step_left_frame tmBody tmTest d h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₈) + (fun d h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₈ => + loop_rewind_step_base_frame tmBody tmTest d h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₈) + p c hstate hc0 hns hp hih hins hwh hwns + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIndexed.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIndexed.lean new file mode 100644 index 00000000..63c07817 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIndexed.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Hoare + +/-! +# Running a loop a fixed number of times + +`TM.loopTM_hoareTime` proves a loop terminates from an invariant and a decreasing variant. A +counting loop has a more specific shape: its tape state is indexed by how many iterations have +run, the index advances by one each time, and the loop stops at a known count. The rule below +packages that shape, so a client supplies only two facts — one iteration advances the index, and +the loop halts at the final index — with the fuel bookkeeping discharged here. + +The index has to be readable from the tapes, since `TM.loopTM_hoareTime`'s variant is a function +of them; in practice it is the counter the loop is iterating. + +## Main results + +- `TM.loopTM_hoareTime_indexed` — a loop that runs to a known iteration count +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **A loop that runs to a known iteration count.** `E j` describes the tapes after `j` +iterations and `idx` reads the index back off them. Given that one iteration carries `E j` to +`E (j + 1)` for every `j` below `N`, and that the loop halts from `E N` with `post`, the loop +carries `E 0` to `post`. -/ +theorem loopTM_hoareTime_indexed (tmBody tmTest : TM n) + {E : ℕ → TapePred n} {post : TapePred n} {N b : ℕ} + {idx : Tape → (Fin n → Tape) → Tape → ℕ} + (hidx : ∀ j inp work out, E j inp work out → idx inp work out = j) + (hstep : ∀ j, j < N → ∀ inp work out, E j inp work out → + ∃ inp' work' out' t, t ≤ b ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + E (j + 1) inp' work' out') + (hstop : ∀ inp work out, E N inp work out → + ∃ c' t, t ≤ b ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ post c'.input c'.work c'.output) : + (loopTM tmBody tmTest).HoareTime + (E 0) post ((N + 1) * b) := by + refine (loopTM_hoareTime tmBody tmTest + (inv := fun inp work out => ∃ j ≤ N, E j inp work out) + (variant := fun inp work out => N - idx inp work out) + (b_iter := b) (k := N) (fun inp work out _ => Nat.sub_le N _) ?_).consequence + (fun inp work out h => ⟨0, Nat.zero_le N, h⟩) (fun _ _ _ h => h) (le_refl _) + rintro inp work out ⟨j, hjN, hEj⟩ + rcases Nat.lt_or_ge j N with hlt | hge + · obtain ⟨inp', work', out', t, ht, hreach, hE'⟩ := hstep j hlt inp work out hEj + refine Or.inr ⟨inp', work', out', t, ht, hreach, ⟨j + 1, by omega, hE'⟩, ?_⟩ + show N - idx inp' work' out' < N - idx inp work out + rw [hidx j inp work out hEj, hidx (j + 1) inp' work' out' hE'] + omega + · have hjeq : j = N := by omega + subst hjeq + exact Or.inl (hstop inp work out hEj) + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIteration.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIteration.lean new file mode 100644 index 00000000..7608dd18 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/LoopIteration.lean @@ -0,0 +1,313 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.IdleHeads + +/-! +# One `loopTM` iteration that continues + +`TM.loopTM_iteration_halt` traces a single pass through `loopTM` that ends in the halting +branch. The complementary pass — the one where the test says *keep going* — had no counterpart, +which left the indexed loop rule `TM.loopTM_hoareTime_indexed` without a way to discharge its +per-iteration obligation: that obligation asks for a run from the loop's start state back to the +loop's start state, and only the check phase's continue branch produces one. + +The pass is body, then test, then the rewind of the output tape, then the check. Everything +outside the two simulations moves each tape by `idleDir` and writes back what it read, so on +tapes that carry their left marker and are parked past it the whole phase machinery is the +identity — which is what makes an invariant on the work tapes survive into the next iteration. + +## Main results + +- `TM.loopTM_check_continue_frame` — the continue branch of the check phase leaves every tape + identical +- `TM.loopTM_iteration_continue` — a full iteration returning to `qstart`, tapes and all +- `TM.loopTM_check_halt_frame`, `TM.loopTM_iteration_halt_frame` — the halting pass, likewise + reporting the tapes it ends on +- `TM.loopTM_continue_of_hoare`, `TM.loopTM_halt_of_hoare` — both passes packaged as the two + obligations of `TM.loopTM_hoareTime_indexed`, from a contract for the body and one for the test +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **The continue branch of the check phase, framed.** Everything the branch does is write back +what it read and move by `idleDir`, so a tape parked past its left marker is untouched. -/ +theorem loopTM_check_continue_frame (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 ≠ Γ.one) + (hout : Parked c.output) (hinp : Parked c.input) (hwork : ∀ i, Parked (c.work i)) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = (loopTM tmBody tmTest).qstart ∧ + c'.input = c.input ∧ c'.work = c.work ∧ c'.output = c.output := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + have hread_ne : c.output.read ≠ Γ.one := by + simp only [Tape.read, hhead]; exact hcell1 + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · exact transitionInput_eq_self hinp.read_ne_start + · funext i + exact transitionTape_eq_self (hwork i).read_ne_start + · exact transitionTape_eq_self hout.read_ne_start + +/-- **One full `loopTM` iteration that continues.** The body runs to its halt state, the test +runs to its halt state, the output tape is rewound to cell one, and the verdict cell fails to +hold `1` — so the machine returns to its own start state with the test's tapes intact. + +The step count matches `TM.loopTM_iteration_halt`: the two simulations, the two phase +transitions between them, the rewind of `p + 1` steps, and the check. -/ +theorem loopTM_iteration_continue (tmBody tmTest : TM n) + {t_body : ℕ} {c_body_start c_body_end : Cfg n tmBody.Q} + (hreach_body : tmBody.reachesIn t_body c_body_start c_body_end) + (hhalt_body : c_body_end.state = tmBody.qhalt) + (hinp_body : Parked c_body_end.input) (hwork_body : ∀ i, Parked (c_body_end.work i)) + (hout_body : Parked c_body_end.output) + {t_test : ℕ} {c_test_end : Cfg n tmTest.Q} + (hreach_test : tmTest.reachesIn t_test + ⟨tmTest.qstart, c_body_end.input, c_body_end.work, c_body_end.output⟩ c_test_end) + (hhalt_test : c_test_end.state = tmTest.qhalt) + (hinp_test : Parked c_test_end.input) (hwork_test : ∀ i, Parked (c_test_end.work i)) + (hout_test : Parked c_test_end.output) (hout0 : c_test_end.output.cells 0 = Γ.start) + {p : ℕ} (hp : c_test_end.output.head = p) + (hcell1 : c_test_end.output.cells 1 ≠ Γ.one) : + ∃ c_final, + (loopTM tmBody tmTest).reachesIn (t_body + 1 + t_test + 1 + (p + 1) + 1) + (loopBodyWrap tmBody tmTest c_body_start) c_final ∧ + c_final.state = (loopTM tmBody tmTest).qstart ∧ + c_final.input = c_test_end.input ∧ + c_final.work = c_test_end.work ∧ + c_final.output.head = 1 ∧ + c_final.output.cells = c_test_end.output.cells := by + -- Phase 1: the body simulation. + have hp1 := loopTM_body_simulation tmBody tmTest hreach_body + -- Body → test: one step, and the parked tapes pass through unchanged. + have h_tr1 : (loopTM tmBody tmTest).reachesIn 1 + (loopBodyWrap tmBody tmTest c_body_end) + (loopTestWrap tmBody tmTest + ⟨tmTest.qstart, c_body_end.input, c_body_end.work, c_body_end.output⟩) := by + refine .step ?_ .zero + have h := loopTM_body_to_test tmBody tmTest hhalt_body + rw [h] + congr 1 + refine Cfg.ext rfl ?_ ?_ ?_ + · exact transitionInput_eq_self hinp_body.read_ne_start + · funext i + exact transitionTape_eq_self (hwork_body i).read_ne_start + · exact transitionTape_eq_self hout_body.read_ne_start + -- Phase 2: the test simulation. + have hp2 := loopTM_test_simulation tmBody tmTest hreach_test + -- Test → rewind: one step, again the identity on parked tapes. + have h_tr2 : (loopTM tmBody tmTest).reachesIn 1 + (loopTestWrap tmBody tmTest c_test_end) + ⟨Sum.inr (Sum.inl LoopPhase.rewindOut), c_test_end.input, c_test_end.work, + c_test_end.output⟩ := by + refine .step ?_ .zero + have h := loopTM_test_to_rewind tmBody tmTest hhalt_test + rw [h] + congr 1 + refine Cfg.ext rfl ?_ ?_ ?_ + · exact transitionInput_eq_self hinp_test.read_ne_start + · funext i + exact transitionTape_eq_self (hwork_test i).read_ne_start + · exact transitionTape_eq_self hout_test.read_ne_start + -- The rewind, which is where the output head returns to cell one. + obtain ⟨c_check, hreach_rw, hst_check, hh_check, hcells_check, hin_check, hwk_check⟩ := + loopTM_rewind_loop_frame tmBody tmTest p + ⟨Sum.inr (Sum.inl LoopPhase.rewindOut), c_test_end.input, c_test_end.work, + c_test_end.output⟩ + rfl hout0 hout_test.2 hp hinp_test.1 hinp_test.2 + (fun i => (hwork_test i).1) (fun i => (hwork_test i).2) + -- The check, taking the continue branch. + obtain ⟨c_done, hstep_done, hst_done, hin_done, hwk_done, hout_done⟩ := + loopTM_check_continue_frame tmBody tmTest c_check hst_check hh_check + (by rw [hcells_check]; exact hcell1) + ⟨by omega, by rw [hcells_check]; exact hout_test.2⟩ + (by rw [hin_check]; exact hinp_test) + (by rw [hwk_check]; exact fun i => hwork_test i) + refine ⟨c_done, ?_, hst_done, ?_, ?_, ?_, ?_⟩ + · exact reachesIn_trans _ (reachesIn_trans _ (reachesIn_trans _ + (reachesIn_trans _ (reachesIn_trans _ hp1 h_tr1) hp2) h_tr2) hreach_rw) + (.step hstep_done .zero) + · rw [hin_done, hin_check] + · rw [hwk_done, hwk_check] + · rw [hout_done, hh_check] + · rw [hout_done, hcells_check] + + +/-- **The halting branch of the check phase, framed.** As with the continue branch, the step +writes back what it read and idles, so parked tapes are untouched. -/ +theorem loopTM_check_halt_frame (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 = Γ.one) + (hout : Parked c.output) (hinp : Parked c.input) (hwork : ∀ i, Parked (c.work i)) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + c'.input = c.input ∧ c'.work = c.work ∧ c'.output = c.output := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + have hread : c.output.read = Γ.one := by simp only [Tape.read, hhead]; exact hcell1 + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · exact transitionInput_eq_self hinp.read_ne_start + · funext i + exact transitionTape_eq_self (hwork i).read_ne_start + · show c.output.writeAndMove (readBackWrite Γ.one).toΓ (idleDir Γ.one) = c.output + rw [← hread] + exact transitionTape_eq_self hout.read_ne_start + +/-- **One full `loopTM` iteration that halts, framed.** The same pass as +`TM.loopTM_iteration_halt`, but reporting the input and work tapes of the halted configuration — +which a loop's postcondition generally talks about, and which the unframed version discards. -/ +theorem loopTM_iteration_halt_frame (tmBody tmTest : TM n) + {t_body : ℕ} {c_body_start c_body_end : Cfg n tmBody.Q} + (hreach_body : tmBody.reachesIn t_body c_body_start c_body_end) + (hhalt_body : c_body_end.state = tmBody.qhalt) + (hinp_body : Parked c_body_end.input) (hwork_body : ∀ i, Parked (c_body_end.work i)) + (hout_body : Parked c_body_end.output) + {t_test : ℕ} {c_test_end : Cfg n tmTest.Q} + (hreach_test : tmTest.reachesIn t_test + ⟨tmTest.qstart, c_body_end.input, c_body_end.work, c_body_end.output⟩ c_test_end) + (hhalt_test : c_test_end.state = tmTest.qhalt) + (hinp_test : Parked c_test_end.input) (hwork_test : ∀ i, Parked (c_test_end.work i)) + (hout_test : Parked c_test_end.output) (hout0 : c_test_end.output.cells 0 = Γ.start) + {p : ℕ} (hp : c_test_end.output.head = p) + (hcell1 : c_test_end.output.cells 1 = Γ.one) : + ∃ c_final, + (loopTM tmBody tmTest).reachesIn (t_body + 1 + t_test + 1 + (p + 1) + 1) + (loopBodyWrap tmBody tmTest c_body_start) c_final ∧ + (loopTM tmBody tmTest).halted c_final ∧ + c_final.input = c_test_end.input ∧ + c_final.work = c_test_end.work ∧ + c_final.output.head = 1 ∧ + c_final.output.cells = c_test_end.output.cells := by + have hp1 := loopTM_body_simulation tmBody tmTest hreach_body + have h_tr1 : (loopTM tmBody tmTest).reachesIn 1 + (loopBodyWrap tmBody tmTest c_body_end) + (loopTestWrap tmBody tmTest + ⟨tmTest.qstart, c_body_end.input, c_body_end.work, c_body_end.output⟩) := by + refine .step ?_ .zero + rw [loopTM_body_to_test tmBody tmTest hhalt_body] + congr 1 + refine Cfg.ext rfl (transitionInput_eq_self hinp_body.read_ne_start) ?_ + (transitionTape_eq_self hout_body.read_ne_start) + funext i + exact transitionTape_eq_self (hwork_body i).read_ne_start + have hp2 := loopTM_test_simulation tmBody tmTest hreach_test + have h_tr2 : (loopTM tmBody tmTest).reachesIn 1 + (loopTestWrap tmBody tmTest c_test_end) + ⟨Sum.inr (Sum.inl LoopPhase.rewindOut), c_test_end.input, c_test_end.work, + c_test_end.output⟩ := by + refine .step ?_ .zero + rw [loopTM_test_to_rewind tmBody tmTest hhalt_test] + congr 1 + refine Cfg.ext rfl (transitionInput_eq_self hinp_test.read_ne_start) ?_ + (transitionTape_eq_self hout_test.read_ne_start) + funext i + exact transitionTape_eq_self (hwork_test i).read_ne_start + obtain ⟨c_check, hreach_rw, hst_check, hh_check, hcells_check, hin_check, hwk_check⟩ := + loopTM_rewind_loop_frame tmBody tmTest p + ⟨Sum.inr (Sum.inl LoopPhase.rewindOut), c_test_end.input, c_test_end.work, + c_test_end.output⟩ + rfl hout0 hout_test.2 hp hinp_test.1 hinp_test.2 + (fun i => (hwork_test i).1) (fun i => (hwork_test i).2) + obtain ⟨c_done, hstep_done, hst_done, hin_done, hwk_done, hout_done⟩ := + loopTM_check_halt_frame tmBody tmTest c_check hst_check hh_check + (by rw [hcells_check]; exact hcell1) + ⟨by omega, by rw [hcells_check]; exact hout_test.2⟩ + (by rw [hin_check]; exact hinp_test) + (by rw [hwk_check]; exact fun i => hwork_test i) + refine ⟨c_done, ?_, hst_done, ?_, ?_, ?_, ?_⟩ + · exact reachesIn_trans _ (reachesIn_trans _ (reachesIn_trans _ + (reachesIn_trans _ (reachesIn_trans _ hp1 h_tr1) hp2) h_tr2) hreach_rw) + (.step hstep_done .zero) + · rw [hin_done, hin_check] + · rw [hwk_done, hwk_check] + · rw [hout_done, hh_check] + · rw [hout_done, hcells_check] + +/-- The side conditions a loop's intermediate and final tape states must meet for the phase +machinery to be transparent: every tape carries its left marker nowhere but cell zero, and every +head is parked past it. -/ +def LoopParked {n : ℕ} (inp : Tape) (work : Fin n → Tape) (out : Tape) : Prop := + Parked inp ∧ (∀ i, Parked (work i)) ∧ Parked out ∧ out.cells 0 = Γ.start ∧ out.head = 1 + +/-- **The per-iteration obligation of `TM.loopTM_hoareTime_indexed`, from two Hoare triples.** +Give a contract for the body and one for the test; if the test's postcondition leaves the tapes +parked with a verdict cell that is not `1`, the loop returns to its own start state with that +postcondition intact. -/ +theorem loopTM_continue_of_hoare (tmBody tmTest : TM n) + {E mid E' : TapePred n} {bBody bTest : ℕ} + (hbody : tmBody.HoareTime E mid bBody) + (htest : tmTest.HoareTime mid E' bTest) + (hmid : ∀ inp work out, mid inp work out → LoopParked inp work out) + (hpost : ∀ inp work out, E' inp work out → + LoopParked inp work out ∧ out.cells 1 ≠ Γ.one) : + ∀ inp work out, E inp work out → + ∃ inp' work' out' t, 1 ≤ t ∧ t ≤ bBody + bTest + 5 ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + E' inp' work' out' := by + intro inp work out hE + obtain ⟨cb, tb, htb, hreachb, hhb, hmidb⟩ := hbody inp work out hE + obtain ⟨hbi, hbw, hbo, hbo0, hbo1⟩ := hmid _ _ _ hmidb + obtain ⟨ct, tt, htt, hreacht, hht, hE't⟩ := htest cb.input cb.work cb.output hmidb + obtain ⟨⟨hti, htw, hto, hto0, hto1⟩, hne⟩ := hpost _ _ _ hE't + obtain ⟨cf, hreach, hstf, hinf, hwkf, hheadf, hcellsf⟩ := + loopTM_iteration_continue tmBody tmTest hreachb hhb hbi hbw hbo hreacht hht hti htw hto + hto0 hto1 hne + refine ⟨cf.input, cf.work, cf.output, tb + 1 + tt + 1 + (1 + 1) + 1, by omega, by omega, ?_, ?_⟩ + · have : (⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ : Cfg n _) + = loopBodyWrap tmBody tmTest ⟨tmBody.qstart, inp, work, out⟩ := rfl + rw [this] + have hcf : (⟨(loopTM tmBody tmTest).qstart, cf.input, cf.work, cf.output⟩ : Cfg n _) = cf := + Cfg.ext hstf.symm rfl rfl rfl + rw [hcf] + exact hreach + · have hout' : cf.output = ct.output := Tape.ext (by rw [hheadf, hto1]) hcellsf + rw [hinf, hwkf, hout'] + exact hE't + +/-- **The terminating obligation of `TM.loopTM_hoareTime_indexed`, from two Hoare triples.** The +companion of `TM.loopTM_continue_of_hoare` for the pass whose verdict cell does hold `1`. -/ +theorem loopTM_halt_of_hoare (tmBody tmTest : TM n) + {E mid E' : TapePred n} {bBody bTest : ℕ} + (hbody : tmBody.HoareTime E mid bBody) + (htest : tmTest.HoareTime mid E' bTest) + (hmid : ∀ inp work out, mid inp work out → LoopParked inp work out) + (hpost : ∀ inp work out, E' inp work out → + LoopParked inp work out ∧ out.cells 1 = Γ.one) : + ∀ inp work out, E inp work out → + ∃ c' t, t ≤ bBody + bTest + 5 ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ E' c'.input c'.work c'.output := by + intro inp work out hE + obtain ⟨cb, tb, htb, hreachb, hhb, hmidb⟩ := hbody inp work out hE + obtain ⟨hbi, hbw, hbo, hbo0, hbo1⟩ := hmid _ _ _ hmidb + obtain ⟨ct, tt, htt, hreacht, hht, hE't⟩ := htest cb.input cb.work cb.output hmidb + obtain ⟨⟨hti, htw, hto, hto0, hto1⟩, heq⟩ := hpost _ _ _ hE't + obtain ⟨cf, hreach, hstf, hinf, hwkf, hheadf, hcellsf⟩ := + loopTM_iteration_halt_frame tmBody tmTest hreachb hhb hbi hbw hbo hreacht hht hti htw hto + hto0 hto1 heq + refine ⟨cf, tb + 1 + tt + 1 + (1 + 1) + 1, by omega, hreach, hstf, ?_⟩ + have hout' : cf.output = ct.output := Tape.ext (by rw [hheadf, hto1]) hcellsf + rw [hinf, hwkf, hout'] + exact hE't + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/RetargetWindow.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/RetargetWindow.lean new file mode 100644 index 00000000..73863821 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/RetargetWindow.lean @@ -0,0 +1,297 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import Complexitylib.Models.TuringMachine.Combinators.RetargetCompute +public import Complexitylib.Models.TuringMachine.Lift +public import Complexitylib.Models.TuringMachine.Combinators.Apply +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Window + +/-! +# Space accounting for a machine reading its input off a work tape + +`TM.retargetInput` runs a machine `M` with its input tape relocated to work tape `k`. That +relocation is exactly what a space bound has to be re-read through: what was `M`'s *free* input +tape becomes a *charged* work tape, so the window the retargeted machine needs is `M`'s own space +budget plus the length of the virtual input. + +The correspondence is step-by-step (`TM.retargetInput_step_commute`), so every configuration the +retargeted machine reaches is a wrapped configuration of `M` — with the real input tape, which it +never consults, drifting only by an idle move. `M`'s bound on its own run therefore transfers. + +## Main results + +- `TM.retargetInput_within` — a wrapped configuration is inside the window when `M`'s is +- `TM.retargetInput_keepsWindow_of_reaches` — the whole retargeted run stays inside it +- `TM.retargetInputStarted_reaches_iff`, `TM.retargetInputStarted_keepsWindow_of_reaches` — the + started wrapper runs the same steps, so the accounting carries over +- `TM.retargetOutput_keepsWindow_of_reaches` — redirecting the output onto a work tape costs one + cell of window +- `TM.applyTM_keepsWindow_of_reaches` — **the two composed**: the window of the work-to-work + evaluator +- `TM.applyTM_keepsWindow_of_decidesInSpace` — the same from a `TM.DecidesInSpace` hypothesis +- `TM.liftTM_keepsWindow_of_reaches` — adding spare work tapes costs no window +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : ℕ} + +/-- A wrapped configuration sits inside a window as soon as the wrapped `M`-configuration does: +`M`'s work heads and its relocated input head are all charged against the new budget. -/ +theorem retargetInput_within (M : TM k) (r : Tape) (c : Cfg k M.Q) + {m s inputLength space : ℕ} (hc : c.WithinDecisionSpace m s) + (hspace : m + s + 1 ≤ space) (hr : r.head ≤ inputLength + space + 1) : + (retargetWrap M r c).WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, hr⟩, ?_⟩ + · by_cases h : i.val < k + · rw [retargetWrap_work_lt M r c i h] + have := hc.1.1 ⟨i.val, h⟩ + omega + · have hlt := i.isLt + have hik : i = ⟨k, by omega⟩ := by + apply Fin.ext + show i.val = k + omega + rw [hik, retargetWrap_work_last M r c] + have := hc.1.2 + omega + · have := hc.2 + show c.output.head ≤ space + 1 + omega + +/-- **The retargeted run stays inside the window.** Every configuration reachable from a wrapped +start is itself wrapped — the step correspondence is exact — so `M`'s bound on its own run is the +only thing needed. -/ +theorem retargetInput_keepsWindow_of_reaches (M : TM k) (r₀ : Tape) (c₀ : Cfg k M.Q) + {m s inputLength space : ℕ} + (hM : ∀ c, M.reaches c₀ c → c.WithinDecisionSpace m s) + (hc₀inp : Tape.StartInvariant c₀.input) + (hc₀work : ∀ i, Tape.StartInvariant (c₀.work i)) + (hc₀out : Tape.StartInvariant c₀.output) + (hr₀ : Tape.StartInvariant r₀) + (hspace : m + s + 1 ≤ space) + (hr : max r₀.head 1 ≤ inputLength + space + 1) : + ∀ d, (retargetInput M).reaches (retargetWrap M r₀ c₀) d → + d.WithinDecisionSpace inputLength space := by + have key : ∀ d, (retargetInput M).reaches (retargetWrap M r₀ c₀) d → + ∃ r c, M.reaches c₀ c ∧ Tape.StartInvariant c.input ∧ + (∀ i, Tape.StartInvariant (c.work i)) ∧ Tape.StartInvariant c.output ∧ + Tape.StartInvariant r ∧ r.head ≤ max r₀.head 1 ∧ d = retargetWrap M r c := by + intro d hd + induction hd with + | refl => + exact ⟨r₀, c₀, Relation.ReflTransGen.refl, hc₀inp, hc₀work, hc₀out, hr₀, + le_max_left _ _, rfl⟩ + | @tail dmid dnext _ hstep ih => + obtain ⟨r, cM, hreach, hinp, hwork, hout, hrsi, hrhead, rfl⟩ := ih + have hstep' : (retargetInput M).step (retargetWrap M r cM) = some dnext := hstep + have hne0 : (retargetWrap M r cM).state ≠ (retargetInput M).qhalt := + state_ne_qhalt_of_step hstep' + have hne : cM.state ≠ M.qhalt := hne0 + obtain ⟨cM', hstep0⟩ : ∃ cM', M.step cM = some cM' := by + rw [TM.step, if_neg hne] + exact ⟨_, rfl⟩ + have hcomm := retargetInput_step_commute M hstep0 r hinp + have hd'eq := Option.some_inj.mp (hstep'.symm.trans hcomm) + obtain ⟨hinp', hwork', hout'⟩ := Tape.StartInvariant.step M hstep0 hinp hwork hout + refine ⟨r.move (idleDir r.read), cM', Relation.ReflTransGen.tail hreach hstep0, + hinp', hwork', hout', ?_, ?_, hd'eq⟩ + · rw [move_idleDir_eq_of_startInvariant hrsi] + exact ⟨hrsi.1, hrsi.2⟩ + · rw [move_idleDir_eq_of_startInvariant hrsi] + show max r.head 1 ≤ max r₀.head 1 + omega + intro d hd + obtain ⟨r, cM, hreach, -, -, -, -, hrhead, rfl⟩ := key d hd + exact retargetInput_within M r cM (hM cM hreach) hspace (by omega) + +/-! ## The started wrapper -/ + +/-- The started wrapper and the plain retargeted machine have the same step relation, so they +reach exactly the same configurations. Only their start states differ. -/ +theorem retargetInputStarted_reaches_iff (M : TM k) (c d : Cfg (k + 1) M.Q) : + (retargetInputStarted M).reaches c d ↔ (retargetInput M).reaches c d := by + constructor + · intro h + induction h with + | refl => exact Relation.ReflTransGen.refl + | tail _ hs ih => + exact Relation.ReflTransGen.tail ih + ((retargetInputStarted_step_eq M _).symm.trans hs) + · intro h + induction h with + | refl => exact Relation.ReflTransGen.refl + | tail _ hs ih => + exact Relation.ReflTransGen.tail ih + ((retargetInputStarted_step_eq M _).trans hs) + +/-- **The started wrapper keeps the window too.** It runs the same steps as `TM.retargetInput`, +so the accounting of `TM.retargetInput_keepsWindow_of_reaches` applies verbatim. -/ +theorem retargetInputStarted_keepsWindow_of_reaches (M : TM k) (r₀ : Tape) (c₀ : Cfg k M.Q) + {m s inputLength space : ℕ} + (hM : ∀ c, M.reaches c₀ c → c.WithinDecisionSpace m s) + (hc₀inp : Tape.StartInvariant c₀.input) + (hc₀work : ∀ i, Tape.StartInvariant (c₀.work i)) + (hc₀out : Tape.StartInvariant c₀.output) + (hr₀ : Tape.StartInvariant r₀) + (hspace : m + s + 1 ≤ space) + (hr : max r₀.head 1 ≤ inputLength + space + 1) : + ∀ d, (retargetInputStarted M).reaches (retargetWrap M r₀ c₀) d → + d.WithinDecisionSpace inputLength space := fun d hd => + retargetInput_keepsWindow_of_reaches M r₀ c₀ hM hc₀inp hc₀work hc₀out hr₀ hspace hr d + ((retargetInputStarted_reaches_iff M _ d).mp hd) + +/-! ## Redirecting the output to a work tape -/ + +/-- **Redirecting the output onto a work tape costs one cell.** The old output tape becomes work +tape `n`, and the decision convention allows the output head one cell more than the work heads, so +the window grows by exactly that. The real output tape is left parked as a dummy. -/ +theorem retargetOutput_keepsWindow_of_reaches {m : ℕ} (tm : TM m) (c₀ : Cfg m tm.Q) + {inputLength space : ℕ} + (htm : ∀ c, tm.reaches c₀ c → c.WithinDecisionSpace inputLength space) : + ∀ D, tm.retargetOutput.reaches (tm.retargetCfg c₀) D → + D.WithinDecisionSpace inputLength (space + 1) := by + have key : ∀ D, tm.retargetOutput.reaches (tm.retargetCfg c₀) D → + ∃ c, tm.reaches c₀ c ∧ D = tm.retargetCfg c := by + intro D hD + induction hD with + | refl => exact ⟨c₀, Relation.ReflTransGen.refl, rfl⟩ + | @tail dmid dnext _ hs ih => + obtain ⟨c, hreach, rfl⟩ := ih + have hs' : tm.retargetOutput.step (tm.retargetCfg c) = some dnext := hs + rw [retargetOutput_step_retargetCfg] at hs' + cases hstep : tm.step c with + | none => + rw [hstep] at hs' + exact absurd hs' (by nofun) + | some c' => + rw [hstep] at hs' + exact ⟨c', Relation.ReflTransGen.tail hreach hstep, + (Option.some_inj.mp hs').symm⟩ + intro D hD + obtain ⟨c, hreach, rfl⟩ := key D hD + have hc := htm c hreach + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · by_cases h : i.val < m + · rw [retargetCfg_work_lt tm c i h] + have := hc.1.1 ⟨i.val, h⟩ + omega + · have hlt := i.isLt + have hil : i = Fin.last m := by + apply Fin.ext + show i.val = m + omega + rw [hil, retargetCfg_work_last tm c] + have := hc.2 + omega + · show c.input.head ≤ _ + have := hc.1.2 + omega + · show ((Tape.init ([] : List Γ)).move Dir3.right).head ≤ space + 1 + 1 + show 0 + 1 ≤ space + 1 + 1 + omega + +/-! ## The work-to-work evaluator -/ + +/-- **The work-to-work evaluator keeps a window.** `TM.applyTM M` is +`M` retargeted twice — its input read off a work tape, its output written to another — so its +window is `M`'s own decision-space budget, plus the virtual input's length for the relocated +input tape, plus one cell for the relocated output tape. Every quantity is explicit, so a caller +that knows `M`'s polynomial space bound knows this one. -/ +theorem applyTM_keepsWindow_of_reaches (M : TM k) (r₀ : Tape) (c₀ : Cfg k M.Q) + {m s inputLength space : ℕ} + (hM : ∀ c, M.reaches c₀ c → c.WithinDecisionSpace m s) + (hc₀inp : Tape.StartInvariant c₀.input) + (hc₀work : ∀ i, Tape.StartInvariant (c₀.work i)) + (hc₀out : Tape.StartInvariant c₀.output) + (hr₀ : Tape.StartInvariant r₀) + (hspace : m + s + 1 ≤ space) + (hr : max r₀.head 1 ≤ inputLength + space + 1) : + ∀ D, (applyTM M).reaches + ((retargetInputStarted M).retargetCfg (retargetWrap M r₀ c₀)) D → + D.WithinDecisionSpace inputLength (space + 1) := + retargetOutput_keepsWindow_of_reaches (retargetInputStarted M) (retargetWrap M r₀ c₀) + (retargetInputStarted_keepsWindow_of_reaches M r₀ c₀ hM hc₀inp hc₀work hc₀out hr₀ hspace hr) + +/-- **The evaluator's window, from the source machine's space bound alone.** Started on the +canonical entry configuration with virtual input `y`, `TM.applyTM M` stays inside a window of +`|y| + S |y| + 2` — the source's own budget, the relocated input tape, and one cell for the +relocated output. This is the form a caller with a `TM.DecidesInSpace` hypothesis can use. -/ +theorem applyTM_keepsWindow_of_decidesInSpace (M : TM k) {L : Language} {S : ℕ → ℕ} + (hdec : M.DecidesInSpace L S) (hne : M.qstart ≠ M.qhalt) + (y : List Bool) (realInput : Tape) (hrsi : Tape.StartInvariant realInput) + {inputLength space : ℕ} + (hspace : y.length + S y.length + 1 ≤ space) + (hr : max realInput.head 1 ≤ inputLength + space + 1) : + ∀ D, (applyTM M).reaches + ((retargetInputStarted M).retargetCfg (retargetInputStartedCfg M y realInput)) D → + D.WithinDecisionSpace inputLength (space + 1) := by + rw [retargetInputStartedCfg_eq_retargetWrap M y realInput hne] + refine applyTM_keepsWindow_of_reaches M realInput (startedCfg M y hne) ?_ ?_ ?_ ?_ hrsi + hspace hr + · intro c hreach + exact hdec.1 y c (Relation.ReflTransGen.head (step_initCfg_startedCfg M y hne) hreach) + · rw [startedCfg_input_eq M y hne] + exact (startInvariant_initOfBool y).move Dir3.right + · intro i + rw [startedCfg_work_eq_init_move_right M y hne i] + exact startInvariant_initNil.move Dir3.right + · rw [startedCfg_output_eq_init_move_right M y hne] + exact startInvariant_initNil.move Dir3.right + + +/-! ## Embedding a machine in a larger tape space -/ + +/-- **Adding spare work tapes costs no window.** `TM.liftTM` runs a machine unchanged alongside +`m` extra tapes, which stay parked at cell one throughout, so a configuration of the lifted +machine sits in exactly the window its underlying configuration does. This is how a subroutine is +placed inside a machine with more tapes than it needs. -/ +theorem liftTM_keepsWindow_of_reaches {m' : ℕ} (tm : TM m') (m : ℕ) (c₀ : Cfg m' tm.Q) + {inputLength space : ℕ} (hs : 1 ≤ space) + (htm : ∀ c, tm.reaches c₀ c → c.WithinDecisionSpace inputLength space) : + ∀ D, (tm.liftTM m).reaches (tm.liftCfg m c₀) D → + D.WithinDecisionSpace inputLength space := by + have key : ∀ D, (tm.liftTM m).reaches (tm.liftCfg m c₀) D → + ∃ c, tm.reaches c₀ c ∧ D = tm.liftCfg m c := by + intro D hD + induction hD with + | refl => exact ⟨c₀, Relation.ReflTransGen.refl, rfl⟩ + | @tail dmid dnext _ hstp ih => + obtain ⟨c, hreach, rfl⟩ := ih + have hs' : (tm.liftTM m).step (tm.liftCfg m c) = some dnext := hstp + rw [liftTM_step_liftCfg] at hs' + cases hstep : tm.step c with + | none => + rw [hstep] at hs' + exact absurd hs' (by nofun) + | some c' => + rw [hstep] at hs' + exact ⟨c', Relation.ReflTransGen.tail hreach hstep, + (Option.some_inj.mp hs').symm⟩ + intro D hD + obtain ⟨c, hreach, rfl⟩ := key D hD + have hc := htm c hreach + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · by_cases hi : i.val < m' + · rw [liftCfg_work_lt tm m c i hi] + exact hc.1.1 ⟨i.val, hi⟩ + · rw [liftCfg_work_ge tm m c i (by omega)] + show ((Tape.init ([] : List Γ)).move Dir3.right).head ≤ space + show 0 + 1 ≤ space + omega + · show c.input.head ≤ _ + exact hc.1.2 + · show c.output.head ≤ _ + exact hc.2 + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/SentinelStep.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/SentinelStep.lean new file mode 100644 index 00000000..2457a7ef --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/SentinelStep.lean @@ -0,0 +1,254 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.RetargetCompute + +/-! +# The sentinel step moves heads and nothing else + +Every machine begins with all heads on `▷`, and `TM.δ_right_of_start` forces that first +transition to move each of them right. Since cell zero is immutable, the transition's writes are +no-ops, so the step's whole effect is to move every head from cell zero to cell one — the control +state it lands in, `TM.retargetInputStartState`, being determined by the machine alone. + +`TM.startedCfg` records this for the *canonical* initial configuration, where every work tape is +blank. But the reads are `▷` on every tape whatever the tapes hold beyond cell zero, so the same +description holds from any configuration with its heads at zero. That generality is what lets a +composed machine hand a simulation an already-loaded work tape — a counter, say — and still enter +it at the state `TM.retargetInputStarted` expects. + +## Main results + +- `TM.step_of_heads_zero` — the sentinel step from any all-heads-at-zero configuration +- `TM.startedTM` — a machine resumed after that step, ready to be a stage of a composed machine +- `TM.reachesIn_of_startedTM`, `TM.reachesIn_startedTM` — the two machines reach the same + configurations +- `TM.reachesIn_succ_of_startedTM` — a run of the resumed machine is a run of the original +- `TM.step_input_cells`, `TM.reachesIn_input_cells` — the input tape is read-only +- `TM.startInvariant_reachesIn` — the left-marker invariant survives a whole run +- `TM.step_work_cells_ne` — a step writes only under its head +- `TM.head_transitionTape_le_max`, `TM.head_transitionInput_le_max` — a phase transition never + pushes a head outward +- `TM.startInvariant_transitionTape`, `TM.startInvariant_transitionInput` — and preserves the + left-marker invariant +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : ℕ} + +/-- A write at cell zero is a no-op, so writing and moving there is just moving. -/ +theorem writeAndMove_of_head_zero (t : Tape) (s : Γ) (d : Dir3) (h : t.head = 0) : + t.writeAndMove s d = t.move d := by + simp only [Tape.writeAndMove, Tape.write, h, ↓reduceIte] + +/-- **The sentinel step, from any configuration whose heads are at cell zero.** Only the heads +move; every tape keeps its contents, and the state reached is the machine's own +`TM.retargetInputStartState`. -/ +theorem step_of_heads_zero (M : TM k) (c : Cfg k M.Q) + (hstate : c.state = M.qstart) (hne : M.qstart ≠ M.qhalt) + (hin : c.input.head = 0) (hwork : ∀ i, (c.work i).head = 0) (hout : c.output.head = 0) + (hin0 : c.input.cells 0 = Γ.start) (hwork0 : ∀ i, (c.work i).cells 0 = Γ.start) + (hout0 : c.output.cells 0 = Γ.start) : + M.step c = some ⟨retargetInputStartState M, c.input.move Dir3.right, + fun i => (c.work i).move Dir3.right, c.output.move Dir3.right⟩ := by + have hri : c.input.read = Γ.start := by rw [Tape.read, hin]; exact hin0 + have hrw : ∀ i, (c.work i).read = Γ.start := by + intro i; rw [Tape.read, hwork i]; exact hwork0 i + have hro : c.output.read = Γ.start := by rw [Tape.read, hout]; exact hout0 + have hdirs := M.δ_right_of_start M.qstart Γ.start (fun _ => Γ.start) Γ.start + simp only [TM.step, hstate, if_neg hne, hri, hro, funext hrw] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + · show (c.input.move _) = _ + rw [hdirs.1 rfl] + · funext i + show (c.work i).writeAndMove _ _ = _ + rw [writeAndMove_of_head_zero _ _ _ (hwork i), hdirs.2.1 i rfl] + · show c.output.writeAndMove _ _ = _ + rw [writeAndMove_of_head_zero _ _ _ hout, hdirs.2.2 rfl] + + +/-- **A machine resumed after its sentinel step.** Same transition function, same halt state; +only the start state is moved forward to where the compulsory `▷`-step lands. This is the form a +machine has to take to be run as a stage of a composed machine, which can never hand it a head at +cell zero. + +Unlike `TM.retargetInputStarted` this leaves the input tape alone. That is the right choice when +the composed machine's own input tape already carries what the stage should read: it is parked at +cell one, which is exactly where the sentinel step would have left it. -/ +def startedTM (M : TM k) : TM k := + { M with + qstart := if M.qstart = M.qhalt then M.qhalt + else (M.δ M.qstart Γ.start (fun _ => Γ.start) Γ.start).1 } + +@[simp] theorem startedTM_qhalt (M : TM k) : (startedTM M).qhalt = M.qhalt := rfl + +/-- Resuming changes no transition, so the two machines step identically. -/ +@[simp] theorem startedTM_step (M : TM k) (c : Cfg k M.Q) : + (startedTM M).step c = M.step c := rfl + +/-- …and therefore reach exactly the same configurations. -/ +theorem reachesIn_of_startedTM (M : TM k) {t : ℕ} {c c' : Cfg k (startedTM M).Q} + (h : (startedTM M).reachesIn t c c') : M.reachesIn t c c' := by + induction h with + | zero => exact .zero + | step hs _ ih => exact .step hs ih + +/-- …and conversely. -/ +theorem reachesIn_startedTM (M : TM k) {t : ℕ} {c c' : Cfg k M.Q} + (h : M.reachesIn t c c') : (startedTM M).reachesIn t c c' := by + induction h with + | zero => exact .zero + | step hs _ ih => exact .step hs ih + +/-- **What the resumed machine's start state is worth.** A configuration with every head at cell +zero steps, in one move, to the resumed machine's own start configuration on the same tapes with +every head at cell one. So a run of the resumed machine from there is a run of the original, one +step in — with whatever the tapes were carrying still on them. -/ +theorem reachesIn_succ_of_startedTM (M : TM k) (c : Cfg k M.Q) + (hstate : c.state = M.qstart) (hne : M.qstart ≠ M.qhalt) + (hin : c.input.head = 0) (hwork : ∀ i, (c.work i).head = 0) (hout : c.output.head = 0) + (hin0 : c.input.cells 0 = Γ.start) (hwork0 : ∀ i, (c.work i).cells 0 = Γ.start) + (hout0 : c.output.cells 0 = Γ.start) + {t : ℕ} {c' : Cfg k M.Q} + (hreach : (startedTM M).reachesIn t + ⟨(startedTM M).qstart, c.input.move Dir3.right, + fun i => (c.work i).move Dir3.right, c.output.move Dir3.right⟩ c') : + M.reachesIn (t + 1) c c' := by + have hq : (startedTM M).qstart = retargetInputStartState M := by + show (if M.qstart = M.qhalt then M.qhalt else retargetInputStartState M) = _ + rw [if_neg hne] + have hstep : M.step c = some ⟨(startedTM M).qstart, c.input.move Dir3.right, + fun i => (c.work i).move Dir3.right, c.output.move Dir3.right⟩ := by + rw [hq] + exact step_of_heads_zero M c hstate hne hin hwork hout hin0 hwork0 hout0 + exact .step hstep (reachesIn_of_startedTM M hreach) + + +/-- **The input tape is read-only.** A transition moves its head and nothing else, so its +contents survive any run — which is what lets a stage rewind the real input and hand the next +stage the tape it started with. -/ +theorem step_input_cells (M : TM k) {c c' : Cfg k M.Q} (h : M.step c = some c') : + c'.input.cells = c.input.cells := by + simp only [TM.step] at h + split at h + · exact absurd h (by simp) + · rw [← Option.some_inj.mp h] + show (c.input.move _).cells = _ + rw [Tape.move_cells] + +/-- …and therefore across a whole run. -/ +theorem reachesIn_input_cells (M : TM k) {t : ℕ} {c c' : Cfg k M.Q} + (h : M.reachesIn t c c') : c'.input.cells = c.input.cells := by + induction h with + | zero => rfl + | step hs _ ih => exact ih.trans (step_input_cells M hs) + +/-- **The left-marker invariant survives a whole run**, not just one step. Every transition +writes symbols drawn from `Γw`, and cell zero is immutable, so a machine can neither erase a +marker nor create one. -/ +theorem startInvariant_reachesIn (tm : TM n) {t : ℕ} {c c' : Cfg n tm.Q} + (h : tm.reachesIn t c c') : + c.input.StartInvariant → (∀ i, (c.work i).StartInvariant) → c.output.StartInvariant → + c'.input.StartInvariant ∧ (∀ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + induction h with + | zero => exact fun a b c => ⟨a, b, c⟩ + | step hstep _ ih => + intro hi hw ho + obtain ⟨h1, h2, h3⟩ := Tape.StartInvariant.step _ hstep hi hw ho + exact ih h1 h2 h3 + + +/-- **A step writes only under the head.** Every other cell of a work tape is left alone. -/ +theorem step_work_cells_ne (M : TM k) {c c' : Cfg k M.Q} (h : M.step c = some c') + (j : Fin k) (i : ℕ) (hi : i ≠ (c.work j).head) : + (c'.work j).cells i = (c.work j).cells i := by + simp only [TM.step] at h + split at h + · exact absurd h (by simp) + · rw [← Option.some_inj.mp h] + show ((c.work j).writeAndMove _ _).cells i = _ + rw [Tape.writeAndMove, Tape.move_cells, Tape.write] + split + · rfl + · exact Function.update_of_ne hi _ _ + +/-- **A phase transition never pushes a head outward.** On a tape carrying its marker only at +cell zero it moves a head sitting on the marker to cell one and leaves every other head alone, so +the head ends at `max head 1`. The library's bound of `head + 1` is too weak to survive a loop. -/ +theorem head_transitionTape_le_max {t : Tape} (h : Tape.StartInvariant t) : + (transitionTape t).head ≤ max t.head 1 := by + by_cases hh : t.head = 0 + · have hread : t.read = Γ.start := by + show t.cells t.head = Γ.start + rw [hh]; exact h.1 + unfold transitionTape Tape.writeAndMove + simp only [Tape.write, hh, ↓reduceIte, hread, idleDir, Tape.move] + omega + · have hread : t.read ≠ Γ.start := h.2 t.head (by omega) + rw [transitionTape_eq_self hread] + omega + +/-- The same for the input tape, which a transition only moves. -/ +theorem head_transitionInput_le_max {t : Tape} (h : Tape.StartInvariant t) : + (transitionInput t).head ≤ max t.head 1 := by + by_cases hh : t.head = 0 + · have hread : t.read = Γ.start := by + show t.cells t.head = Γ.start + rw [hh]; exact h.1 + unfold transitionInput + simp only [hread, idleDir, ↓reduceIte, Tape.move, hh] + omega + · have hread : t.read ≠ Γ.start := h.2 t.head (by omega) + rw [transitionInput_eq_self hread] + omega + +/-- A phase transition preserves the left-marker invariant. -/ +theorem startInvariant_transitionTape {t : Tape} (h : Tape.StartInvariant t) : + Tape.StartInvariant (transitionTape t) := by + refine ⟨?_, fun j hj => ?_⟩ + · rw [transitionTape_cells t (fun i hi => h.2 i hi)]; exact h.1 + · rw [transitionTape_cells t (fun i hi => h.2 i hi)]; exact h.2 j hj + +/-- …and so does the input tape's. -/ +theorem startInvariant_transitionInput {t : Tape} (h : Tape.StartInvariant t) : + Tape.StartInvariant (transitionInput t) := by + refine ⟨?_, fun j hj => ?_⟩ + · rw [transitionInput_cells]; exact h.1 + · rw [transitionInput_cells]; exact h.2 j hj + + +/-- **Runs from the same configuration are prefixes of one another.** A deterministic machine has +only one future, so a shorter run is an initial segment of a longer one. This is what lets a loop's +space argument work one iteration at a time: any configuration a run passes through either lies +inside the current iteration or is reached *through* the next iteration's start. -/ +theorem reachesIn_prefix (M : TM k) : ∀ {t t' : ℕ} {c d d' : Cfg k M.Q}, + M.reachesIn t c d → M.reachesIn t' c d' → t ≤ t' → M.reachesIn (t' - t) d d' := by + intro t + induction t with + | zero => + intro t' c d d' h h' _ + cases h + simpa using h' + | succ t ih => + intro t' c d d' h h' hle + obtain ⟨t'', rfl⟩ : ∃ t'', t' = t'' + 1 := ⟨t' - 1, by omega⟩ + cases h with + | step hs hr => + cases h' with + | step hs' hr' => + have heq := Option.some_inj.mp (hs.symm.trans hs') + subst heq + simpa using ih hr hr' (by omega) + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/SeqChain.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/SeqChain.lean new file mode 100644 index 00000000..2d16317a --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/SeqChain.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# Chaining a sequence of stages through pinned tape states + +A machine assembled from many subroutines is a `TM.bigSeqTM` of stages, each carrying the tape +state from one pinned configuration to the next. `TM.bigSeqTM_hoareTime` already chains stages, +but only through the `EmitPred` state shape, whose output component is a written list. A stage +that leaves a counter tape half-scanned, or two tallies at different values, does not fit that +shape. + +The rule below chains through *arbitrary* pinned states — a fixed input tape, a family of work +banks, and a family of output tapes — asking only that every pinned tape be `Parked`, which is +what makes the phase transitions between stages no-ops. + +## Main results + +- `TM.bigSeqTM_hoareTime_pinned_gen` — the chain rule for arbitrary pinned tape states, input + tape included +- `TM.bigSeqTM_hoareTime_pinned` — the same with a fixed input tape +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **Chaining stages through pinned tape states.** Stage `k` carries the pinned state `k` to the +pinned state `k + 1`; the fold carries state `0` to state `ms.length`. Every pinned tape is +required `Parked`, which makes the phase transition between consecutive stages a no-op. + +The input tape is indexed too. A stage may move the input head — a rewind does — and then the +next stage's precondition names a different input tape, so a single fixed one will not do. -/ +theorem bigSeqTM_hoareTime_pinned_gen : + ∀ (ms : List (TM n)) (I : ℕ → Tape) (W : ℕ → Fin n → Tape) (O : ℕ → Tape) (b : ℕ), + (∀ k, Parked (I k)) → (∀ k i, Parked (W k i)) → (∀ k, Parked (O k)) → + (∀ k, (hk : k < ms.length) → + ms[k].HoareTime (fun inp work out => inp = I k ∧ work = W k ∧ out = O k) + (fun inp work out => inp = I (k + 1) ∧ work = W (k + 1) ∧ out = O (k + 1)) b) → + (bigSeqTM ms).HoareTime + (fun inp work out => inp = I 0 ∧ work = W 0 ∧ out = O 0) + (fun inp work out => inp = I ms.length ∧ work = W ms.length ∧ out = O ms.length) + (ms.length * (b + 1) + 1) := by + intro ms + induction ms with + | nil => + intro I W O b hI hW hO _ + exact (skipTM_hoareTime_frame (I 0) (W 0) (O 0) (hI 0) (hW 0) (hO 0)).mono_bound (by simp) + | cons m ms ih => + intro I W O b hI hW hO hms + have hhead := hms 0 (by simp) + have hrest := ih (fun k => I (k + 1)) (fun k => W (k + 1)) (fun k => O (k + 1)) b + (fun k => hI (k + 1)) (fun k i => hW (k + 1) i) (fun k => hO (k + 1)) + (fun k hk => by + have h := hms (k + 1) (by simpa using Nat.succ_lt_succ hk) + simpa using h) + have htrans : ∀ inp work out, + (inp = I 1 ∧ work = W 1 ∧ out = O 1) → + (transitionInput inp = I 1 ∧ (fun i => transitionTape (work i)) = W 1 ∧ + transitionTape out = O 1) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨transitionInput_eq_self ((hI 1).read_ne_start), funext fun i => ?_, + transitionTape_eq_self ((hO 1).read_ne_start)⟩ + exact transitionTape_eq_self ((hW 1 i).read_ne_start) + have hseq := seqTM_hoareTime m (bigSeqTM ms) hhead htrans hrest + refine hseq.consequence (fun _ _ _ h => h) (fun _ _ _ h => ?_) ?_ + · show (_ = I (m :: ms).length ∧ _ = W (m :: ms).length ∧ _ = O (m :: ms).length) + rw [List.length_cons] + exact h + · rw [List.length_cons] + have hmul : (ms.length + 1) * (b + 1) = ms.length * (b + 1) + (b + 1) := Nat.succ_mul .. + omega + +/-- **The chain rule with a fixed input tape**, the common case: no stage moves the input head. -/ +theorem bigSeqTM_hoareTime_pinned (ms : List (TM n)) (I : Tape) (W : ℕ → Fin n → Tape) + (O : ℕ → Tape) (b : ℕ) + (hI : Parked I) (hW : ∀ k i, Parked (W k i)) (hO : ∀ k, Parked (O k)) + (hms : ∀ k, (hk : k < ms.length) → + ms[k].HoareTime (fun inp work out => inp = I ∧ work = W k ∧ out = O k) + (fun inp work out => inp = I ∧ work = W (k + 1) ∧ out = O (k + 1)) b) : + (bigSeqTM ms).HoareTime + (fun inp work out => inp = I ∧ work = W 0 ∧ out = O 0) + (fun inp work out => inp = I ∧ work = W ms.length ∧ out = O ms.length) + (ms.length * (b + 1) + 1) := + bigSeqTM_hoareTime_pinned_gen ms (fun _ => I) W O b (fun _ => hI) hW hO hms + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/Window.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/Window.lean new file mode 100644 index 00000000..1e354523 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/Window.lean @@ -0,0 +1,1374 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.IdleHeads +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SentinelStep +public import Complexitylib.Models.TuringMachine.Hoare.Space + +/-! +# Machines that respect a space window + +A `TM.HoareSpace` contract bounds every configuration reachable from a *start* state, which makes +it awkward to compose: the body of a loop is entered again and again, never from its own start. +The step-local strengthening below composes freely. A machine *respects a window* when one step +from any configuration inside the window lands inside the window again — regardless of where in +its own execution it happens to be. + +Respecting a window immediately gives a space contract, and the property is inherited by the loop +combinator from its body and test, because every phase `loopTM` interposes between them idles the +input and work tapes (`TM.loop_head_bound`). This is what lets a loop run for as long as it likes +without its space bound growing. + +`TM.RespectsWindow` is the step-local form, convenient when it applies. It is too strong for a +machine that simulates another one, whose own space bound holds only along its own run, so the +weaker `TM.KeepsWindow` — *started anywhere inside the window, everything reached stays inside* — +is the notion the composition rules are stated for. Every entry into a loop body is at its start +state, so this is exactly as much as a loop needs. + +A subroutine that simulates another machine is not robust even in that sense: run from a start +whose scratch tapes hold garbage, the simulated machine is not on any run its own space bound +covers. `TM.KeepsWindowOn` therefore carries a precondition on the starting tapes, which a +composition rule must re-establish at each entry from the previous stage's postcondition — +and `TM.halted_unique` is what makes such a postcondition usable, since it says the halted +configuration a stage reaches is the only one. + +The two forms meet at `TM.seqTM_keepsWindow_of_post`: a stage that needs blank scratch, prefixed +by a stage that clears it, is robust again. So a loop body assembled that way satisfies the plain +`TM.KeepsWindow` hypothesis of `TM.loopTM_keepsWindow`, and no precondition-carrying loop rule is +needed. + +## Main definitions + +- `TM.RespectsWindow` — one step from inside the window stays inside it +- `TM.KeepsWindow` — from any windowed start, every reachable configuration is windowed +- `TM.KeepsWindowOn` — the same, restricted to starts satisfying a precondition + +## Main results + +- `TM.hoareSpace_of_respectsWindow` — respecting a window is a space contract +- `TM.decidesInSpace_of_respectsWindow`, `TM.decidesInSpace_of_keepsWindow` — a window turns a + decider into a space-bounded decider +- `TM.halted_unique` — a deterministic run reaches at most one halted configuration +- `TM.keepsWindowOn_of_haltsIn`, `TM.keepsWindowOn_of_hoareTime`, + `TM.keepsWindowOn_of_hoareTime_pinned` — **any time-bounded subroutine, and any `TM.HoareTime` + contract, acquires a window contract** +- `TM.KeepsWindowOn.hoareSpace`, `TM.KeepsWindow.hoareSpace` — a window contract is a + `TM.HoareSpace` contract, so the two styles interoperate +- `TM.seqTM_respectsWindow`, `TM.loopTM_respectsWindow` — the step-local form composes +- `TM.seqTM_keepsWindow`, `TM.ifTM_keepsWindow`, `TM.loopTM_keepsWindow` — **and so does the + usable form**, for all three control-flow combinators +- `TM.seqTM_keepsWindowOn` — and the precondition-carrying form, for sequential composition +- `TM.seqTM_keepsWindow_of_post` — **the bridge**: prefixing a precondition-needing stage with a + robust one yields a robust composite, which the unconditional loop rule accepts +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- The tapes of a configuration all carry their left-end markers. -/ +def CfgStartInvariant {Q : Type} (c : Cfg n Q) : Prop := + c.input.StartInvariant ∧ (∀ i, (c.work i).StartInvariant) ∧ c.output.StartInvariant + +/-- **The machine respects a space window**: one step from any configuration inside the window +lands inside the window again — including the output head, so the discipline is the one +`TM.DecidesInSpace` asks for. Unlike `TM.HoareSpace` this says nothing about where the machine +started, so it survives being re-entered, which is what a loop body needs. -/ +def RespectsWindow (tm : TM n) (inputLength space : ℕ) : Prop := + ∀ c c' : Cfg n tm.Q, c.WithinDecisionSpace inputLength space → CfgStartInvariant c → + tm.step c = some c' → c'.WithinDecisionSpace inputLength space + +/-- The start-marker invariant is preserved by a step. -/ +theorem CfgStartInvariant.step {tm : TM n} {c c' : Cfg n tm.Q} + (h : CfgStartInvariant c) (hstep : tm.step c = some c') : CfgStartInvariant c' := + Tape.StartInvariant.step tm hstep h.1 h.2.1 h.2.2 + +/-- **Respecting a window is a space contract.** -/ +theorem hoareSpace_of_respectsWindow (tm : TM n) {inputLength space : ℕ} + (h : tm.RespectsWindow inputLength space) : + tm.HoareSpace + (fun inp work out => + ({ state := tm.qstart, input := inp, work := work, output := out } : + Cfg n tm.Q).WithinDecisionSpace inputLength space ∧ + CfgStartInvariant { state := tm.qstart, input := inp, work := work, output := out }) + inputLength space := + hoareSpace_of_invariant + (fun c => c.WithinDecisionSpace inputLength space ∧ CfgStartInvariant c) + (fun _ _ _ hpre => hpre) + (fun _ _ hP hstep => ⟨h _ _ hP.1 hP.2 hstep, hP.2.step hstep⟩) + (fun _ hP => hP.1.1) + +/-- **Sequential composition inherits the window.** The one step interposed between the two +machines idles every tape, so it cannot push a head outward. -/ +theorem seqTM_respectsWindow (tm₁ tm₂ : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + (h₁ : tm₁.RespectsWindow inputLength space) + (h₂ : tm₂.RespectsWindow inputLength space) : + (seqTM tm₁ tm₂).RespectsWindow inputLength space := by + intro c c' hwin hsi hstep + have hne := state_ne_qhalt_of_step hstep + rcases hstate : c.state with q | q + · by_cases hq : q = tm₁.qhalt + · subst hq + obtain ⟨hi, hw, ho⟩ := seq_head_bound tm₁ tm₂ hstate hstep hsi.1 hsi.2.1 hsi.2.2 + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have h₃ := hw i + have h₄ := hwin.1.1 i + omega + · have h₄ := hwin.1.2 + omega + · have h₄ := hwin.2 + omega + · have hc : c = phase1Wrap tm₁ tm₂ ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨c₀', hstep0⟩ : + ∃ c₀', tm₁.step ⟨q, c.input, c.work, c.output⟩ = some c₀' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsimstep := seqTM_phase1_step tm₁ tm₂ hstep0 + rw [hc] at hstep + have hc'eq : c' = phase1Wrap tm₁ tm₂ c₀' := + Option.some_inj.mp (hstep.symm.trans hsimstep) + subst hc'eq + exact h₁ _ _ hwin hsi hstep0 + · have hq : q ≠ tm₂.qhalt := by + intro h + exact hne (by rw [hstate, h]; rfl) + have hc : c = phase2Wrap tm₁ tm₂ ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨c₀', hstep0⟩ : + ∃ c₀', tm₂.step ⟨q, c.input, c.work, c.output⟩ = some c₀' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsimstep := seqTM_phase2_step tm₁ tm₂ hstep0 + rw [hc] at hstep + have hc'eq : c' = phase2Wrap tm₁ tm₂ c₀' := + Option.some_inj.mp (hstep.symm.trans hsimstep) + subst hc'eq + exact h₂ _ _ hwin hsi hstep0 + +/-- **The loop inherits its window from its body and test.** Every phase `loopTM` interposes +between the two idles the input and work tapes, so the interposed steps cannot push a head +outward; the simulated steps are covered by the parts' own contracts. The bound is therefore +independent of how many iterations run. -/ +theorem loopTM_respectsWindow (tmBody tmTest : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + (hbody : tmBody.RespectsWindow inputLength space) + (htest : tmTest.RespectsWindow inputLength space) : + (loopTM tmBody tmTest).RespectsWindow inputLength space := by + intro c c' hwin hsi hstep + by_cases hb : ∀ q, c.state = Sum.inl q → q = tmBody.qhalt + · by_cases ht : ∀ q, c.state = Sum.inr (Sum.inr q) → q = tmTest.qhalt + · obtain ⟨hi, hw, ho⟩ := loop_head_bound tmBody tmTest hb ht hstep hsi.1 hsi.2.1 hsi.2.2 + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have h₁ := hw i + have h₂ := hwin.1.1 i + omega + · have h₂ := hwin.1.2 + omega + · have h₂ := hwin.2 + omega + · push Not at ht + obtain ⟨q, hstate, hq⟩ := ht + have hc : c = loopTestWrap tmBody tmTest ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨c₀', hstep0⟩ : + ∃ c₀', tmTest.step ⟨q, c.input, c.work, c.output⟩ = some c₀' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsimstep := loopTM_test_step tmBody tmTest hstep0 + rw [hc] at hstep + have hc'eq : c' = loopTestWrap tmBody tmTest c₀' := + Option.some_inj.mp (hstep.symm.trans hsimstep) + subst hc'eq + exact htest _ _ hwin hsi hstep0 + · push Not at hb + obtain ⟨q, hstate, hq⟩ := hb + have hc : c = loopBodyWrap tmBody tmTest ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨c₀', hstep0⟩ : + ∃ c₀', tmBody.step ⟨q, c.input, c.work, c.output⟩ = some c₀' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsimstep := loopTM_body_step tmBody tmTest hstep0 + rw [hc] at hstep + have hc'eq : c' = loopBodyWrap tmBody tmTest c₀' := + Option.some_inj.mp (hstep.symm.trans hsimstep) + subst hc'eq + exact hbody _ _ hwin hsi hstep0 + +/-! ## Determinism at the halt -/ + +/-- A deterministic run reaches at most one halted configuration: the halt is the run's endpoint, +whichever way it is reached. This is what lets a stage's postcondition be *used* — the +configuration a composition rule meets at the phase boundary is the one the stage's Hoare triple +describes. -/ +theorem reachesIn_halted_unique {tm : TM n} : + ∀ {s t : ℕ} {c a b : Cfg n tm.Q}, tm.reachesIn s c a → tm.reachesIn t c b → + tm.halted a → tm.halted b → a = b := by + intro s + induction s with + | zero => + intro t c a b ha hb hha hhb + cases ha + cases hb with + | zero => rfl + | step hstep _ => + rw [TM.step, if_pos hha] at hstep + exact absurd hstep (by nofun) + | succ s ih => + intro t c a b ha hb hha hhb + cases ha with + | step hstepa hresta => + cases hb with + | zero => + rw [TM.step, if_pos hhb] at hstepa + exact absurd hstepa (by nofun) + | step hstepb hrestb => + rw [Option.some_inj.mp (hstepa.symm.trans hstepb)] at hresta + exact ih hresta hrestb hha hhb + +/-- The unbounded form of `TM.reachesIn_halted_unique`. -/ +theorem halted_unique {tm : TM n} {c a b : Cfg n tm.Q} + (ha : tm.reaches c a) (hb : tm.reaches c b) + (hha : tm.halted a) (hhb : tm.halted b) : a = b := by + obtain ⟨s, hs⟩ := TM.reaches_to_reachesIn tm ha + obtain ⟨t, ht⟩ := TM.reaches_to_reachesIn tm hb + exact reachesIn_halted_unique hs ht hha hhb + +/-! ## Keeping a window along a run -/ + +/-- **The machine keeps its window**: started anywhere inside the window with its left markers +intact, every configuration it reaches is still inside the window. This is weaker than +`TM.RespectsWindow` — it says nothing about configurations the machine cannot reach from a +windowed start — and it is what a subroutine that simulates another machine can actually +satisfy. -/ +def KeepsWindow (tm : TM n) (inputLength space : ℕ) : Prop := + ∀ c : Cfg n tm.Q, c.state = tm.qstart → c.WithinDecisionSpace inputLength space → + CfgStartInvariant c → ∀ c', tm.reaches c c' → c'.WithinDecisionSpace inputLength space + +/-- A machine that never steps out of the window certainly keeps it. -/ +theorem RespectsWindow.keepsWindow {tm : TM n} {inputLength space : ℕ} + (h : tm.RespectsWindow inputLength space) : tm.KeepsWindow inputLength space := by + intro c _ hwin hsi c' hreach + have key : ∀ d, tm.reaches c d → + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d := by + intro d hd + induction hd with + | refl => exact ⟨hwin, hsi⟩ + | tail _ hs ih => exact ⟨h _ _ ih.1 ih.2 hs, ih.2.step hs⟩ + exact (key c' hreach).1 + +/-- **Sequential composition keeps the window.** Each phase is entered at its machine's start +state with windowed tapes, and the single interposed step idles every tape. -/ +theorem seqTM_keepsWindow (tm₁ tm₂ : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + (h₁ : tm₁.KeepsWindow inputLength space) + (h₂ : tm₂.KeepsWindow inputLength space) : + (seqTM tm₁ tm₂).KeepsWindow inputLength space := by + intro c₀ hstart hwin₀ hsi₀ cfin hreach + set P : Cfg n (seqTM tm₁ tm₂).Q → Prop := fun c => + c.WithinDecisionSpace inputLength space ∧ CfgStartInvariant c ∧ + (∀ q, c.state = Sum.inl q → ∃ d : Cfg n tm₁.Q, d.state = tm₁.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tm₁.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ q, c.state = Sum.inr q → ∃ d : Cfg n tm₂.Q, d.state = tm₂.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tm₂.reaches d ⟨q, c.input, c.work, c.output⟩) with hPdef + have hstep : ∀ c c', P c → (seqTM tm₁ tm₂).step c = some c' → P c' := by + intro c c' ⟨hwin, hsi, hp1, hp2⟩ hst + have hne := state_ne_qhalt_of_step hst + have hsi' : CfgStartInvariant c' := hsi.step hst + rcases hstate : c.state with q | q + · by_cases hq : q = tm₁.qhalt + · subst hq + obtain ⟨hi, hw, ho⟩ := seq_head_bound tm₁ tm₂ hstate hst hsi.1 hsi.2.1 hsi.2.2 + have hwin' : c'.WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have := hw i; have := hwin.1.1 i; omega + · have := hwin.1.2; omega + · have := hwin.2; omega + refine ⟨hwin', hsi', ?_, ?_⟩ + · intro q' hq' + have hc : c = phase1Wrap tm₁ tm₂ ⟨tm₁.qhalt, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + rw [hc] at hst + rw [seqTM_transition_step tm₁ tm₂ rfl] at hst + rw [← Option.some_inj.mp hst] at hq' + exact absurd hq' (by nofun) + · intro q' hq' + have hc : c = phase1Wrap tm₁ tm₂ ⟨tm₁.qhalt, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + rw [hc] at hst + rw [seqTM_transition_step tm₁ tm₂ rfl] at hst + have hc' := Option.some_inj.mp hst + subst hc' + have hq2 : q' = tm₂.qstart := by + have : (Sum.inr tm₂.qstart : SeqQ tm₁.Q tm₂.Q) = Sum.inr q' := hq' + exact (Sum.inr.injEq _ _ ▸ this).symm + subst hq2 + exact ⟨_, rfl, hwin', hsi', Relation.ReflTransGen.refl⟩ + · obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hp1 q hstate + have hc : c = phase1Wrap tm₁ tm₂ ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tm₁.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq]; exact ⟨_, rfl⟩ + have hsim := seqTM_phase1_step tm₁ tm₂ hstep0 + rw [hc] at hst + have hc'eq : c' = phase1Wrap tm₁ tm₂ e' := Option.some_inj.mp (hst.symm.trans hsim) + have hre : tm₁.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + exact ⟨h₁ d hd0 hd1 hd2 e' hre, hsi', + fun q' hq' => ⟨d, hd0, hd1, hd2, by + rw [show (⟨q', (phase1Wrap tm₁ tm₂ e').input, (phase1Wrap tm₁ tm₂ e').work, + (phase1Wrap tm₁ tm₂ e').output⟩ : Cfg n tm₁.Q) = e' from + Cfg.ext (Sum.inl.injEq _ _ ▸ hq').symm rfl rfl rfl] + exact hre⟩, + fun _ hq' => absurd hq' (by nofun)⟩ + · have hq : q ≠ tm₂.qhalt := fun h => hne (by rw [hstate, h]; rfl) + obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hp2 q hstate + have hc : c = phase2Wrap tm₁ tm₂ ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tm₂.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq]; exact ⟨_, rfl⟩ + have hsim := seqTM_phase2_step tm₁ tm₂ hstep0 + rw [hc] at hst + have hc'eq : c' = phase2Wrap tm₁ tm₂ e' := Option.some_inj.mp (hst.symm.trans hsim) + have hre : tm₂.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + exact ⟨h₂ d hd0 hd1 hd2 e' hre, hsi', + fun _ hq' => absurd hq' (by nofun), + fun q' hq' => ⟨d, hd0, hd1, hd2, by + rw [show (⟨q', (phase2Wrap tm₁ tm₂ e').input, (phase2Wrap tm₁ tm₂ e').work, + (phase2Wrap tm₁ tm₂ e').output⟩ : Cfg n tm₂.Q) = e' from + Cfg.ext (Sum.inr.injEq _ _ ▸ hq').symm rfl rfl rfl] + exact hre⟩⟩ + have hinit : P c₀ := by + refine ⟨hwin₀, hsi₀, ?_, ?_⟩ + · intro q hq + have : q = tm₁.qstart := by + have h := hstart.symm.trans hq + exact (Sum.inl.injEq _ _ ▸ h).symm + subst this + exact ⟨_, rfl, hwin₀, hsi₀, Relation.ReflTransGen.refl⟩ + · intro q hq + rw [hstart] at hq + exact absurd hq (by nofun) + have key : ∀ c, (seqTM tm₁ tm₂).reaches c₀ c → P c := by + intro c h + induction h with + | refl => exact hinit + | tail _ hs ih => exact hstep _ _ ih hs + exact (key cfin hreach).1 + +/-- **The loop keeps the window, however many iterations it runs.** Body and test are each +entered at their own start state with windowed tapes, and every step the loop interposes between +them idles the input and work tapes, so nothing accumulates across iterations. -/ +theorem loopTM_keepsWindow (tmBody tmTest : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + (hbody : tmBody.KeepsWindow inputLength space) + (htest : tmTest.KeepsWindow inputLength space) : + (loopTM tmBody tmTest).KeepsWindow inputLength space := by + intro c₀ hstart hwin₀ hsi₀ cfin hreach + set P : Cfg n (loopTM tmBody tmTest).Q → Prop := fun c => + c.WithinDecisionSpace inputLength space ∧ CfgStartInvariant c ∧ + (∀ q, c.state = Sum.inl q → ∃ d : Cfg n tmBody.Q, d.state = tmBody.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tmBody.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ q, c.state = Sum.inr (Sum.inr q) → ∃ d : Cfg n tmTest.Q, d.state = tmTest.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tmTest.reaches d ⟨q, c.input, c.work, c.output⟩) with hPdef + have hstepP : ∀ c c', P c → (loopTM tmBody tmTest).step c = some c' → P c' := by + intro c c' ⟨hwin, hsi, hp1, hp2⟩ hst + have hne := state_ne_qhalt_of_step hst + have hsi' : CfgStartInvariant c' := hsi.step hst + by_cases hb : ∀ q, c.state = Sum.inl q → q = tmBody.qhalt + · by_cases ht : ∀ q, c.state = Sum.inr (Sum.inr q) → q = tmTest.qhalt + · obtain ⟨hi, hw, ho⟩ := loop_head_bound tmBody tmTest hb ht hst hsi.1 hsi.2.1 hsi.2.2 + have hwin' : c'.WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have := hw i; have := hwin.1.1 i; omega + · have := hwin.1.2; omega + · have := hwin.2; omega + obtain ⟨hs1, hs2⟩ := loop_idle_step_state tmBody tmTest hb ht hst + refine ⟨hwin', hsi', ?_, ?_⟩ + · intro q' hq' + exact ⟨⟨q', c'.input, c'.work, c'.output⟩, hs1 q' hq', hwin', hsi', + Relation.ReflTransGen.refl⟩ + · intro q' hq' + exact ⟨⟨q', c'.input, c'.work, c'.output⟩, hs2 q' hq', hwin', hsi', + Relation.ReflTransGen.refl⟩ + · push Not at ht + obtain ⟨q, hstate, hq⟩ := ht + obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hp2 q hstate + have hc : c = loopTestWrap tmBody tmTest ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmTest.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq]; exact ⟨_, rfl⟩ + have hsim := loopTM_test_step tmBody tmTest hstep0 + rw [hc] at hst + have hc'eq : c' = loopTestWrap tmBody tmTest e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmTest.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + exact ⟨htest d hd0 hd1 hd2 e' hre, hsi', + fun _ hq' => absurd hq' (by nofun), + fun q' hq' => ⟨d, hd0, hd1, hd2, by + rw [show (⟨q', (loopTestWrap tmBody tmTest e').input, + (loopTestWrap tmBody tmTest e').work, + (loopTestWrap tmBody tmTest e').output⟩ : Cfg n tmTest.Q) = e' from + Cfg.ext (by injection hq'.symm with h; injection h) rfl rfl rfl] + exact hre⟩⟩ + · push Not at hb + obtain ⟨q, hstate, hq⟩ := hb + obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hp1 q hstate + have hc : c = loopBodyWrap tmBody tmTest ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmBody.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq]; exact ⟨_, rfl⟩ + have hsim := loopTM_body_step tmBody tmTest hstep0 + rw [hc] at hst + have hc'eq : c' = loopBodyWrap tmBody tmTest e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmBody.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + exact ⟨hbody d hd0 hd1 hd2 e' hre, hsi', + fun q' hq' => ⟨d, hd0, hd1, hd2, by + rw [show (⟨q', (loopBodyWrap tmBody tmTest e').input, + (loopBodyWrap tmBody tmTest e').work, + (loopBodyWrap tmBody tmTest e').output⟩ : Cfg n tmBody.Q) = e' from + Cfg.ext (by injection hq'.symm) rfl rfl rfl] + exact hre⟩, + fun _ hq' => absurd hq' (by nofun)⟩ + have hinit : P c₀ := by + refine ⟨hwin₀, hsi₀, ?_, ?_⟩ + · intro q hq + have hqs : q = tmBody.qstart := by + have h := hstart.symm.trans hq + exact (Sum.inl.injEq _ _ ▸ h).symm + subst hqs + exact ⟨_, rfl, hwin₀, hsi₀, Relation.ReflTransGen.refl⟩ + · intro q hq + rw [hstart] at hq + exact absurd hq (by nofun) + have key : ∀ c, (loopTM tmBody tmTest).reaches c₀ c → P c := by + intro c h + induction h with + | refl => exact hinit + | tail _ hs ih => exact hstepP _ _ ih hs + exact (key cfin hreach).1 + +/-- **The conditional keeps the window.** Test and branch are each entered at their own start +state with windowed tapes, and the steps between them idle every tape. -/ +theorem ifTM_keepsWindow (tmTest tmThen tmElse : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + (htest : tmTest.KeepsWindow inputLength space) + (hthen : tmThen.KeepsWindow inputLength space) + (helse : tmElse.KeepsWindow inputLength space) : + (ifTM tmTest tmThen tmElse).KeepsWindow inputLength space := by + intro c₀ hstart hwin₀ hsi₀ cfin hreach + set P : Cfg n (ifTM tmTest tmThen tmElse).Q → Prop := fun c => + c.WithinDecisionSpace inputLength space ∧ CfgStartInvariant c ∧ + (∀ q, c.state = Sum.inl q → ∃ d : Cfg n tmTest.Q, d.state = tmTest.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tmTest.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ q, c.state = Sum.inr (Sum.inr (Sum.inl q)) → ∃ d : Cfg n tmThen.Q, + d.state = tmThen.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tmThen.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ q, c.state = Sum.inr (Sum.inr (Sum.inr q)) → ∃ d : Cfg n tmElse.Q, + d.state = tmElse.qstart ∧ + d.WithinDecisionSpace inputLength space ∧ CfgStartInvariant d ∧ + tmElse.reaches d ⟨q, c.input, c.work, c.output⟩) with hPdef + have hstepP : ∀ c c', P c → (ifTM tmTest tmThen tmElse).step c = some c' → P c' := by + intro c c' hPc hst + obtain ⟨hwin, hsi, hpt, hpth, hpel⟩ := hPc + have hne := state_ne_qhalt_of_step hst + have hsi' : CfgStartInvariant c' := hsi.step hst + by_cases h1 : ∀ q, c.state = Sum.inl q → q = tmTest.qhalt + · by_cases h2 : ∀ q, c.state = Sum.inr (Sum.inr (Sum.inl q)) → q = tmThen.qhalt + · by_cases h3 : ∀ q, c.state = Sum.inr (Sum.inr (Sum.inr q)) → q = tmElse.qhalt + · obtain ⟨hi, hw, ho⟩ := + if_head_bound tmTest tmThen tmElse h1 h2 h3 hst hsi.1 hsi.2.1 hsi.2.2 + have hwin' : c'.WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have := hw i + have := hwin.1.1 i + omega + · have := hwin.1.2 + omega + · have := hwin.2 + omega + rcases if_idle_step_state tmTest tmThen tmElse h1 h2 h3 hst with + ⟨ph, hph⟩ | hthq | helq + · exact ⟨hwin', hsi', + fun _ hq => absurd (hq.symm.trans hph) (by nofun), + fun _ hq => absurd (hq.symm.trans hph) (by nofun), + fun _ hq => absurd (hq.symm.trans hph) (by nofun)⟩ + · refine ⟨hwin', hsi', fun _ hq => absurd (hq.symm.trans hthq) (by nofun), ?_, + fun _ hq => absurd (hq.symm.trans hthq) (by nofun)⟩ + intro q' hq' + have hqq : q' = tmThen.qstart := by + have hA := hthq.symm.trans hq' + injection hA with hB + injection hB with hC + injection hC with hD + exact hD.symm + subst hqq + exact ⟨_, rfl, hwin', hsi', Relation.ReflTransGen.refl⟩ + · refine ⟨hwin', hsi', fun _ hq => absurd (hq.symm.trans helq) (by nofun), + fun _ hq => absurd (hq.symm.trans helq) (by nofun), ?_⟩ + intro q' hq' + have hqq : q' = tmElse.qstart := by + have hA := helq.symm.trans hq' + injection hA with hB + injection hB with hC + injection hC with hD + exact hD.symm + subst hqq + exact ⟨_, rfl, hwin', hsi', Relation.ReflTransGen.refl⟩ + · push Not at h3 + obtain ⟨q, hstate, hq⟩ := h3 + obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hpel q hstate + have hc : c = ifElseWrap tmTest tmThen tmElse ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmElse.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsim := ifTM_else_step tmTest tmThen tmElse hstep0 + rw [hc] at hst + have hc'eq : c' = ifElseWrap tmTest tmThen tmElse e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmElse.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + refine ⟨helse d hd0 hd1 hd2 e' hre, hsi', + fun _ hq' => absurd hq' (by nofun), + fun _ hq' => absurd hq' (by nofun), ?_⟩ + intro q' hq' + refine ⟨d, hd0, hd1, hd2, ?_⟩ + have hqq : q' = e'.state := by + injection hq' with hB + injection hB with hC + injection hC with hD + exact hD.symm + subst hqq + exact hre + · push Not at h2 + obtain ⟨q, hstate, hq⟩ := h2 + obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hpth q hstate + have hc : c = ifThenWrap tmTest tmThen tmElse ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmThen.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsim := ifTM_then_step tmTest tmThen tmElse hstep0 + rw [hc] at hst + have hc'eq : c' = ifThenWrap tmTest tmThen tmElse e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmThen.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + refine ⟨hthen d hd0 hd1 hd2 e' hre, hsi', + fun _ hq' => absurd hq' (by nofun), ?_, + fun _ hq' => absurd hq' (by nofun)⟩ + intro q' hq' + refine ⟨d, hd0, hd1, hd2, ?_⟩ + have hqq : q' = e'.state := by + injection hq' with hB + injection hB with hC + injection hC with hD + exact hD.symm + subst hqq + exact hre + · push Not at h1 + obtain ⟨q, hstate, hq⟩ := h1 + obtain ⟨d, hd0, hd1, hd2, hd3⟩ := hpt q hstate + have hc : c = ifTestWrap tmTest tmThen tmElse ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmTest.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsim := ifTM_test_step tmTest tmThen tmElse hstep0 + rw [hc] at hst + have hc'eq : c' = ifTestWrap tmTest tmThen tmElse e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmTest.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + refine ⟨htest d hd0 hd1 hd2 e' hre, hsi', ?_, + fun _ hq' => absurd hq' (by nofun), + fun _ hq' => absurd hq' (by nofun)⟩ + intro q' hq' + refine ⟨d, hd0, hd1, hd2, ?_⟩ + have hqq : q' = e'.state := by + injection hq'.symm + subst hqq + exact hre + have hinit : P c₀ := by + refine ⟨hwin₀, hsi₀, ?_, ?_, ?_⟩ + · intro q hq + have hqs : q = tmTest.qstart := by + have hA := hstart.symm.trans hq + injection hA with hB + exact hB.symm + subst hqs + exact ⟨_, rfl, hwin₀, hsi₀, Relation.ReflTransGen.refl⟩ + · intro q hq + rw [hstart] at hq + exact absurd hq (by nofun) + · intro q hq + rw [hstart] at hq + exact absurd hq (by nofun) + have key : ∀ c, (ifTM tmTest tmThen tmElse).reaches c₀ c → P c := by + intro c h + induction h with + | refl => exact hinit + | tail _ hs ih => exact hstepP _ _ ih hs + exact (key cfin hreach).1 + +/-- **The machine keeps its window on runs that start from a configuration satisfying `pre`.** +The precondition is what a subroutine simulating another machine needs: its space bound only +covers runs whose scratch tapes started blank, so a composition rule has to re-establish that at +every entry. -/ +def KeepsWindowOn (tm : TM n) (pre : Cfg n tm.Q → Prop) (inputLength space : ℕ) : Prop := + ∀ c, pre c → ∀ c', tm.reaches c c' → c'.WithinDecisionSpace inputLength space + +/-- Keeping the window unconditionally is keeping it on any precondition that pins the start +state and the window. -/ +theorem KeepsWindow.keepsWindowOn {tm : TM n} {inputLength space : ℕ} + (h : tm.KeepsWindow inputLength space) {pre : Cfg n tm.Q → Prop} + (hpre : ∀ c, pre c → c.state = tm.qstart ∧ c.WithinDecisionSpace inputLength space ∧ + CfgStartInvariant c) : + tm.KeepsWindowOn pre inputLength space := fun c hc c' hreach => + h c (hpre c hc).1 (hpre c hc).2.1 (hpre c hc).2.2 c' hreach + +/-- Weakening the precondition of a windowed contract. -/ +theorem KeepsWindowOn.mono {tm : TM n} {pre pre' : Cfg n tm.Q → Prop} {inputLength space : ℕ} + (h : tm.KeepsWindowOn pre inputLength space) (hpre : ∀ c, pre' c → pre c) : + tm.KeepsWindowOn pre' inputLength space := fun c hc => h c (hpre c hc) + +/-- **Sequential composition keeps the window, with preconditions.** The second machine's +precondition is re-established from the first machine's postcondition: `TM.halted_unique` says the +configuration met at the phase boundary is the very one the first machine's Hoare triple +describes, and the interposed step transforms its tapes in the fixed way `transitionTape` records. +-/ +theorem seqTM_keepsWindowOn (tm₁ tm₂ : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + {pre₁ : Cfg n tm₁.Q → Prop} {pre₂ : Cfg n tm₂.Q → Prop} {mid : TapePred n} + (hpre₁ : ∀ c, pre₁ c → c.state = tm₁.qstart ∧ c.WithinDecisionSpace inputLength space ∧ + CfgStartInvariant c) + (h₁ : tm₁.KeepsWindowOn pre₁ inputLength space) + (h₁post : ∀ c, pre₁ c → ∃ e, tm₁.reaches c e ∧ tm₁.halted e ∧ mid e.input e.work e.output) + (h₂ : tm₂.KeepsWindowOn pre₂ inputLength space) + (htrans : ∀ inp work out, mid inp work out → + pre₂ ⟨tm₂.qstart, transitionInput inp, fun i => transitionTape (work i), + transitionTape out⟩) : + (seqTM tm₁ tm₂).KeepsWindowOn + (fun c => ∃ d, pre₁ d ∧ c = phase1Wrap tm₁ tm₂ d) inputLength space := by + rintro c₀ ⟨d₀, hd₀, rfl⟩ cfin hreach + obtain ⟨hd₀start, hd₀win, hd₀si⟩ := hpre₁ d₀ hd₀ + set P : Cfg n (seqTM tm₁ tm₂).Q → Prop := fun c => + c.WithinDecisionSpace inputLength space ∧ CfgStartInvariant c ∧ + (∀ q, c.state = Sum.inl q → + ∃ d, pre₁ d ∧ tm₁.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ q, c.state = Sum.inr q → + ∃ d, pre₂ d ∧ tm₂.reaches d ⟨q, c.input, c.work, c.output⟩) with hPdef + have hstepP : ∀ c c', P c → (seqTM tm₁ tm₂).step c = some c' → P c' := by + intro c c' hPc hst + obtain ⟨hwin, hsi, hp1, hp2⟩ := hPc + have hne := state_ne_qhalt_of_step hst + have hsi' : CfgStartInvariant c' := hsi.step hst + rcases hstate : c.state with q | q + · obtain ⟨d, hd, hdreach⟩ := hp1 q hstate + by_cases hq : q = tm₁.qhalt + · subst hq + obtain ⟨hi, hw, ho⟩ := seq_head_bound tm₁ tm₂ hstate hst hsi.1 hsi.2.1 hsi.2.2 + have hwin' : c'.WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have := hw i + have := hwin.1.1 i + omega + · have := hwin.1.2 + omega + · have := hwin.2 + omega + obtain ⟨e, hereach, hehalt, hemid⟩ := h₁post d hd + have heq : (⟨tm₁.qhalt, c.input, c.work, c.output⟩ : Cfg n tm₁.Q) = e := + halted_unique hdreach hereach rfl hehalt + have hc : c = phase1Wrap tm₁ tm₂ ⟨tm₁.qhalt, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + rw [hc, seqTM_transition_step tm₁ tm₂ rfl] at hst + have hc'eq := Option.some_inj.mp hst + subst hc'eq + refine ⟨hwin', hsi', fun _ hq' => absurd hq' (by nofun), ?_⟩ + intro q' hq' + have hq2 : q' = tm₂.qstart := by + injection hq'.symm with hB + subst hq2 + refine ⟨_, htrans _ _ _ ?_, Relation.ReflTransGen.refl⟩ + rw [show c.input = e.input from congrArg Cfg.input heq, + show c.work = e.work from congrArg Cfg.work heq, + show c.output = e.output from congrArg Cfg.output heq] + exact hemid + · have hc : c = phase1Wrap tm₁ tm₂ ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tm₁.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsim := seqTM_phase1_step tm₁ tm₂ hstep0 + rw [hc] at hst + have hc'eq : c' = phase1Wrap tm₁ tm₂ e' := Option.some_inj.mp (hst.symm.trans hsim) + have hre : tm₁.reaches d e' := Relation.ReflTransGen.tail hdreach hstep0 + subst hc'eq + refine ⟨h₁ d hd e' hre, hsi', ?_, fun _ hq' => absurd hq' (by nofun)⟩ + intro q' hq' + refine ⟨d, hd, ?_⟩ + have hqq : q' = e'.state := by + injection hq' with hB + exact hB.symm + subst hqq + exact hre + · have hq : q ≠ tm₂.qhalt := fun h => hne (by rw [hstate, h]; rfl) + obtain ⟨d, hd, hdreach⟩ := hp2 q hstate + have hc : c = phase2Wrap tm₁ tm₂ ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tm₂.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq] + exact ⟨_, rfl⟩ + have hsim := seqTM_phase2_step tm₁ tm₂ hstep0 + rw [hc] at hst + have hc'eq : c' = phase2Wrap tm₁ tm₂ e' := Option.some_inj.mp (hst.symm.trans hsim) + have hre : tm₂.reaches d e' := Relation.ReflTransGen.tail hdreach hstep0 + subst hc'eq + refine ⟨h₂ d hd e' hre, hsi', fun _ hq' => absurd hq' (by nofun), ?_⟩ + intro q' hq' + refine ⟨d, hd, ?_⟩ + have hqq : q' = e'.state := by + injection hq' with hB + exact hB.symm + subst hqq + exact hre + have hinit : P (phase1Wrap tm₁ tm₂ d₀) := by + refine ⟨hd₀win, hd₀si, ?_, fun _ hq => absurd hq (by nofun)⟩ + intro q hq + refine ⟨d₀, hd₀, ?_⟩ + have hqq : q = d₀.state := by + injection hq.symm with hB + subst hqq + exact Relation.ReflTransGen.refl + have key : ∀ c, (seqTM tm₁ tm₂).reaches (phase1Wrap tm₁ tm₂ d₀) c → P c := by + intro c h + induction h with + | refl => exact hinit + | tail _ hstp ih => exact hstepP _ _ ih hstp + exact (key cfin hreach).1 + +/-- **A sequential composition is robust as soon as its first stage is.** This is what makes the +unconditional rules usable in practice. A subroutine that simulates another machine needs its +scratch tapes blank, so it only satisfies the precondition-carrying contract; but prefix it with a +stage that clears the scratch — one that *is* robust — and the composite is robust too, because +the first stage's postcondition supplies the second stage's precondition. The composite can then +be dropped straight into `TM.loopTM_keepsWindow`, whose body hypothesis is the unconditional one. +-/ +theorem seqTM_keepsWindow_of_post (tm₁ tm₂ : TM n) {inputLength space : ℕ} (hs : 1 ≤ space) + {pre₂ : Cfg n tm₂.Q → Prop} {mid : TapePred n} + (h₁ : tm₁.KeepsWindow inputLength space) + (h₁post : ∀ c : Cfg n tm₁.Q, c.state = tm₁.qstart → + c.WithinDecisionSpace inputLength space → CfgStartInvariant c → + ∃ e, tm₁.reaches c e ∧ tm₁.halted e ∧ mid e.input e.work e.output) + (h₂ : tm₂.KeepsWindowOn pre₂ inputLength space) + (htrans : ∀ inp work out, mid inp work out → + pre₂ ⟨tm₂.qstart, transitionInput inp, fun i => transitionTape (work i), + transitionTape out⟩) : + (seqTM tm₁ tm₂).KeepsWindow inputLength space := by + intro c₀ hstart hwin hsi cfin hreach + have hkw := seqTM_keepsWindowOn tm₁ tm₂ hs + (pre₁ := fun c => c.state = tm₁.qstart ∧ c.WithinDecisionSpace inputLength space ∧ + CfgStartInvariant c) + (pre₂ := pre₂) (mid := mid) + (fun _ h => h) + (h₁.keepsWindowOn (fun _ h => h)) + (fun c h => h₁post c h.1 h.2.1 h.2.2) + h₂ htrans + have hc : c₀ = phase1Wrap tm₁ tm₂ ⟨tm₁.qstart, c₀.input, c₀.work, c₀.output⟩ := + Cfg.ext hstart rfl rfl rfl + refine hkw c₀ ⟨⟨tm₁.qstart, c₀.input, c₀.work, c₀.output⟩, ⟨rfl, hwin, hsi⟩, hc⟩ cfin hreach + +/-! ## Time-bounded subroutines keep a window -/ + +/-- **A subroutine that halts in `t` steps keeps a window `t` cells wider than its start.** +Every head moves at most one cell per step, and a deterministic run cannot outlast its halt, so a +configuration starting with its heads inside `h` can only have pushed them to `h + t`. + +This is the bridge from the library's existing time contracts: any subroutine with a +`TM.HoareTime`-style halting bound acquires a window contract, with no new tape analysis. -/ +theorem keepsWindowOn_of_haltsIn {tm : TM n} {pre : Cfg n tm.Q → Prop} + {inputLength h t : ℕ} + (hwork : ∀ c, pre c → ∀ i, (c.work i).head ≤ h) + (hinput : ∀ c, pre c → c.input.head ≤ inputLength + h + 1) + (houtput : ∀ c, pre c → c.output.head ≤ h + 1) + (hhalt : ∀ c, pre c → ∃ e t', t' ≤ t ∧ tm.reachesIn t' c e ∧ tm.halted e) : + tm.KeepsWindowOn pre inputLength (h + t) := by + intro c hc c' hreach + obtain ⟨s, hs⟩ := TM.reaches_to_reachesIn tm hreach + obtain ⟨e, t', ht', hte, hhe⟩ := hhalt c hc + have hle : s ≤ t := le_trans (TM.reachesIn_le_halt tm hs hte hhe) ht' + obtain ⟨hi, ho, hw⟩ := head_le_start_add_of_reachesIn tm hs + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have h₁ := hw i + have h₂ := hwork c hc i + omega + · have h₂ := hinput c hc + omega + · have h₂ := houtput c hc + omega + +/-- **Every `TM.HoareTime` contract yields a window contract.** The library's subroutines are +specified by halting-time triples; this converts any of them, with no tape analysis, provided the +precondition pins where the heads start. The window is the starting bound plus the running time, +since a head moves at most one cell per step. -/ +theorem keepsWindowOn_of_hoareTime {tm : TM n} {pre post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) {inputLength h₀ : ℕ} + (hwork : ∀ inp work out, pre inp work out → ∀ i, (work i).head ≤ h₀) + (hinput : ∀ inp work out, pre inp work out → inp.head ≤ inputLength + h₀ + 1) + (houtput : ∀ inp work out, pre inp work out → out.head ≤ h₀ + 1) : + tm.KeepsWindowOn + (fun c => c.state = tm.qstart ∧ pre c.input c.work c.output) + inputLength (h₀ + b) := by + refine keepsWindowOn_of_haltsIn (fun c hc i => hwork _ _ _ hc.2 i) + (fun c hc => hinput _ _ _ hc.2) (fun c hc => houtput _ _ _ hc.2) (fun c hc => ?_) + obtain ⟨c', t, hle, hreach, hhalt, -⟩ := h c.input c.work c.output hc.2 + refine ⟨c', t, hle, ?_, hhalt⟩ + have hceq : ({ state := tm.qstart, input := c.input, work := c.work, output := c.output } : + Cfg n tm.Q) = c := Cfg.ext hc.1.symm rfl rfl rfl + rwa [hceq] at hreach + +/-- **The pinned form**, matching how the library states its framed subroutine contracts: the +precondition names the three tapes exactly, so the head bounds are three facts about literals. -/ +theorem keepsWindowOn_of_hoareTime_pinned {tm : TM n} {post : TapePred n} {b : ℕ} + {inp₀ : Tape} {work₀ : Fin n → Tape} {out₀ : Tape} + (h : tm.HoareTime (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) post b) + {inputLength h₀ : ℕ} + (hwork : ∀ i, (work₀ i).head ≤ h₀) + (hinput : inp₀.head ≤ inputLength + h₀ + 1) + (houtput : out₀.head ≤ h₀ + 1) : + tm.KeepsWindowOn + (fun c => c.state = tm.qstart ∧ + (c.input = inp₀ ∧ c.work = work₀ ∧ c.output = out₀)) + inputLength (h₀ + b) := + keepsWindowOn_of_hoareTime h + (fun _ _ _ hpre i => by rw [hpre.2.1]; exact hwork i) + (fun _ _ _ hpre => by rw [hpre.1]; exact hinput) + (fun _ _ _ hpre => by rw [hpre.2.2]; exact houtput) + +/-- The unconditional form: a machine that halts within `t` steps from *every* configuration +inside the window keeps the widened window. -/ +theorem keepsWindow_of_haltsIn {tm : TM n} {inputLength h t : ℕ} + (hhalt : ∀ c : Cfg n tm.Q, c.state = tm.qstart → + c.WithinDecisionSpace inputLength h → CfgStartInvariant c → + ∃ e t', t' ≤ t ∧ tm.reachesIn t' c e ∧ tm.halted e) : + tm.KeepsWindowOn + (fun c => c.state = tm.qstart ∧ c.WithinDecisionSpace inputLength h ∧ + CfgStartInvariant c) inputLength (h + t) := + keepsWindowOn_of_haltsIn + (fun _ hc i => hc.2.1.1.1 i) + (fun _ hc => hc.2.1.1.2) + (fun _ hc => hc.2.1.2) + (fun c hc => hhalt c hc.1 hc.2.1 hc.2.2) + +/-! ## Interoperation with the library's space contracts -/ + +/-- **A window contract is a `TM.HoareSpace` contract.** `TM.HoareSpace` is the library's own +anchored space judgement; it bounds `Cfg.WithinAuxSpace`, which ignores the output tape, whereas +a window additionally bounds the output head as `TM.DecidesInSpace` requires. So a window is the +stronger statement, and anything established with the composition rules above can be handed to +`TM.seqTM_hoareTimeSpace` and `TM.computesInSpace_of_hoareTimeSpace`. -/ +theorem KeepsWindowOn.hoareSpace {tm : TM n} {pre : TapePred n} {inputLength space : ℕ} + (h : tm.KeepsWindowOn + (fun c => c.state = tm.qstart ∧ pre c.input c.work c.output) inputLength space) : + tm.HoareSpace pre inputLength space := + fun inp work out hpre c' hreach => + (h { state := tm.qstart, input := inp, work := work, output := out } ⟨rfl, hpre⟩ c' hreach).1 + +/-- The unconditional form likewise yields a `TM.HoareSpace` contract, on any precondition that +pins the window and the left markers. -/ +theorem KeepsWindow.hoareSpace {tm : TM n} {inputLength space : ℕ} + (h : tm.KeepsWindow inputLength space) {pre : TapePred n} + (hpre : ∀ inp work out, pre inp work out → + ({ state := tm.qstart, input := inp, work := work, output := out } : + Cfg n tm.Q).WithinDecisionSpace inputLength space ∧ + CfgStartInvariant { state := tm.qstart, input := inp, work := work, output := out }) : + tm.HoareSpace pre inputLength space := + fun inp work out hp c' hreach => + (h { state := tm.qstart, input := inp, work := work, output := out } rfl + (hpre inp work out hp).1 (hpre inp work out hp).2 c' hreach).1 + +/-! ## From a window to a space-bounded decider -/ + +/-- The initial configuration parks every head at the left end, so it sits inside every window. -/ +theorem initCfg_withinDecisionSpace (tm : TM n) (x : List Bool) (inputLength space : ℕ) : + (tm.initCfg x).WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ <;> simp + +/-- Every tape of the initial configuration carries its left-end marker. -/ +theorem cfgStartInvariant_initCfg (tm : TM n) (x : List Bool) : + CfgStartInvariant (tm.initCfg x) := + ⟨startInvariant_initOfBool x, fun _ => startInvariant_initNil, startInvariant_initNil⟩ + +/-- **A machine that respects its window and decides `L` decides `L` in that space.** This is the +landing gear: a construction assembled from `TM.seqTM_respectsWindow` and +`TM.loopTM_respectsWindow` needs only its correctness proof to become a `DSPACE` membership. -/ +theorem decidesInSpace_of_respectsWindow {tm : TM n} {L : Language} {S : ℕ → ℕ} + (hwin : ∀ x : List Bool, tm.RespectsWindow x.length (S x.length)) + (hdec : ∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L → c'.output.cells 1 = Γ.one) ∧ (x ∉ L → c'.output.cells 1 = Γ.zero)) : + tm.DecidesInSpace L S := by + refine ⟨fun x c' hreach => ?_, hdec⟩ + have key : ∀ c, tm.reaches (tm.initCfg x) c → + c.WithinDecisionSpace x.length (S x.length) ∧ CfgStartInvariant c := by + intro c h + induction h with + | refl => exact ⟨initCfg_withinDecisionSpace tm x _ _, cfgStartInvariant_initCfg tm x⟩ + | tail _ hs ih => exact ⟨hwin x _ _ ih.1 ih.2 hs, ih.2.step hs⟩ + exact (key c' hreach).1 + +/-- **A machine that keeps its window and decides `L` decides `L` in that space.** -/ +theorem decidesInSpace_of_keepsWindow {tm : TM n} {L : Language} {S : ℕ → ℕ} + (hwin : ∀ x : List Bool, tm.KeepsWindow x.length (S x.length)) + (hdec : ∀ x : List Bool, ∃ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L → c'.output.cells 1 = Γ.one) ∧ (x ∉ L → c'.output.cells 1 = Γ.zero)) : + tm.DecidesInSpace L S := + ⟨fun x c' hreach => + hwin x (tm.initCfg x) rfl (initCfg_withinDecisionSpace tm x _ _) + (cfgStartInvariant_initCfg tm x) c' hreach, + hdec⟩ + + +/-- **A loop keeps a window one iteration at a time.** The loop's *total* run is exponentially +long when the counter is, so no bound of the form "space ≤ time" can help. What is true is that +every configuration the loop passes through lies within one iteration of some indexed state, and +each iteration is short: `hiter` asks only that a single iteration stay inside the window. + +Determinism is what makes the reduction work. A run that leaves the current iteration must pass +through the next iteration's start configuration, because two runs from the same configuration are +prefixes of one another. -/ +theorem loopTM_keepsWindow_indexed (tmBody tmTest : TM n) {inputLength space : ℕ} + (E : ℕ → TapePred n) (N b : ℕ) + (hstep : ∀ j, j < N → ∀ inp work out, E j inp work out → + ∃ inp' work' out' t, 1 ≤ t ∧ t ≤ b ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + E (j + 1) inp' work' out') + (hstop : ∀ inp work out, E N inp work out → + ∃ c' t, t ≤ b ∧ (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c') + (hiter : ∀ j, j ≤ N → ∀ inp work out, E j inp work out → + ∀ (c : Cfg n (loopTM tmBody tmTest).Q) (t : ℕ), t ≤ b → + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c → + c.WithinDecisionSpace inputLength space) : + ∀ j, j ≤ N → ∀ inp work out, E j inp work out → + ∀ c, (loopTM tmBody tmTest).reaches + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c → + c.WithinDecisionSpace inputLength space := by + have key : ∀ t : ℕ, ∀ j, j ≤ N → ∀ inp work out, E j inp work out → + ∀ c, (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c → + c.WithinDecisionSpace inputLength space := by + intro t + induction t using Nat.strong_induction_on with + | _ t ih => + intro j hjN inp work out hE c hreach + by_cases hb : t ≤ b + · exact hiter j hjN inp work out hE c t hb hreach + · rw [Nat.not_le] at hb + rcases Nat.lt_or_ge j N with hj | hj + · obtain ⟨inp', work', out', s, hs1, hs, hrun, hE'⟩ := hstep j hj inp work out hE + have hprefix := reachesIn_prefix (loopTM tmBody tmTest) hrun hreach (by omega) + refine ih (t - s) (by omega) (j + 1) (by omega) inp' work' out' hE' c hprefix + · have hjeq : j = N := by omega + subst hjeq + obtain ⟨d, s, hs, hrun, hhalt⟩ := hstop inp work out hE + have hprefix := reachesIn_prefix (loopTM tmBody tmTest) hrun hreach (by omega) + obtain ⟨u, hu⟩ : ∃ u, t - s = u + 1 := ⟨t - s - 1, by omega⟩ + rw [hu] at hprefix + cases hprefix with + | step hstepd _ => + exact absurd hstepd (by + simp only [TM.step, hhalt, ↓reduceIte] + nofun) + intro j hjN inp work out hE c hreach + obtain ⟨t, ht⟩ := TM.reaches_to_reachesIn _ hreach + exact key t j hjN inp work out hE c ht + + +/-- **A loop whose indexed states are parked keeps a window of one iteration's width.** Inside a +single iteration no head can travel further than the iteration is long, and each indexed state +has every head at cell one, so `1 + b` cells suffice — for the whole run, however many iterations +it takes. -/ +theorem loopTM_keepsWindow_indexed_of_parked (tmBody tmTest : TM n) {inputLength : ℕ} + (E : ℕ → TapePred n) (N b : ℕ) + (hstep : ∀ j, j < N → ∀ inp work out, E j inp work out → + ∃ inp' work' out' t, 1 ≤ t ∧ t ≤ b ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + E (j + 1) inp' work' out') + (hstop : ∀ inp work out, E N inp work out → + ∃ c' t, t ≤ b ∧ (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c') + (hparked : ∀ j, j ≤ N → ∀ inp work out, E j inp work out → + (∀ i, (work i).head ≤ 1) ∧ inp.head ≤ inputLength + 1 ∧ out.head ≤ 1) : + ∀ j, j ≤ N → ∀ inp work out, E j inp work out → + ∀ c, (loopTM tmBody tmTest).reaches + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c → + c.WithinDecisionSpace inputLength (1 + b) := by + refine loopTM_keepsWindow_indexed tmBody tmTest E N b hstep hstop ?_ + intro j hjN inp work out hE c t ht hreach + obtain ⟨hw, hi, ho⟩ := hparked j hjN inp work out hE + obtain ⟨hbi, hbo, hbw⟩ := + head_le_start_add_of_reachesIn (loopTM tmBody tmTest) hreach + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have h1 : (c.work i).head ≤ (work i).head + t := hbw i + have h2 := hw i + omega + · have h1 : c.input.head ≤ inp.head + t := hbi + omega + · have h1 : c.output.head ≤ out.head + t := hbo + omega + + +/-- Widening the window of a conditional window contract. Composing stages of different widths +means widening each to their maximum first. -/ +theorem KeepsWindowOn.mono_space {tm : TM n} {pre : Cfg n tm.Q → Prop} + {inputLength s s' : ℕ} (h : tm.KeepsWindowOn pre inputLength s) (hs : s ≤ s') : + tm.KeepsWindowOn pre inputLength s' := + fun c hc c' hreach => + ⟨⟨fun i => le_trans ((h c hc c' hreach).1.1 i) hs, + by have := (h c hc c' hreach).1.2; omega⟩, + by have := (h c hc c' hreach).2; omega⟩ + +/-- The tape conditions a loop configuration must satisfy for the phase-based window rule: the +body and the test are entered on tapes their own window rules accept, and the bookkeeping phases +between them on tapes that carry those conditions along. -/ +def LoopTapeInv (tmBody tmTest : TM n) (PB PT : TapePred n) (PL : LoopPhase → TapePred n) + (c : Cfg n (loopTM tmBody tmTest).Q) : Prop := + (c.state = Sum.inl tmBody.qstart → PB c.input c.work c.output) ∧ + (c.state = Sum.inr (Sum.inr tmTest.qstart) → PT c.input c.work c.output) ∧ + (∀ ph, c.state = Sum.inr (Sum.inl ph) → ph = LoopPhase.done ∨ PL ph c.input c.work c.output) + +/-- **A loop keeps a window, given windows for its phases.** `TM.loopTM_keepsWindow` asks each +phase to keep the window from *any* windowed configuration, which a phase that simulates another +machine cannot promise: started anywhere, such a machine need not even halt. This rule asks +instead for a window on the states each phase is actually entered at, plus three obligations +saying that the loop's own steps between phases carry those states along. + +`PB` and `PT` describe the tapes the body and the test are entered with, `PL` those of the +rewind-and-check phases between them. -/ +theorem loopTM_keepsWindowOn_phases (tmBody tmTest : TM n) {inputLength space : ℕ} + (hs : 1 ≤ space) (PB PT : TapePred n) (PL : LoopPhase → TapePred n) + (hbodyW : tmBody.KeepsWindowOn + (fun d => d.state = tmBody.qstart ∧ PB d.input d.work d.output) inputLength space) + (htestW : tmTest.KeepsWindowOn + (fun d => d.state = tmTest.qstart ∧ PT d.input d.work d.output) inputLength space) + (hBT : ∀ (c c' : Cfg n (loopTM tmBody tmTest).Q), c.state = Sum.inl tmBody.qhalt → + (∃ d : Cfg n tmBody.Q, d.state = tmBody.qstart ∧ PB d.input d.work d.output ∧ + tmBody.reaches d ⟨tmBody.qhalt, c.input, c.work, c.output⟩) → + (loopTM tmBody tmTest).step c = some c' → LoopTapeInv tmBody tmTest PB PT PL c') + (hTL : ∀ (c c' : Cfg n (loopTM tmBody tmTest).Q), + c.state = Sum.inr (Sum.inr tmTest.qhalt) → + (∃ d : Cfg n tmTest.Q, d.state = tmTest.qstart ∧ PT d.input d.work d.output ∧ + tmTest.reaches d ⟨tmTest.qhalt, c.input, c.work, c.output⟩) → + (loopTM tmBody tmTest).step c = some c' → LoopTapeInv tmBody tmTest PB PT PL c') + (hLL : ∀ (c c' : Cfg n (loopTM tmBody tmTest).Q) (ph : LoopPhase), + c.state = Sum.inr (Sum.inl ph) → PL ph c.input c.work c.output → + (loopTM tmBody tmTest).step c = some c' → LoopTapeInv tmBody tmTest PB PT PL c') : + ∀ (c₀ : Cfg n (loopTM tmBody tmTest).Q), c₀.state = (loopTM tmBody tmTest).qstart → + PB c₀.input c₀.work c₀.output → + c₀.WithinDecisionSpace inputLength space → CfgStartInvariant c₀ → + ∀ c, (loopTM tmBody tmTest).reaches c₀ c → + c.WithinDecisionSpace inputLength space := by + intro c₀ hstart hPB0 hwin₀ hsi₀ cfin hreach + set P : Cfg n (loopTM tmBody tmTest).Q → Prop := fun c => + c.WithinDecisionSpace inputLength space ∧ CfgStartInvariant c ∧ + (∀ q, c.state = Sum.inl q → ∃ d : Cfg n tmBody.Q, d.state = tmBody.qstart ∧ + PB d.input d.work d.output ∧ + tmBody.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ q, c.state = Sum.inr (Sum.inr q) → ∃ d : Cfg n tmTest.Q, d.state = tmTest.qstart ∧ + PT d.input d.work d.output ∧ + tmTest.reaches d ⟨q, c.input, c.work, c.output⟩) ∧ + (∀ ph, c.state = Sum.inr (Sum.inl ph) → ph = LoopPhase.done ∨ + PL ph c.input c.work c.output) with hPdef + -- An idle step: the tape conditions come from the caller's obligation. + have hidle : ∀ (c c' : Cfg n (loopTM tmBody tmTest).Q), P c → + (∀ q, c.state = Sum.inl q → q = tmBody.qhalt) → + (∀ q, c.state = Sum.inr (Sum.inr q) → q = tmTest.qhalt) → + (loopTM tmBody tmTest).step c = some c' → + LoopTapeInv tmBody tmTest PB PT PL c' → P c' := by + rintro c c' ⟨hwin, hsi, -, -, -⟩ hb ht hst hinv + obtain ⟨hi, hw, ho⟩ := loop_head_bound tmBody tmTest hb ht hst hsi.1 hsi.2.1 hsi.2.2 + have hwin' : c'.WithinDecisionSpace inputLength space := by + refine ⟨⟨fun i => ?_, ?_⟩, ?_⟩ + · have := hw i; have := hwin.1.1 i; omega + · have := hwin.1.2; omega + · have := hwin.2; omega + obtain ⟨hs1, hs2⟩ := loop_idle_step_state tmBody tmTest hb ht hst + refine ⟨hwin', hsi.step hst, ?_, ?_, hinv.2.2⟩ + · intro q' hq' + have hq0 : q' = tmBody.qstart := hs1 q' hq' + subst hq0 + exact ⟨⟨tmBody.qstart, c'.input, c'.work, c'.output⟩, rfl, hinv.1 hq', + Relation.ReflTransGen.refl⟩ + · intro q' hq' + have hq0 : q' = tmTest.qstart := hs2 q' hq' + subst hq0 + exact ⟨⟨tmTest.qstart, c'.input, c'.work, c'.output⟩, rfl, hinv.2.1 hq', + Relation.ReflTransGen.refl⟩ + have hstepP : ∀ c c', P c → (loopTM tmBody tmTest).step c = some c' → P c' := by + intro c c' hP hst + obtain ⟨hwin, hsi, hp1, hp2, hp3⟩ := hP + have hsi' : CfgStartInvariant c' := hsi.step hst + rcases hstate : c.state with q | ph | q + · by_cases hq : q = tmBody.qhalt + · subst hq + refine hidle c c' ⟨hwin, hsi, hp1, hp2, hp3⟩ ?_ ?_ hst + (hBT c c' hstate (hp1 _ hstate) hst) + · intro q' hq' + rw [hstate] at hq' + exact (Sum.inl.injEq _ _ ▸ hq').symm + · intro q' hq' + rw [hstate] at hq' + exact absurd hq' (by nofun) + · obtain ⟨d, hd0, hd1, hd3⟩ := hp1 q hstate + have hc : c = loopBodyWrap tmBody tmTest ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmBody.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq]; exact ⟨_, rfl⟩ + have hsim := loopTM_body_step tmBody tmTest hstep0 + rw [hc] at hst + have hc'eq : c' = loopBodyWrap tmBody tmTest e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmBody.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + exact ⟨hbodyW d ⟨hd0, hd1⟩ e' hre, hsi', + fun q' hq' => ⟨d, hd0, hd1, by + rw [show (⟨q', (loopBodyWrap tmBody tmTest e').input, + (loopBodyWrap tmBody tmTest e').work, + (loopBodyWrap tmBody tmTest e').output⟩ : Cfg n tmBody.Q) = e' from + Cfg.ext (by injection hq'.symm) rfl rfl rfl] + exact hre⟩, + fun _ hq' => absurd hq' (by nofun), + fun _ hph' => absurd hph' (by nofun)⟩ + · have hb : ∀ q', c.state = Sum.inl q' → q' = tmBody.qhalt := by + intro q' hq' + rw [hstate] at hq' + exact absurd hq' (by nofun) + have ht : ∀ q', c.state = Sum.inr (Sum.inr q') → q' = tmTest.qhalt := by + intro q' hq' + rw [hstate] at hq' + exact absurd hq' (by nofun) + have hPLc : PL ph c.input c.work c.output := by + rcases hp3 ph hstate with hdone | hPL + · subst hdone + exact absurd hst (by + simp only [TM.step, show c.state = (loopTM tmBody tmTest).qhalt from hstate, + ↓reduceIte] + nofun) + · exact hPL + exact hidle c c' ⟨hwin, hsi, hp1, hp2, hp3⟩ hb ht hst (hLL c c' ph hstate hPLc hst) + · by_cases hq : q = tmTest.qhalt + · subst hq + refine hidle c c' ⟨hwin, hsi, hp1, hp2, hp3⟩ ?_ ?_ hst + (hTL c c' hstate (hp2 _ hstate) hst) + · intro q' hq' + rw [hstate] at hq' + exact absurd hq' (by nofun) + · intro q' hq' + rw [hstate] at hq' + exact (Sum.inr.injEq _ _ ▸ (Sum.inr.injEq _ _ ▸ hq')).symm + · obtain ⟨d, hd0, hd1, hd3⟩ := hp2 q hstate + have hc : c = loopTestWrap tmBody tmTest ⟨q, c.input, c.work, c.output⟩ := + Cfg.ext hstate rfl rfl rfl + obtain ⟨e', hstep0⟩ : + ∃ e', tmTest.step ⟨q, c.input, c.work, c.output⟩ = some e' := by + rw [TM.step, if_neg hq]; exact ⟨_, rfl⟩ + have hsim := loopTM_test_step tmBody tmTest hstep0 + rw [hc] at hst + have hc'eq : c' = loopTestWrap tmBody tmTest e' := + Option.some_inj.mp (hst.symm.trans hsim) + have hre : tmTest.reaches d e' := Relation.ReflTransGen.tail hd3 hstep0 + subst hc'eq + exact ⟨htestW d ⟨hd0, hd1⟩ e' hre, hsi', + fun _ hq' => absurd hq' (by nofun), + fun q' hq' => ⟨d, hd0, hd1, by + rw [show (⟨q', (loopTestWrap tmBody tmTest e').input, + (loopTestWrap tmBody tmTest e').work, + (loopTestWrap tmBody tmTest e').output⟩ : Cfg n tmTest.Q) = e' from + Cfg.ext (by injection hq'.symm with h; injection h) rfl rfl rfl] + exact hre⟩, + fun _ hph' => absurd hph' (by nofun)⟩ + have hinit : P c₀ := by + refine ⟨hwin₀, hsi₀, ?_, ?_, ?_⟩ + · intro q hq + have hqs : q = tmBody.qstart := by + have h := hstart.symm.trans hq + exact (Sum.inl.injEq _ _ ▸ h).symm + subst hqs + exact ⟨_, rfl, hPB0, Relation.ReflTransGen.refl⟩ + · intro q hq + rw [hstart] at hq + exact absurd hq (by nofun) + · intro ph hph + rw [hstart] at hph + exact absurd hph (by nofun) + have key : ∀ c, (loopTM tmBody tmTest).reaches c₀ c → P c := by + intro c h + induction h with + | refl => exact hinit + | tail _ hs ih => exact hstepP _ _ ih hs + exact (key cfin hreach).1 + + +/-- **A bookkeeping step of a loop moves only the output head.** Between the test and the next +iteration the loop rewinds its output tape and reads one cell; the work tapes and the input are +idled, and the output's contents are written back unchanged. -/ +theorem loop_phase_step_tapes (tmBody tmTest : TM n) {c c' : Cfg n (loopTM tmBody tmTest).Q} + {ph : LoopPhase} (hstate : c.state = Sum.inr (Sum.inl ph)) (hph : ph ≠ LoopPhase.done) + (hout : Tape.StartInvariant c.output) + (hstep : (loopTM tmBody tmTest).step c = some c') : + c'.input = transitionInput c.input ∧ + (∀ i, c'.work i = transitionTape (c.work i)) ∧ + c'.output.cells = c.output.cells ∧ c'.output.head ≤ max c.output.head 1 := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate] + intro hcon + exact hph (by injection hcon with h; injection h) + rw [TM.step, if_neg hne] at hstep + rw [← Option.some_inj.mp hstep, hstate] + have hcells : ∀ (d : Dir3), d ≠ Dir3.right → c.output.read ≠ Γ.start → + (c.output.writeAndMove (readBackWrite c.output.read).toΓ d).cells = c.output.cells ∧ + (c.output.writeAndMove (readBackWrite c.output.read).toΓ d).head + ≤ max c.output.head 1 := by + intro d hd hread + have hw : c.output.write (readBackWrite c.output.read).toΓ = c.output := + write_readBack c.output hread + show ((c.output.write (readBackWrite c.output.read).toΓ).move d).cells = _ ∧ + ((c.output.write (readBackWrite c.output.read).toΓ).move d).head ≤ _ + rw [hw, Tape.move_cells] + refine ⟨rfl, ?_⟩ + cases d + · show (c.output.head - 1) ≤ _ + omega + · exact absurd rfl hd + · show c.output.head ≤ _ + omega + have hstart : c.output.read = Γ.start → c.output.head = 0 := by + intro hread + by_contra hc0 + exact absurd hread (hout.2 c.output.head (by omega)) + cases ph with + | done => exact absurd rfl hph + | rewindOut => + simp only [loopTM] + by_cases hread : c.output.read = Γ.start + · rw [if_pos hread] + refine ⟨rfl, fun i => rfl, ?_, ?_⟩ + · show ((c.output.write Γw.blank.toΓ).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, if_pos (hstart hread)] + · show ((c.output.write Γw.blank.toΓ).move Dir3.right).head ≤ _ + show (c.output.write Γw.blank.toΓ).head + 1 ≤ _ + rw [Tape.write_head, hstart hread] + omega + · rw [if_neg hread] + exact ⟨rfl, fun i => rfl, (hcells Dir3.left (by nofun) hread).1, + (hcells Dir3.left (by nofun) hread).2⟩ + | check => + simp only [loopTM] + by_cases hone : c.output.read = Γ.one + · rw [if_pos hone] + have hread : c.output.read ≠ Γ.start := by rw [hone]; nofun + have hd : idleDir c.output.read ≠ Dir3.right := by + rw [idleDir, if_neg hread] + nofun + exact ⟨rfl, fun i => rfl, (hcells (idleDir c.output.read) hd hread).1, + (hcells (idleDir c.output.read) hd hread).2⟩ + · rw [if_neg hone] + by_cases hread : c.output.read = Γ.start + · refine ⟨rfl, fun i => rfl, ?_, ?_⟩ + · show ((c.output.write (readBackWrite c.output.read).toΓ).move + (idleDir c.output.read)).cells = _ + rw [Tape.move_cells, Tape.write, if_pos (hstart hread)] + · show ((c.output.write (readBackWrite c.output.read).toΓ).move + (idleDir c.output.read)).head ≤ _ + rw [idleDir, if_pos hread] + show (c.output.write (readBackWrite c.output.read).toΓ).head + 1 ≤ _ + rw [Tape.write_head, hstart hread] + omega + · have hd : idleDir c.output.read ≠ Dir3.right := by + rw [idleDir, if_neg hread] + nofun + exact ⟨rfl, fun i => rfl, (hcells (idleDir c.output.read) hd hread).1, + (hcells (idleDir c.output.read) hd hread).2⟩ + +/-- **Where a rewind step goes.** It keeps rewinding until the output head reads the marker, and +then moves on to the check. -/ +theorem loop_rewind_step_state (tmBody tmTest : TM n) {c c' : Cfg n (loopTM tmBody tmTest).Q} + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hstep : (loopTM tmBody tmTest).step c = some c') : + (c.output.read = Γ.start → c'.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c'.output.head = c.output.head + 1) ∧ + (c.output.read ≠ Γ.start → c'.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate] + nofun + rw [TM.step, if_neg hne] at hstep + rw [← Option.some_inj.mp hstep, hstate] + simp only [loopTM] + constructor + · intro hread + rw [if_pos hread] + refine ⟨rfl, ?_⟩ + show ((c.output.write Γw.blank.toΓ).move Dir3.right).head = _ + show (c.output.write Γw.blank.toΓ).head + 1 = _ + rw [Tape.write_head] + · intro hread + rw [if_neg hread] + +/-- **A check step leaves every tape exactly as it found it**, when the output head is off the +marker — which it is, since the rewind has just put it at cell one. -/ +theorem loop_check_step_tapes (tmBody tmTest : TM n) {c c' : Cfg n (loopTM tmBody tmTest).Q} + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) (hread : c.output.read ≠ Γ.start) + (hstep : (loopTM tmBody tmTest).step c = some c') : + c'.input = transitionInput c.input ∧ (∀ i, c'.work i = transitionTape (c.work i)) ∧ + c'.output = c.output := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate] + nofun + rw [TM.step, if_neg hne] at hstep + rw [← Option.some_inj.mp hstep, hstate] + simp only [loopTM] + have hout : c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read) = c.output := by + rw [idleDir, if_neg hread] + show (c.output.write (readBackWrite c.output.read).toΓ).move Dir3.stay = c.output + rw [write_readBack c.output hread] + rfl + split + · exact ⟨rfl, fun i => rfl, hout⟩ + · exact ⟨rfl, fun i => rfl, hout⟩ + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Delay.lean b/Complexitylib/Models/TuringMachine/Delay.lean new file mode 100644 index 00000000..7fef1b71 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Delay.lean @@ -0,0 +1,295 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Data.Fintype.Prod +public import Complexitylib.Models.TuringMachine.Combinators +public import Complexitylib.Models.TuringMachine.Internal +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SentinelStep + +/-! +# Delaying a nondeterministic machine's first choice + +A machine begins with every head on `▷`, and `NTM.δ_right_of_start` forces that first transition +to move them all right. The transition may nevertheless *branch*: `δ false` and `δ true` can send +the machine to different states. That is a nuisance for any construction that has to enter a +simulated machine after the compulsory `▷`-step — a composed machine can never hand a stage a +head at cell zero — because the entry state would then fix the first choice. + +`NTM.delayNTM` removes the branch. It spends one extra step doing nothing but the compulsory +move, and only *then* consults the choice bit, jumping to whichever state the source machine's +first transition would have produced. Its first step is therefore choice-independent, while its +subsequent behaviour is the source machine's, one step later. + +## Main results + +- `NTM.delayNTM` — the source machine with its first choice deferred by one step +- `NTM.delayNTM_trace_embed` — after the delay, the two machines run in lockstep +- `NTM.delayNTM_trace_two_initCfg` — two steps of the delayed machine reproduce one of the source +- `NTM.delayNTM_allPathsHaltIn` — the delay costs two steps +- `NTM.delayNTM_acceptCount` — the delay doubles the count of accepting paths +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {n : ℕ} + +/-- **The source machine with its first choice deferred.** The extra state `Sum.inl ()` is both +the start state and the state the machine sits in after the compulsory `▷`-step; the two are +distinguished by the input head's symbol, which is `▷` exactly on the first step. -/ +def delayNTM (tm : NTM n) : NTM n := + letI : Fintype tm.Q := tm.finQ + letI : DecidableEq tm.Q := tm.decEq + { Q := Unit ⊕ tm.Q, + decEq := inferInstance, + finQ := inferInstance, + qstart := Sum.inl (), + qhalt := Sum.inr tm.qhalt, + δ := fun b q iHead wHeads oHead => + match q with + | Sum.inl () => + ( if iHead = Γ.start then Sum.inl () + else Sum.inr (tm.δ b tm.qstart Γ.start (fun _ => Γ.start) Γ.start).1, + fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, + TM.idleDir iHead, + fun i => TM.idleDir (wHeads i), + TM.idleDir oHead ) + | Sum.inr q' => + let r := tm.δ b q' iHead wHeads oHead + (Sum.inr r.1, r.2.1, r.2.2.1, r.2.2.2.1, r.2.2.2.2.1, r.2.2.2.2.2), + δ_right_of_start := by + intro b q iHead wHeads oHead + match q with + | Sum.inl () => + exact ⟨fun h => by simp [TM.idleDir, h], fun i h => by simp [TM.idleDir, h], + fun h => by simp [TM.idleDir, h]⟩ + | Sum.inr q' => + exact tm.δ_right_of_start b q' iHead wHeads oHead } + +@[simp] theorem delayNTM_qhalt (tm : NTM n) : (delayNTM tm).qhalt = Sum.inr tm.qhalt := rfl + +@[simp] theorem delayNTM_qstart (tm : NTM n) : (delayNTM tm).qstart = Sum.inl () := rfl + +/-- A source configuration, viewed as one of the delayed machine's. -/ +def delayEmbed (tm : NTM n) (c : Cfg n tm.Q) : Cfg n (delayNTM tm).Q where + state := Sum.inr c.state + input := c.input + work := c.work + output := c.output + +theorem delayEmbed_halted_iff (tm : NTM n) (c : Cfg n tm.Q) : + (delayEmbed tm c).state = (delayNTM tm).qhalt ↔ c.state = tm.qhalt := by + exact ⟨fun h => by injection h, fun h => by rw [delayEmbed, delayNTM_qhalt, h]⟩ + +/-- **One step, transported.** On an embedded configuration the delayed machine's transition is +literally the source's, wrapped. -/ +theorem delayNTM_trace_one_embed (tm : NTM n) (b : Bool) (c : Cfg n tm.Q) : + (delayNTM tm).trace 1 (fun _ => b) (delayEmbed tm c) + = delayEmbed tm (tm.trace 1 (fun _ => b) c) := by + by_cases hc : c.state = tm.qhalt + · rw [NTM.trace, NTM.trace, if_pos ((delayEmbed_halted_iff tm c).mpr hc), if_pos hc] + · rw [NTM.trace, NTM.trace, if_neg (fun h => hc ((delayEmbed_halted_iff tm c).mp h)), + if_neg hc] + rcases hr : tm.δ b c.state c.input.read (fun i => (c.work i).read) c.output.read with + ⟨q', ww, ow, iD, wD, oD⟩ + have hd : (delayNTM tm).δ b (delayEmbed tm c).state (delayEmbed tm c).input.read + (fun i => ((delayEmbed tm c).work i).read) (delayEmbed tm c).output.read + = (Sum.inr q', ww, ow, iD, wD, oD) := by + show (delayNTM tm).δ b (Sum.inr c.state) c.input.read + (fun i => (c.work i).read) c.output.read = _ + rw [show (delayNTM tm).δ b (Sum.inr c.state) c.input.read + (fun i => (c.work i).read) c.output.read + = (fun r => (Sum.inr r.1, r.2.1, r.2.2.1, r.2.2.2.1, r.2.2.2.2.1, r.2.2.2.2.2)) + (tm.δ b c.state c.input.read (fun i => (c.work i).read) c.output.read) from rfl, + hr] + simp only [hd, hr] + rfl + +/-- **After the delay, the two machines run in lockstep.** Every trace from an embedded +configuration transports to the source machine's. -/ +theorem delayNTM_trace_embed (tm : NTM n) : + ∀ (T : ℕ) (choices : Fin T → Bool) (c : Cfg n tm.Q), + (delayNTM tm).trace T choices (delayEmbed tm c) + = delayEmbed tm (tm.trace T choices c) := by + intro T + induction T with + | zero => intro _ _; rfl + | succ T ih => + intro choices c + rw [NTM.trace_succ (delayNTM tm) T choices (delayEmbed tm c), + NTM.trace_succ tm T choices c, delayNTM_trace_one_embed, ih] + + +/-- **The sentinel step of a nondeterministic machine.** From any configuration whose heads are +at cell zero the reads are all `▷`, so the writes are no-ops and every head moves right; only the +state depends on the choice bit. -/ +theorem trace_one_of_heads_zero (tm : NTM n) (b : Bool) (c : Cfg n tm.Q) + (hne : c.state ≠ tm.qhalt) + (hin : c.input.head = 0) (hwork : ∀ i, (c.work i).head = 0) (hout : c.output.head = 0) + (hin0 : c.input.cells 0 = Γ.start) (hwork0 : ∀ i, (c.work i).cells 0 = Γ.start) + (hout0 : c.output.cells 0 = Γ.start) : + tm.trace 1 (fun _ => b) c = + ⟨(tm.δ b c.state Γ.start (fun _ => Γ.start) Γ.start).1, + c.input.move Dir3.right, fun i => (c.work i).move Dir3.right, + c.output.move Dir3.right⟩ := by + have hri : c.input.read = Γ.start := by rw [Tape.read, hin]; exact hin0 + have hrw : ∀ i, (c.work i).read = Γ.start := by + intro i; rw [Tape.read, hwork i]; exact hwork0 i + have hro : c.output.read = Γ.start := by rw [Tape.read, hout]; exact hout0 + have hdirs := tm.δ_right_of_start b c.state Γ.start (fun _ => Γ.start) Γ.start + rw [NTM.trace, if_neg hne] + simp only [hri, hro, funext hrw] + rcases hr : tm.δ b c.state Γ.start (fun _ => Γ.start) Γ.start with ⟨q', ww, ow, iD, wD, oD⟩ + rw [hr] at hdirs + simp only [hr, NTM.trace] + refine Cfg.ext rfl ?_ ?_ ?_ + · rw [hdirs.1 rfl] + · funext i + show (c.work i).writeAndMove (ww i).toΓ (wD i) = (c.work i).move Dir3.right + rw [TM.writeAndMove_of_head_zero _ _ _ (hwork i), hdirs.2.1 i rfl] + · show c.output.writeAndMove ow.toΓ oD = c.output.move Dir3.right + rw [TM.writeAndMove_of_head_zero _ _ _ hout, hdirs.2.2 rfl] + +/-- **The delayed machine's second step.** Sitting in the extra state with every head off the +marker, it consults the choice bit, jumps to the state the source machine's first transition would +have produced, and leaves every tape exactly as it is. -/ +theorem delayNTM_trace_one_pending (tm : NTM n) (b : Bool) (c : Cfg n (delayNTM tm).Q) + (hstate : c.state = Sum.inl ()) + (hin : c.input.read ≠ Γ.start) (hwork : ∀ i, (c.work i).read ≠ Γ.start) + (hout : c.output.read ≠ Γ.start) : + (delayNTM tm).trace 1 (fun _ => b) c = + ⟨Sum.inr (tm.δ b tm.qstart Γ.start (fun _ => Γ.start) Γ.start).1, + c.input, c.work, c.output⟩ := by + have hnh : c.state ≠ (delayNTM tm).qhalt := by rw [hstate]; nofun + rw [NTM.trace, if_neg hnh] + have hd : (delayNTM tm).δ b c.state c.input.read (fun i => (c.work i).read) c.output.read + = (Sum.inr (tm.δ b tm.qstart Γ.start (fun _ => Γ.start) Γ.start).1, + fun i => TM.readBackWrite ((c.work i).read), TM.readBackWrite c.output.read, + TM.idleDir c.input.read, fun i => TM.idleDir ((c.work i).read), + TM.idleDir c.output.read) := by + rw [hstate] + show (if c.input.read = Γ.start then (Sum.inl () : Unit ⊕ tm.Q) + else Sum.inr (tm.δ b tm.qstart Γ.start (fun _ => Γ.start) Γ.start).1, _, _, _, _, _) = _ + rw [if_neg hin] + simp only [hd, NTM.trace] + refine Cfg.ext rfl ?_ ?_ ?_ + · exact TM.transitionInput_eq_self hin + · funext i + exact TM.transitionTape_eq_self (hwork i) + · exact TM.transitionTape_eq_self hout + +/-- **Two steps of the delayed machine reproduce one step of the source.** The first step is the +compulsory move off the marker and ignores its choice bit; the second consumes the choice the +source machine would have made first. -/ +theorem delayNTM_trace_two_initCfg (tm : NTM n) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) (choices : Fin 2 → Bool) : + (delayNTM tm).trace 2 choices ((delayNTM tm).initCfg x) + = delayEmbed tm (tm.trace 1 (fun _ => choices ⟨1, by omega⟩) (tm.initCfg x)) := by + have hne2 : ((delayNTM tm).initCfg x).state ≠ (delayNTM tm).qhalt := nofun + have hstep1 := trace_one_of_heads_zero (delayNTM tm) (choices ⟨0, by omega⟩) + ((delayNTM tm).initCfg x) hne2 rfl (fun _ => rfl) rfl (Tape.init_cells_zero _) + (fun _ => Tape.init_cells_zero _) (Tape.init_cells_zero _) + have hδ1 : ((delayNTM tm).δ (choices ⟨0, by omega⟩) ((delayNTM tm).initCfg x).state + Γ.start (fun _ => Γ.start) Γ.start).1 = Sum.inl () := by + show (if (Γ.start : Γ) = Γ.start then (Sum.inl () : Unit ⊕ tm.Q) + else Sum.inr (tm.δ (choices ⟨0, by omega⟩) tm.qstart Γ.start + (fun _ => Γ.start) Γ.start).1) = Sum.inl () + rw [if_pos rfl] + rw [NTM.trace_two, hstep1, hδ1] + have hinr : ((Tape.init (x.map Γ.ofBool)).move Dir3.right).read ≠ Γ.start := + Tape.init_ofBool_move_right_read_ne_start x + have hblank : ((Tape.init ([] : List Γ)).move Dir3.right).read ≠ Γ.start := by + rw [Tape.init_nil_move_right_read] + nofun + rw [delayNTM_trace_one_pending tm _ _ rfl hinr (fun _ => hblank) hblank] + rw [trace_one_of_heads_zero tm (choices ⟨1, by omega⟩) (tm.initCfg x) hne rfl (fun _ => rfl) rfl + (Tape.init_cells_zero _) (fun _ => Tape.init_cells_zero _) (Tape.init_cells_zero _)] + rfl + + +/-- **A whole run of the delayed machine, from its initial configuration.** Two extra steps buy +one step of the source machine, and thereafter the two run in lockstep. -/ +theorem delayNTM_trace_initCfg (tm : NTM n) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) (T : ℕ) (ch : Fin (T + 2) → Bool) : + (delayNTM tm).trace (T + 2) ch ((delayNTM tm).initCfg x) + = delayEmbed tm (tm.trace (T + 1) (Fin.tail ch) (tm.initCfg x)) := by + rw [NTM.trace_add_two, delayNTM_trace_two_initCfg tm x hne, delayNTM_trace_embed, + NTM.trace_succ tm T (Fin.tail ch) (tm.initCfg x)] + rfl + +/-- **The delay costs two steps.** Every path of the source machine that halts within `f |x|` +steps has its delayed counterpart halted within `f |x| + 2`. -/ +theorem delayNTM_allPathsHaltIn (tm : NTM n) {f : ℕ → ℕ} + (hall : tm.AllPathsHaltIn f) (hne : tm.qstart ≠ tm.qhalt) : + (delayNTM tm).AllPathsHaltIn (fun m => f m + 2) := by + intro x ch + show ((delayNTM tm).trace (f x.length + 2) ch ((delayNTM tm).initCfg x)).state + = (delayNTM tm).qhalt + rw [delayNTM_trace_initCfg tm x hne (f x.length) ch] + refine (delayEmbed_halted_iff tm _).mpr ?_ + have heq := tm.trace_mono (T := f x.length) (T' := f x.length + 1) (by omega) + (choices := fun i => Fin.tail ch ⟨i.val, by omega⟩) (choices' := Fin.tail ch) + (fun _ => rfl) (hall x _) + rw [heq] + exact hall x _ + +/-- **The delayed machine's accepting paths, counted.** Its first choice bit does nothing, so each +accepting path of the source machine lifts to exactly two of the delayed machine's. -/ +theorem delayNTM_acceptCount (tm : NTM n) (x : List Bool) + (hne : tm.qstart ≠ tm.qhalt) (T : ℕ) : + (delayNTM tm).acceptCount x (T + 2) = 2 * tm.acceptCount x (T + 1) := by + classical + set P : (Fin (T + 1) → Bool) → Prop := fun g => + (tm.trace (T + 1) g (tm.initCfg x)).state = tm.qhalt ∧ + (tm.trace (T + 1) g (tm.initCfg x)).output.cells 1 = Γ.one with hP + letI : DecidableEq tm.Q := tm.decEq + letI : DecidablePred P := fun _ => inferInstanceAs (Decidable (_ ∧ _)) + have hkey := delayNTM_trace_initCfg tm x hne T + have hfilter : ∀ ch : Fin (T + 2) → Bool, + (((delayNTM tm).trace (T + 2) ch ((delayNTM tm).initCfg x)).state + = (delayNTM tm).qhalt ∧ + ((delayNTM tm).trace (T + 2) ch ((delayNTM tm).initCfg x)).output.cells 1 = Γ.one) + ↔ P (Fin.tail ch) := by + intro ch + rw [hkey ch, hP] + exact and_congr (delayEmbed_halted_iff tm _) Iff.rfl + have hcard : ∀ (Q : (Fin (T + 1) → Bool) → Prop) [DecidablePred Q], + (Finset.univ.filter fun ch : Fin (T + 2) → Bool => Q (Fin.tail ch)).card + = 2 * (Finset.univ.filter Q).card := by + intro Q hQ + haveI : DecidablePred Q := hQ + haveI hf1 : Fintype {g : Fin (T + 1) → Bool // Q g} := Subtype.fintype _ + haveI hf2 : Fintype {ch : Fin (T + 2) → Bool // Q (Fin.tail ch)} := Subtype.fintype _ + rw [← Fintype.card_subtype, ← Fintype.card_subtype] + rw [Fintype.card_congr (Equiv.mk + (fun ch : {ch : Fin (T + 2) → Bool // Q (Fin.tail ch)} => + (ch.1 0, (⟨Fin.tail ch.1, ch.2⟩ : {g : Fin (T + 1) → Bool // Q g}))) + (fun p : Bool × {g : Fin (T + 1) → Bool // Q g} => + (⟨Fin.cons p.1 p.2.1, by rw [Fin.tail_cons]; exact p.2.2⟩ : + {ch : Fin (T + 2) → Bool // Q (Fin.tail ch)})) + (fun ch => by + refine Subtype.ext ?_ + simp) + (fun p => by + refine Prod.ext ?_ ?_ + · simp + · exact Subtype.ext (by simp)))] + rw [Fintype.card_prod, Fintype.card_bool] + calc (delayNTM tm).acceptCount x (T + 2) + = (Finset.univ.filter fun ch : Fin (T + 2) → Bool => P (Fin.tail ch)).card := by + rw [NTM.acceptCount] + congr 1 + exact Finset.filter_congr (fun a _ => hfilter a) + _ = 2 * (Finset.univ.filter fun g : Fin (T + 1) → Bool => P g).card := hcard P + _ = 2 * tm.acceptCount x (T + 1) := by rw [NTM.acceptCount] + +end NTM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Hoare/Space.lean b/Complexitylib/Models/TuringMachine/Hoare/Space.lean index c764ed61..23449a9c 100644 --- a/Complexitylib/Models/TuringMachine/Hoare/Space.lean +++ b/Complexitylib/Models/TuringMachine/Hoare/Space.lean @@ -72,6 +72,20 @@ namespace TM variable {n : ℕ} +/-- **A step-closed configuration predicate discharges a space contract.** Supply any predicate +that holds at every start satisfying the precondition, is preserved by one step, and implies the +space bound; every reachable configuration then satisfies the bound. This is the workhorse for +machines whose space analysis is a phase invariant rather than a composition of subroutine +contracts. -/ +theorem hoareSpace_of_invariant {tm : TM n} {pre : TapePred n} + {inputLength space : ℕ} (P : Cfg n tm.Q → Prop) + (hinit : ∀ inp work out, pre inp work out → + P { state := tm.qstart, input := inp, work := work, output := out }) + (hstep : ∀ c c', P c → tm.step c = some c' → P c') + (hbound : ∀ c, P c → c.WithinAuxSpace inputLength space) : + tm.HoareSpace pre inputLength space := + hoareSpace_of_invariant_internal P hinit hstep hbound + /-- Strengthening the precondition preserves an all-reachable space contract. -/ theorem HoareSpace.weaken_pre {tm : TM n} {pre pre' : TapePred n} {inputLength space : ℕ} diff --git a/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean b/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean index 347fe675..f3de02bd 100644 --- a/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean +++ b/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean @@ -83,6 +83,20 @@ namespace TM variable {n : ℕ} +/-- Internal: an inductive configuration predicate discharges a space contract. -/ +theorem hoareSpace_of_invariant_internal {tm : TM n} {pre : TapePred n} + {inputLength space : ℕ} (P : Cfg n tm.Q → Prop) + (hinit : ∀ inp work out, pre inp work out → + P { state := tm.qstart, input := inp, work := work, output := out }) + (hstep : ∀ c c', P c → tm.step c = some c' → P c') + (hbound : ∀ c, P c → c.WithinAuxSpace inputLength space) : + tm.HoareSpace pre inputLength space := by + intro inp work out hpre c' hreach + refine hbound c' ?_ + induction hreach with + | refl => exact hinit inp work out hpre + | tail _ hs ih => exact hstep _ _ ih hs + /-- Internal precondition weakening for all-reachable space contracts. -/ theorem HoareSpace.weaken_pre_internal {tm : TM n} {pre pre' : TapePred n} {inputLength space : ℕ} diff --git a/Complexitylib/Models/TuringMachine/Hoare/SpaceFrame.lean b/Complexitylib/Models/TuringMachine/Hoare/SpaceFrame.lean new file mode 100644 index 00000000..2318e18c --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Hoare/SpaceFrame.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SentinelStep + +/-! +# What a space bound says about the tape, not just the head + +⚠️ Unreviewed by Bolton + +`Cfg.WithinDecisionSpace` bounds head *positions*. A caller that has to clear up after a +subroutine needs more: it needs to know that nothing was written past the window, so that a wipe +of that width suffices. That follows, since a step writes only under its head — but it has to be +carried along the run. + +Bounding the same thing by the running time instead would be a disaster here: a space-bounded +machine may run for exponentially many steps, and a wipe of exponential width is not a wipe a +polynomial-space machine can afford. + +## Main results + +- `TM.work_cells_far_of_reachesIn` — a run whose heads stay inside `S` writes nothing past `S` +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **A run that stays inside a window writes nothing outside it.** Each step writes only under +its head, and every head along the run is inside the window, so a cell beyond it still holds what +it did at the start. -/ +theorem work_cells_far_of_reachesIn {tm : TM n} (S : ℕ) : + ∀ {t : ℕ} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' → + (∀ d, tm.reaches c d → ∀ i, (d.work i).head ≤ S) → + (∀ i p, S < p → (c.work i).cells p = Γ.blank) → + ∀ i p, S < p → (c'.work i).cells p = Γ.blank := by + intro t + induction t with + | zero => + intro c c' hreach _ hblank + cases hreach + exact hblank + | succ t ih => + intro c c' hreach hspace hblank + cases hreach with + | step hstep hrest => + rename_i cmid + refine ih hrest (fun d hd i => hspace d (Relation.ReflTransGen.head hstep hd) i) + (fun i p hp => ?_) + have hhead : (c.work i).head ≤ S := + hspace c (Relation.ReflTransGen.refl) i + rw [step_work_cells_ne tm hstep i p (by omega)] + exact hblank i p hp + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Hoare/StartInvariant.lean b/Complexitylib/Models/TuringMachine/Hoare/StartInvariant.lean new file mode 100644 index 00000000..4968c53f --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Hoare/StartInvariant.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Hoare.Defs +public import Complexitylib.Models.TuringMachine.Frame +public import Complexitylib.Models.TuringMachine.Internal + +/-! +# Carrying the left-marker invariant through a contract + +⚠️ Unreviewed by Bolton + +Every subroutine that rewinds, parks, or wipes asks its tapes for `Tape.StartInvariant`: the left +marker at cell zero and nowhere else. A run cannot destroy it — `TM.reachesIn_startInvariant` — +but a contract that does not mention it cannot pass it on, and a stage assembled from such +contracts is stuck. + +The rule below adds it: if a machine's precondition guarantees the invariant, its postcondition +may be strengthened by it, for free. + +## Main results + +- `TM.HoareTime.startInvariant` — a contract carries the left-marker invariant along +- `TM.HoareTime.headBound` — and a bound on how far its heads can have travelled +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **A contract carries the left-marker invariant.** No machine can put a marker anywhere but +cell zero, so a stage whose entry tapes are start-invariant leaves start-invariant tapes behind — +which is what the rewinds and wipes downstream ask for. -/ +theorem HoareTime.startInvariant {tm : TM n} {pre post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) + (hpre : ∀ inp work out, pre inp work out → + Tape.StartInvariant inp ∧ (∀ i, Tape.StartInvariant (work i)) ∧ Tape.StartInvariant out) : + tm.HoareTime pre + (fun inp work out => post inp work out ∧ + Tape.StartInvariant inp ∧ (∀ i, Tape.StartInvariant (work i)) ∧ Tape.StartInvariant out) + b := by + intro inp work out hp + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp work out hp + obtain ⟨hi, hw, ho⟩ := hpre inp work out hp + exact ⟨c', t, ht, hreach, hhalt, hpost, reachesIn_startInvariant hreach hi hw ho⟩ + +/-- **A contract bounds where its heads end up.** A head moves at most one cell per step, so a +stage that starts inside `h₀` and runs for `b` steps ends inside `h₀ + b` — which is what the +rewinds downstream need in order to know how far to scan. -/ +theorem HoareTime.headBound {tm : TM n} {pre post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) (h₀ : ℕ) + (hpre : ∀ inp work out, pre inp work out → + (∀ i, (work i).head ≤ h₀) ∧ inp.head ≤ h₀ ∧ out.head ≤ h₀) : + tm.HoareTime pre + (fun inp work out => post inp work out ∧ + (∀ i, (work i).head ≤ h₀ + b) ∧ inp.head ≤ h₀ + b ∧ out.head ≤ h₀ + b) + b := by + intro inp work out hp + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp work out hp + obtain ⟨hw, hi, ho⟩ := hpre inp work out hp + obtain ⟨hin, hout, hwork⟩ := head_le_start_add_of_reachesIn tm hreach + dsimp only at hin hout hwork + refine ⟨c', t, ht, hreach, hhalt, hpost, fun i => ?_, ?_, ?_⟩ + · have := hwork i + have := hw i + show (c'.work i).head ≤ h₀ + b + omega + · show c'.input.head ≤ h₀ + b + omega + · show c'.output.head ≤ h₀ + b + omega + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Placement/Hoare.lean b/Complexitylib/Models/TuringMachine/Placement/Hoare.lean new file mode 100644 index 00000000..bc1bbcbd --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Placement/Hoare.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Placement +public import Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# Hoare contracts through work-tape placement + +⚠️ Unreviewed by Bolton + +A stage of a larger machine is a small machine placed in a block of the layout's tapes. Its +contract should travel with it: what it promises about its own tapes should become a promise +about the block, and the tapes on either side should come back untouched. + +That is the rule below. The frame it carries is the one `TM.placeWorkTM` needs anyway — every +tape outside the block is start-invariant with its head off the marker, so the placed machine's +structurally mandatory idle writes leave it exactly as it was. + +## Main results + +- `TM.placeWorkTM_hoareTime` — a placed stage's contract, with the surrounding tapes framed +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **A placed stage keeps its contract, and its neighbours.** The precondition asks that the +tapes outside the block are the given frame and that the block satisfies the stage's own +precondition; the postcondition returns the frame unchanged and the stage's postcondition on the +block. -/ +theorem placeWorkTM_hoareTime (tm : TM n) {pre post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) (pre₀ post₀ : ℕ) + (extras : Fin (pre₀ + n + post₀) → Tape) + (hinv : ∀ i, ¬ placeWorkInMiddle pre₀ n i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ placeWorkInMiddle pre₀ n i → 1 ≤ (extras i).head) : + (placeWorkTM pre₀ post₀ tm).HoareTime + (fun inp work out => + (∀ i, ¬ placeWorkInMiddle pre₀ n i → work i = extras i) ∧ + pre inp (fun j => work (placeWorkIdx pre₀ post₀ j)) out) + (fun inp work out => + (∀ i, ¬ placeWorkInMiddle pre₀ n i → work i = extras i) ∧ + post inp (fun j => work (placeWorkIdx pre₀ post₀ j)) out) + b := by + rintro inp work out ⟨hframe, hpre⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := + h inp (fun j => work (placeWorkIdx pre₀ post₀ j)) out hpre + refine ⟨placeWorkCfg tm pre₀ post₀ extras c', t, ht, ?_, hhalt, ?_, ?_⟩ + · have hstart : (⟨(placeWorkTM pre₀ post₀ tm).qstart, inp, work, out⟩ : + Cfg (pre₀ + n + post₀) (placeWorkTM pre₀ post₀ tm).Q) = + placeWorkCfg tm pre₀ post₀ extras + (⟨tm.qstart, inp, fun j => work (placeWorkIdx pre₀ post₀ j), out⟩ : Cfg n tm.Q) := by + refine Cfg.ext rfl rfl (funext fun i => ?_) rfl + show work i = if hi : placeWorkInMiddle pre₀ n i then + work (placeWorkIdx pre₀ post₀ (placeWorkCoord pre₀ n i hi)) else extras i + by_cases hi : placeWorkInMiddle pre₀ n i + · rw [dif_pos hi, placeWorkIdx_placeWorkCoord i hi] + · rw [dif_neg hi] + exact hframe i hi + rw [hstart] + exact placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant tm pre₀ post₀ extras hreach + hinv hhead + · intro i hi + show (if h : placeWorkInMiddle pre₀ n i then _ else extras i) = extras i + rw [dif_neg hi] + · show post c'.input (fun j => (placeWorkCfg tm pre₀ post₀ extras c').work + (placeWorkIdx pre₀ post₀ j)) c'.output + have hw : (fun j => (placeWorkCfg tm pre₀ post₀ extras c').work + (placeWorkIdx pre₀ post₀ j)) = c'.work := by + funext j + show (if hi : placeWorkInMiddle pre₀ n (placeWorkIdx pre₀ post₀ j) then + c'.work (placeWorkCoord pre₀ n (placeWorkIdx pre₀ post₀ j) hi) + else extras (placeWorkIdx pre₀ post₀ j)) = c'.work j + rw [dif_pos (placeWorkInMiddle_placeWorkIdx pre₀ post₀ j), + placeWorkCoord_placeWorkIdx pre₀ post₀ j] + rw [hw] + exact hpost + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Placement/Window.lean b/Complexitylib/Models/TuringMachine/Placement/Window.lean new file mode 100644 index 00000000..5439f02b --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Placement/Window.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Placement + +/-! +# A placed machine's window + +⚠️ Unreviewed by Bolton + +A machine placed in a block of a larger tape space runs exactly as it did, so a window it keeps +on its own tapes is a window the placed machine keeps — provided the tapes on either side are +inside that window too, which they are: they never move. + +## Main results + +- `TM.placeWorkTM_reaches_reflect` — every configuration a placed run reaches is a placed one +- `TM.placeWorkTM_keepsWindow_of_reaches` — and so the source's window transfers +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- **Every configuration a placed run reaches is a placed configuration.** The frame never +changes, so the run is the source's run under the embedding. -/ +theorem placeWorkTM_reaches_reflect (tm : TM n) (pre post : ℕ) + (extras : Fin (pre + n + post) → Tape) (c₀ : Cfg n tm.Q) + (hinv : ∀ i, ¬ placeWorkInMiddle pre n i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ placeWorkInMiddle pre n i → 1 ≤ (extras i).head) : + ∀ D, (placeWorkTM pre post tm).reaches (placeWorkCfg tm pre post extras c₀) D → + ∃ c, tm.reaches c₀ c ∧ D = placeWorkCfg tm pre post extras c := by + intro D hD + induction hD with + | refl => exact ⟨c₀, Relation.ReflTransGen.refl, rfl⟩ + | @tail dmid dnext _ hstp ih => + obtain ⟨c, hreach, rfl⟩ := ih + have hcomm := placeWorkTM_step_placeWorkCfg_of_startInvariant tm pre post extras c + hinv hhead + have hstp' : (placeWorkTM pre post tm).step (placeWorkCfg tm pre post extras c) + = some dnext := hstp + rw [hcomm] at hstp' + obtain ⟨c', hstep, hD⟩ := Option.map_eq_some_iff.mp hstp' + exact ⟨c', Relation.ReflTransGen.tail hreach hstep, hD.symm⟩ + +/-- **A placed machine keeps its source's window**, given that the tapes on either side sit +inside it. -/ +theorem placeWorkTM_keepsWindow_of_reaches (tm : TM n) (pre post : ℕ) + (extras : Fin (pre + n + post) → Tape) (c₀ : Cfg n tm.Q) + (hinv : ∀ i, ¬ placeWorkInMiddle pre n i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬ placeWorkInMiddle pre n i → 1 ≤ (extras i).head) + {inputLength space : ℕ} + (hextraW : ∀ i, ¬ placeWorkInMiddle pre n i → (extras i).head ≤ space) + (htm : ∀ c, tm.reaches c₀ c → c.WithinDecisionSpace inputLength space) : + ∀ D, (placeWorkTM pre post tm).reaches (placeWorkCfg tm pre post extras c₀) D → + D.WithinDecisionSpace inputLength space := by + intro D hD + obtain ⟨c, hreach, rfl⟩ := placeWorkTM_reaches_reflect tm pre post extras c₀ hinv hhead D hD + obtain ⟨⟨hw, hi⟩, ho⟩ := htm c hreach + refine ⟨⟨fun j => ?_, hi⟩, ho⟩ + have hval : (placeWorkCfg tm pre post extras c).work j + = if h : placeWorkInMiddle pre n j then c.work (placeWorkCoord pre n j h) + else extras j := rfl + rw [hval] + by_cases hj : placeWorkInMiddle pre n j + · rw [dif_pos hj] + exact hw _ + · rw [dif_neg hj] + exact hextraW j hj + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump.lean new file mode 100644 index 00000000..690a72a0 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryBump.Internal + +/-! +# The zero-extending increment + +⚠️ Unreviewed by Bolton + +`TM.binarySuccTM` increments the number a tape holds: a carry running off the end appends a new +high `1`, which is what a numeral needs. `TM.binaryBumpTM` runs the same scan with that one write +changed to a `0`, which increments the *string* a tape holds — one place wider each time it +overflows. + +The strings it steps through, from the empty one, are every bitstring in order of length: +`[]`, `0`, `1`, `00`, `10`, `01`, `11`, `000`, … So a machine enumerating the witnesses of a +bounded existential can carry the witness on a tape and advance it with this, instead of decoding +one from a counter. + +## Main results + +- `TM.binaryBumpTM` — the machine, and `TM.binaryBumpTime` its exact running time +- `TM.binaryBumpTM_reachesIn_frame` — exact execution with a full tape frame +- `TM.binaryBumpTM_hoareTime_frame` — its compositional time contract +- `TM.binaryBumpTM_isTransducer` — the output head never moves left +-/ + +public section + +namespace Complexity + +namespace BinaryBump + +/-- The exact transition count is at most twice the string's length, plus two. -/ +theorem steps_le (bits : List Bool) : steps bits ≤ 2 * bits.length + 2 := + steps_le_internal bits + +end BinaryBump + +namespace TM + +variable {n : ℕ} + +/-- The exact running time is at most twice the string's length, plus two. -/ +theorem binaryBumpTime_le (bits : List Bool) : + binaryBumpTime bits ≤ 2 * bits.length + 2 := + binaryBumpTime_le_internal bits + +/-- **The zero-extending increment, executed exactly.** Starting on a rewound bit string, +`binaryBumpTM` halts after exactly `binaryBumpTime bits` transitions with the next string in the +enumeration. Input, output, and every unrelated work tape are preserved exactly. -/ +theorem binaryBumpTM_reachesIn_frame (idx : Fin n) (bits : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hbits : (work₀ idx).HasBinaryString bits) + (hcell0 : (work₀ idx).cells 0 = Γ.start) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + ∃ c', + (binaryBumpTM idx).reachesIn (binaryBumpTime bits) + { state := (binaryBumpTM idx).qstart + input := inp₀ + work := work₀ + output := out₀ } c' ∧ + (binaryBumpTM idx).halted c' ∧ + c'.input = inp₀ ∧ + (∀ i, i ≠ idx → c'.work i = work₀ i) ∧ + (c'.work idx).HasBinaryString (BinaryBump.bump bits) ∧ + (c'.work idx).cells 0 = Γ.start ∧ + c'.output = out₀ := + binaryBumpTM_reachesIn_frame_internal idx bits inp₀ work₀ out₀ hbits hcell0 hinp hother hout + +/-- Time-bounded compositional form of `TM.binaryBumpTM_reachesIn_frame`. -/ +theorem binaryBumpTM_hoareTime_frame (idx : Fin n) (bits : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hbits : (work₀ idx).HasBinaryString bits) + (hcell0 : (work₀ idx).cells 0 = Γ.start) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + (binaryBumpTM idx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => + inp = inp₀ ∧ + (∀ i, i ≠ idx → work i = work₀ i) ∧ + (work idx).HasBinaryString (BinaryBump.bump bits) ∧ + (work idx).cells 0 = Γ.start ∧ + out = out₀) + (binaryBumpTime bits) := + binaryBumpTM_hoareTime_frame_internal idx bits inp₀ work₀ out₀ hbits hcell0 hinp hother hout + +/-- `binaryBumpTM` never moves the output head left, so it is safe in one-way-output, +space-bounded compositions. -/ +theorem binaryBumpTM_isTransducer (idx : Fin n) : (binaryBumpTM idx).IsTransducer := + binaryBumpTM_isTransducer_internal idx + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Defs.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Defs.lean new file mode 100644 index 00000000..f54df903 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Defs.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Combinators +public import Complexitylib.Models.TuringMachine.Tape.Encoding +public import Mathlib.Data.Nat.Bits + +/-! +# The zero-extending increment — definitions + +⚠️ Unreviewed by Bolton + +`TM.binarySuccTM` increments the *number* a tape holds: a carry that runs off the end appends a +new high `1`. This module defines the same scan with one write changed — the carry appends a `0` +— which increments the *string* a tape holds, one place wider each time it overflows. + +That is the enumeration of all bitstrings in order of length: `[]`, `0`, `1`, `00`, `10`, …. It +is the increment of a fixed-width counter that widens instead of wrapping, and it is what a +machine enumerating the witnesses of a bounded existential advances each iteration. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryBump + +/-- Ripple one carry through a little-endian bit string, widening the string when the carry runs +off its end. -/ +def bump : List Bool → List Bool + | [] => [false] + | false :: rest => true :: rest + | true :: rest => false :: bump rest + +/-- Exact number of transitions used by `binaryBumpTM` on a bit string. It is twice the successor +of the number of initial low-order one bits. -/ +def steps : List Bool → ℕ + | [] => 2 + | false :: _ => 2 + | true :: rest => steps rest + 2 + +end BinaryBump + +namespace TM + +/-- Finite phases of the zero-extending increment. -/ +inductive BinaryBumpPhase where + | carry + | rewind + | done + deriving DecidableEq + +/-- `BinaryBumpPhase` has exactly three states. -/ +instance instFintypeBinaryBumpPhase : Fintype BinaryBumpPhase where + elems := {.carry, .rewind, .done} + complete := fun state => by cases state <;> simp + +/-- Exact running time of the zero-extending increment on a bit string. -/ +def binaryBumpTime (bits : List Bool) : ℕ := + BinaryBump.steps bits + +/-- Advance the little-endian bit string on work tape `idx` to the next one. + +The carry phase turns initial one bits into zero bits. The first zero becomes one; if the carry +reaches the terminating blank, a *zero* is appended there — one place wider, all zeros — which is +the only difference from `TM.binarySuccTM`. The machine then rewinds to cell one. Input, output, +and unrelated work tapes use the structurally safe read-back/idle action. -/ +def binaryBumpTM {n : ℕ} (idx : Fin n) : TM n where + Q := BinaryBumpPhase + qstart := .carry + qhalt := .done + δ := fun phase iHead wHeads oHead => + match phase with + | .carry => + match wHeads idx with + | .zero => + (.rewind, + fun i => if i = idx then Γw.one else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .one => + (.carry, + fun i => if i = idx then Γw.zero else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .blank => + (.rewind, + fun i => if i = idx then Γw.zero else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .start => + (.carry, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .rewind => + if wHeads idx = Γ.start then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro phase iHead wHeads oHead + match phase with + | .carry => + dsimp only + match htarget : wHeads idx with + | .zero | .one | .blank => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + · subst i + rw [htarget] at hi + exact absurd hi (by decide) + · rw [if_neg hitarget] + exact idleDir_right_of_start hi + | .start => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + · rw [if_pos hitarget] + · rw [if_neg hitarget] + exact idleDir_right_of_start hi + | .rewind => + dsimp only + split + · simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + · rw [if_pos hitarget] + · rw [if_neg hitarget] + exact idleDir_right_of_start hi + · next hnotStart => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + · subst i + exact absurd hi hnotStart + · rw [if_neg hitarget] + exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Internal.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Internal.lean new file mode 100644 index 00000000..c395a4bb --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryBump/Internal.lean @@ -0,0 +1,568 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Hoare.Space +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryBump.Defs +public import Mathlib.Data.Nat.Size + +/-! +# The zero-extending increment — proof internals + +⚠️ Unreviewed by Bolton + +This file proves the exact full-frame execution of `TM.binaryBumpTM`, following the proof of +`TM.binaryBumpTM` step for step: the two machines differ in one write. The carry proof is +generalized over the already-zeroed low-order prefix, and everything it states is about the bit +*string* on the tape — no number is involved, since a widening counter is not a numeral. +-/ + + +public section + +namespace Complexity + +namespace BinaryBump + +/-- Internal worst-case bound for the exact step count. -/ +theorem steps_le_internal (bits : List Bool) : + steps bits ≤ 2 * bits.length + 2 := by + induction bits with + | nil => simp [steps] + | cons bit bits ih => + cases bit + · simp [steps] + · simp only [steps, List.length_cons] + omega + +end BinaryBump + +namespace Tape + +private theorem HasBinaryContent.read_cons {t : Tape} {done : ℕ} + {bit : Bool} {rest : List Bool} + (h : t.HasBinaryContent (List.replicate done false ++ bit :: rest)) + (hhead : t.head = done + 1) : t.read = Γ.ofBool bit := by + rw [Tape.read, hhead] + have hcell := h.1 done (by simp) + simpa using hcell + +private theorem HasBinaryContent.read_nil {t : Tape} {done : ℕ} + (h : t.HasBinaryContent (List.replicate done false)) + (hhead : t.head = done + 1) : t.read = Γ.blank := by + rw [Tape.read, hhead] + exact h.2 done (by simp) + +end Tape + +namespace BinaryBump + +private theorem set_true_to_false (done : ℕ) (rest : List Bool) : + (List.replicate done false ++ true :: rest).set done false = + List.replicate (done + 1) false ++ rest := by + induction done with + | zero => rfl + | succ done ih => + change false :: (List.replicate done false ++ true :: rest).set done false = + false :: false :: (List.replicate done false ++ rest) + congr 1 + +private theorem set_false_to_true (done : ℕ) (rest : List Bool) : + (List.replicate done false ++ false :: rest).set done true = + List.replicate done false ++ true :: rest := by + induction done with + | zero => rfl + | succ done ih => + change false :: (List.replicate done false ++ false :: rest).set done true = + false :: (List.replicate done false ++ true :: rest) + congr 1 + +end BinaryBump + +namespace TM + +variable {n : ℕ} {idx : Fin n} + +private theorem binaryBumpTM_ne_halt {phase : BinaryBumpPhase} + (hne : phase ≠ .done) {c : Cfg n (binaryBumpTM idx).Q} + (hstate : c.state = phase) : + c.state ≠ (binaryBumpTM idx).qhalt := by + rw [hstate] + exact hne + +/-- Carry over one low-order one: write zero and advance right. -/ +private theorem binaryBumpTM_step_one (c : Cfg n (binaryBumpTM idx).Q) + (hstate : c.state = .carry) (hread : (c.work idx).read = Γ.one) + (hinput : c.input.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (c.work i).read ≠ Γ.start) + (houtput : c.output.read ≠ Γ.start) : + (binaryBumpTM idx).step c = some + { state := .carry + input := c.input + work := Function.update c.work idx + (((c.work idx).write Γ.zero).move Dir3.right) + output := c.output } := by + rw [TM.step, if_neg (binaryBumpTM_ne_halt (by decide) hstate)] + simp only [binaryBumpTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + · exact transitionInput_eq_self hinput + · funext i + by_cases hi : i = idx + · subst i + simp only [↓reduceIte, Function.update_self] + rfl + · rw [Function.update_of_ne hi] + simpa only [if_neg hi] using transitionTape_eq_self (hother i hi) + · exact transitionTape_eq_self houtput + +/-- Resolve a carry on zero: write one and turn left. -/ +private theorem binaryBumpTM_step_zero (c : Cfg n (binaryBumpTM idx).Q) + (hstate : c.state = .carry) (hread : (c.work idx).read = Γ.zero) + (hinput : c.input.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (c.work i).read ≠ Γ.start) + (houtput : c.output.read ≠ Γ.start) : + (binaryBumpTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx + (((c.work idx).write Γ.one).move Dir3.left) + output := c.output } := by + rw [TM.step, if_neg (binaryBumpTM_ne_halt (by decide) hstate)] + simp only [binaryBumpTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + · exact transitionInput_eq_self hinput + · funext i + by_cases hi : i = idx + · subst i + simp only [↓reduceIte, Function.update_self] + rfl + · rw [Function.update_of_ne hi] + simpa only [if_neg hi] using transitionTape_eq_self (hother i hi) + · exact transitionTape_eq_self houtput + +/-- Resolve overflow on the terminating blank: append a zero — widening the string — and turn +left. This is the one step in which the two increments differ. -/ +private theorem binaryBumpTM_step_blank (c : Cfg n (binaryBumpTM idx).Q) + (hstate : c.state = .carry) (hread : (c.work idx).read = Γ.blank) + (hinput : c.input.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (c.work i).read ≠ Γ.start) + (houtput : c.output.read ≠ Γ.start) : + (binaryBumpTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx + (((c.work idx).write Γ.zero).move Dir3.left) + output := c.output } := by + rw [TM.step, if_neg (binaryBumpTM_ne_halt (by decide) hstate)] + simp only [binaryBumpTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + · exact transitionInput_eq_self hinput + · funext i + by_cases hi : i = idx + · subst i + simp only [↓reduceIte, Function.update_self] + rfl + · rw [Function.update_of_ne hi] + simpa only [if_neg hi] using transitionTape_eq_self (hother i hi) + · exact transitionTape_eq_self houtput + +/-- Rewind one ordinary target cell to the left. -/ +private theorem binaryBumpTM_step_rewind (c : Cfg n (binaryBumpTM idx).Q) + (hstate : c.state = .rewind) (hread : (c.work idx).read ≠ Γ.start) + (hinput : c.input.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (c.work i).read ≠ Γ.start) + (houtput : c.output.read ≠ Γ.start) : + (binaryBumpTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } := by + rw [TM.step, if_neg (binaryBumpTM_ne_halt (by decide) hstate)] + simp only [binaryBumpTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + · exact transitionInput_eq_self hinput + · funext i + by_cases hi : i = idx + · subst i + rw [if_pos rfl, Function.update_self, + writeAndMove_readBack _ hread] + · rw [if_neg hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + · exact transitionTape_eq_self houtput + +/-- Bounce right from the left marker and halt. -/ +private theorem binaryBumpTM_step_start (c : Cfg n (binaryBumpTM idx).Q) + (hstate : c.state = .rewind) (hread : (c.work idx).read = Γ.start) + (hhead : (c.work idx).head = 0) + (hinput : c.input.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (c.work i).read ≠ Γ.start) + (houtput : c.output.read ≠ Γ.start) : + (binaryBumpTM idx).step c = some + { state := .done + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.right) + output := c.output } := by + rw [TM.step, if_neg (binaryBumpTM_ne_halt (by decide) hstate)] + simp only [binaryBumpTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + · exact transitionInput_eq_self hinput + · funext i + by_cases hi : i = idx + · subst i + simp only [↓reduceIte, Function.update_self] + show (((c.work idx).write _).move Dir3.right) = + (c.work idx).move Dir3.right + rw [Tape.write, if_pos hhead] + · rw [if_neg hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + · exact transitionTape_eq_self houtput + +/-! ## Exact rewind and carry runs -/ + +private theorem binaryBumpTM_rewind_run (bits : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + ∀ head (c : Cfg n (binaryBumpTM idx).Q), + c.state = .rewind → + c.input = inp₀ → + (∀ i, i ≠ idx → c.work i = work₀ i) → + (c.work idx).HasBinaryContent bits → + (c.work idx).cells 0 = Γ.start → + (c.work idx).head = head → + c.output = out₀ → + ∃ c', + (binaryBumpTM idx).reachesIn (head + 1) c c' ∧ + (binaryBumpTM idx).halted c' ∧ + c'.input = inp₀ ∧ + (∀ i, i ≠ idx → c'.work i = work₀ i) ∧ + (c'.work idx).HasBinaryString bits ∧ + (c'.work idx).cells 0 = Γ.start ∧ + c'.output = out₀ := by + intro head + induction head with + | zero => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Γ.start := by + rw [Tape.read, hhead] + exact hcell0 + have hstep := binaryBumpTM_step_start c hstate hread hhead + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryBumpTM idx).Q := + { state := .done + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.right) + output := c.output } + refine ⟨c₁, .step hstep .zero, rfl, hinput, ?_, ?_, ?_, houtput⟩ + · intro i hi + show Function.update c.work idx ((c.work idx).move Dir3.right) i = work₀ i + rw [Function.update_of_ne hi] + exact hwork i hi + · show (Function.update c.work idx ((c.work idx).move Dir3.right) idx) + |>.HasBinaryString bits + rw [Function.update_self] + apply Tape.HasBinaryContent.hasBinaryString + · simpa only [Tape.HasBinaryContent, Tape.move_cells] using hcontent + · simp [Tape.move, hhead] + · show (Function.update c.work idx ((c.work idx).move Dir3.right) idx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0 + | succ head ih => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read ≠ Γ.start := by + rw [Tape.read, hhead] + exact hcontent.cells_ne_start (head + 1) (by omega) + have hstep := binaryBumpTM_step_rewind c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryBumpTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx ((c.work idx).move Dir3.left) i = work₀ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx) + |>.HasBinaryContent bits + rw [Function.update_self] + simpa only [Tape.HasBinaryContent, Tape.move_cells] using hcontent) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx).head = head + rw [Function.update_self] + simp [Tape.move, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ + simpa [Nat.succ_eq_add_one, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + +private theorem binaryBumpTM_carry_run + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + ∀ done bits (c : Cfg n (binaryBumpTM idx).Q), + c.state = .carry → + c.input = inp₀ → + (∀ i, i ≠ idx → c.work i = work₀ i) → + (c.work idx).HasBinaryContent (List.replicate done false ++ bits) → + (c.work idx).cells 0 = Γ.start → + (c.work idx).head = done + 1 → + c.output = out₀ → + ∃ c', + (binaryBumpTM idx).reachesIn (done + BinaryBump.steps bits) c c' ∧ + (binaryBumpTM idx).halted c' ∧ + c'.input = inp₀ ∧ + (∀ i, i ≠ idx → c'.work i = work₀ i) ∧ + (c'.work idx).HasBinaryString + (List.replicate done false ++ BinaryBump.bump bits) ∧ + (c'.work idx).cells 0 = Γ.start ∧ + c'.output = out₀ := by + intro done bits + induction bits generalizing done with + | nil => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hcontent' : (c.work idx).HasBinaryContent (List.replicate done false) := by + simpa using hcontent + have hread : (c.work idx).read = Γ.blank := + hcontent'.read_nil hhead + have hstep := binaryBumpTM_step_blank c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Γ.zero).move Dir3.left + have htargetContent : target.HasBinaryContent + (List.replicate done false ++ [false]) := by + have hwrite := hcontent'.write_append false (by simpa using hhead) + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using hwrite + have htargetCell0 : target.cells 0 = Γ.start := by + exact Tape.write_move_cell0 Γ.zero Dir3.left hcell0 + have htargetHead : target.head = done := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binaryBumpTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + binaryBumpTM_rewind_run (idx := idx) + (List.replicate done false ++ [false]) inp₀ work₀ out₀ hinp hother hout + done c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = work₀ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = done + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + · simpa [BinaryBump.steps, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + · simpa [BinaryBump.bump] using hstring + | cons bit rest ih => + cases bit with + | false => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Γ.zero := + hcontent.read_cons hhead + have hstep := binaryBumpTM_step_zero c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Γ.one).move Dir3.left + have htargetContent : target.HasBinaryContent + (List.replicate done false ++ true :: rest) := by + have hwrite := hcontent.write_set true hhead (by simp) + rw [BinaryBump.set_false_to_true] at hwrite + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using hwrite + have htargetCell0 : target.cells 0 = Γ.start := by + exact Tape.write_move_cell0 Γ.one Dir3.left hcell0 + have htargetHead : target.head = done := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binaryBumpTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + binaryBumpTM_rewind_run (idx := idx) + (List.replicate done false ++ true :: rest) + inp₀ work₀ out₀ hinp hother hout done c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = work₀ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = done + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + · simpa [BinaryBump.steps, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + · simpa [BinaryBump.bump] using hstring + | true => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Γ.one := + hcontent.read_cons hhead + have hstep := binaryBumpTM_step_one c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Γ.zero).move Dir3.right + have htargetContent : target.HasBinaryContent + (List.replicate (done + 1) false ++ rest) := by + have hwrite := hcontent.write_set false hhead (by simp) + rw [BinaryBump.set_true_to_false] at hwrite + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using hwrite + have htargetCell0 : target.cells 0 = Γ.start := by + exact Tape.write_move_cell0 Γ.zero Dir3.right hcell0 + have htargetHead : target.head = (done + 1) + 1 := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binaryBumpTM idx).Q := + { state := .carry + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih (done + 1) c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = work₀ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = (done + 1) + 1 + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + · convert TM.reachesIn.step hstep hreach using 1 + all_goals simp [BinaryBump.steps, Nat.add_assoc] + all_goals omega + · simpa [BinaryBump.bump, List.replicate_add, + List.append_assoc] using hstring + +/-! ## Public-theorem internals -/ + +theorem binaryBumpTime_le_internal (bits : List Bool) : + binaryBumpTime bits ≤ 2 * bits.length + 2 := + BinaryBump.steps_le_internal bits + +theorem binaryBumpTM_reachesIn_frame_internal + (idx : Fin n) (bits : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hbits : (work₀ idx).HasBinaryString bits) + (hcell0 : (work₀ idx).cells 0 = Γ.start) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + ∃ c', + (binaryBumpTM idx).reachesIn (binaryBumpTime bits) + { state := (binaryBumpTM idx).qstart + input := inp₀ + work := work₀ + output := out₀ } c' ∧ + (binaryBumpTM idx).halted c' ∧ + c'.input = inp₀ ∧ + (∀ i, i ≠ idx → c'.work i = work₀ i) ∧ + (c'.work idx).HasBinaryString (BinaryBump.bump bits) ∧ + (c'.work idx).cells 0 = Γ.start ∧ + c'.output = out₀ := by + let c₀ : Cfg n (binaryBumpTM idx).Q := + { state := (binaryBumpTM idx).qstart + input := inp₀ + work := work₀ + output := out₀ } + obtain ⟨c', hreach, hhalt, hinput, hwork, hstring, hcell0', houtput⟩ := + binaryBumpTM_carry_run (idx := idx) inp₀ work₀ out₀ hinp hother hout + 0 bits c₀ (by rfl) (by rfl) (fun _ _ => rfl) + (by simpa [c₀] using hbits.hasBinaryContent) hcell0 + (by simpa [c₀] using hbits.1) (by rfl) + refine ⟨c', ?_, hhalt, hinput, hwork, ?_, hcell0', houtput⟩ + · simpa [c₀, binaryBumpTime] using hreach + · simpa using hstring + +theorem binaryBumpTM_hoareTime_frame_internal + (idx : Fin n) (bits : List Bool) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hbits : (work₀ idx).HasBinaryString bits) + (hcell0 : (work₀ idx).cells 0 = Γ.start) + (hinp : inp₀.read ≠ Γ.start) + (hother : ∀ i, i ≠ idx → (work₀ i).read ≠ Γ.start) + (hout : out₀.read ≠ Γ.start) : + (binaryBumpTM idx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => + inp = inp₀ ∧ + (∀ i, i ≠ idx → work i = work₀ i) ∧ + (work idx).HasBinaryString (BinaryBump.bump bits) ∧ + (work idx).cells 0 = Γ.start ∧ + out = out₀) + (binaryBumpTime bits) := by + rintro inp work out ⟨hinput₀, hwork₀, houtput₀⟩ + obtain ⟨c', hreach, hhalt, hinput, hwork, hbits', hcell0', houtput⟩ := + binaryBumpTM_reachesIn_frame_internal idx bits inp₀ work₀ out₀ + hbits hcell0 hinp hother hout + refine ⟨c', binaryBumpTime bits, le_rfl, ?_, hhalt, + hinput, hwork, hbits', hcell0', houtput⟩ + simpa [hinput₀, hwork₀, houtput₀] using hreach + +theorem binaryBumpTM_isTransducer_internal (idx : Fin n) : + (binaryBumpTM idx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | carry => + cases hread : wHeads idx <;> + simp [binaryBumpTM, hread, idleDir] <;> + split <;> decide + | rewind => + simp only [binaryBumpTM] + split <;> simp [idleDir] <;> split <;> decide + | done => + simp [binaryBumpTM, allIdle, idleDir] + split <;> decide + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean b/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean new file mode 100644 index 00000000..f490587c --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Subroutines.RewindList +public import Complexitylib.Models.TuringMachine.Combinators.Internal.SeqChain + +/-! +# Putting every head back where a stage expects it + +A simulated machine leaves its heads wherever its run ended — possibly on the left marker, since +a machine may halt immediately after stepping left onto it. Everything downstream wants heads +parked past the marker, and the tapes a stage will read again want them back at cell one. + +`TM.parkRewindTM` does both: one parking step for every tape, then a rewind of the input tape and +of each named work tape. It is the stage that separates a simulation from whatever reads its +results. + +## Main results + +- `TM.parkRewindTM` — park everything, then rewind the input and the named work tapes +- `TM.parkRewindTM_hoareTime` — its contract, through fully pinned tape states +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- Park every head past the marker, then rewind the input tape and the named work tapes to +cell one. -/ +def parkRewindTM (targets : List (Fin n)) : TM n := + seqTM skipTM (bigSeqTM [rewindInputTM, bigSeqTM (targets.map rewindWorkTM)]) + +/-- A tape with its marker only at cell zero, parked at `max head 1`. -/ +def parkTape (t : Tape) : Tape := ⟨max t.head 1, t.cells⟩ + +theorem parkTape_parked {t : Tape} (h : Tape.StartInvariant t) : Parked (parkTape t) := + ⟨le_max_right _ _, fun j hj => h.2 j hj⟩ + +theorem rewound_parked {t : Tape} (h : Tape.StartInvariant t) : + Parked (⟨1, t.cells⟩ : Tape) := + ⟨le_refl 1, fun j hj => h.2 j hj⟩ + +/-- **The cleanup stage's contract.** Every head ends parked; the input tape and the named work +tapes end at cell one, with their contents untouched. Only `Tape.StartInvariant` is asked of the +starting tapes — a head may still be sitting on the marker, which is exactly the state a halted +simulation can leave behind. -/ +theorem parkRewindTM_hoareTime (targets : List (Fin n)) (hnodup : targets.Nodup) (B : ℕ) + (hB : 1 ≤ B) (I₀ : Tape) (W₀ : Fin n → Tape) (O₀ : Tape) + (hI : Tape.StartInvariant I₀) (hW : ∀ i, Tape.StartInvariant (W₀ i)) + (hO : Tape.StartInvariant O₀) + (hIB : I₀.head ≤ B) (hWB : ∀ j, j ∈ targets → (W₀ j).head ≤ B) : + (parkRewindTM targets).HoareTime + (fun inp work out => inp = I₀ ∧ work = W₀ ∧ out = O₀) + (fun inp work out => inp = (⟨1, I₀.cells⟩ : Tape) ∧ + work = (fun j => if j ∈ targets then (⟨1, (W₀ j).cells⟩ : Tape) else parkTape (W₀ j)) ∧ + out = parkTape O₀) + (1 + 1 + (2 * (max (B + 2) (targets.length * (B + 3) + 1) + 1) + 1)) := by + classical + set W1 : Fin n → Tape := fun j => parkTape (W₀ j) with hW1def + set W3 : Fin n → Tape := + fun j => if j ∈ targets then (⟨1, (W₀ j).cells⟩ : Tape) else parkTape (W₀ j) with hW3def + set I1 : Tape := parkTape I₀ with hI1def + set I2 : Tape := (⟨1, I₀.cells⟩ : Tape) with hI2def + set O1 : Tape := parkTape O₀ with hO1def + have hW1P : ∀ j, Parked (W1 j) := fun j => parkTape_parked (hW j) + have hW3P : ∀ j, Parked (W3 j) := by + intro j + simp only [hW3def] + split + · exact rewound_parked (hW j) + · exact parkTape_parked (hW j) + have hI1P : Parked I1 := parkTape_parked hI + have hI2P : Parked I2 := rewound_parked hI + have hO1P : Parked O1 := parkTape_parked hO + set b := max (B + 2) (targets.length * (B + 3) + 1) with hbdef + -- Stage one: park every head. + have hpark : (skipTM (n := n)).HoareTime + (fun inp work out => inp = I₀ ∧ work = W₀ ∧ out = O₀) + (fun inp work out => inp = I1 ∧ work = W1 ∧ out = O1) 1 := by + refine (parkAll_hoareTime I₀ W₀ O₀ hI hW hO).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, funext hw, ho⟩ + -- The transition into stage two is the identity on parked tapes. + have htrans : ∀ inp work out, (inp = I1 ∧ work = W1 ∧ out = O1) → + (transitionInput inp = I1 ∧ (fun i => transitionTape (work i)) = W1 ∧ + transitionTape out = O1) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨transitionInput_eq_self hI1P.read_ne_start, + funext fun i => transitionTape_eq_self (hW1P i).read_ne_start, + transitionTape_eq_self hO1P.read_ne_start⟩ + -- Stages two and three: rewind the input, then the named work tapes. + have hrest : (bigSeqTM [rewindInputTM, bigSeqTM (targets.map rewindWorkTM)]).HoareTime + (fun inp work out => inp = I1 ∧ work = W1 ∧ out = O1) + (fun inp work out => inp = I2 ∧ work = W3 ∧ out = O1) (2 * (b + 1) + 1) := by + refine (bigSeqTM_hoareTime_pinned_gen [rewindInputTM, bigSeqTM (targets.map rewindWorkTM)] + (fun k => if k = 0 then I1 else I2) (fun k => if k ≤ 1 then W1 else W3) + (fun _ => O1) b ?_ ?_ (fun _ => hO1P) ?_).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (le_refl _) + · intro k + dsimp only + split + · exact hI1P + · exact hI2P + · intro k i + dsimp only + split + · exact hW1P i + · exact hW3P i + · intro k hk + match k, hk with + | 0, _ => + show (rewindInputTM (n := n)).HoareTime _ _ _ + refine ((rewindInputTM_hoareTime_frame (n := n) B + (P := fun inp work out => inp.cells = I₀.cells ∧ work = W1 ∧ out = O1) + ?_).consequence ?_ ?_ (le_max_left _ _)) + · rintro inp work out inp' work' out' ⟨hc, hw, ho⟩ hc' _ hkeep hout' + exact ⟨hc'.trans hc, hkeep.trans hw, hout'.trans ho⟩ + · rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨hI.1, fun j hj => hI.2 j hj, by + show max I₀.head 1 ≤ B + omega, + hO1P.read_ne_start, hO1P.1, + fun i => ⟨(hW1P i).read_ne_start, (hW1P i).1⟩, rfl, rfl, rfl⟩ + · rintro inp work out ⟨hh, hc, hw, ho⟩ + exact ⟨Tape.ext hh hc, hw, ho⟩ + | 1, _ => + show (bigSeqTM (targets.map rewindWorkTM)).HoareTime _ _ _ + refine ((rewindList_hoareTime targets hnodup B I2 W1 O1 hI2P hO1P hW1P ?_).strengthen_post + ?_).mono_bound (le_max_right _ _) + · intro j hj + refine ⟨(hW j).1, ?_⟩ + show max (W₀ j).head 1 ≤ B + have := hWB j hj + omega + · rintro inp work out ⟨rfl, rfl, hin, hout⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + by_cases hj : j ∈ targets + · rw [hin j hj] + show (⟨1, (W1 j).cells⟩ : Tape) = W3 j + simp only [hW3def, if_pos hj] + rfl + · rw [hout j hj] + show W1 j = W3 j + simp only [hW3def, if_neg hj] + rfl + exact seqTM_hoareTime skipTM _ hpark htrans hrest + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/WipeRewind.lean b/Complexitylib/Models/TuringMachine/Subroutines/WipeRewind.lean new file mode 100644 index 00000000..1eef5114 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/WipeRewind.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Subroutines.ResetTapes +public import Complexitylib.Models.TuringMachine.Subroutines.ParkRewind + +/-! +# Blanking a group of tapes and putting their heads back + +`TM.resetTapes_hoareTime` blanks its targets by walking a fixed height across them, which leaves +every head parked at the far end of the walk. A loop that reuses those tapes needs them back at +cell one, so the wipe is followed by one more rewind. + +The wipe is content-agnostic: nothing is assumed about *where* inside the wiped region the +non-blank cells sit, only that nothing lies beyond it. That is what makes it the right tool for +cleaning up after a simulation, whose tapes can hold anything at all. + +## Main results + +- `TM.wipeRewindTM` — blank the named tapes and return their heads to cell one +- `TM.wipeRewindTM_hoareTime` — its contract, landing on a fully named bank +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- The blank tape parked at cell one — what a wiped-and-rewound tape becomes. -/ +def blankTape : Tape := (Tape.init ([] : List Γ)).move Dir3.right + +theorem blankTape_parked : Parked blankTape := + ⟨le_refl 1, fun j hj => by + show ((Tape.init ([] : List Γ)).move Dir3.right).cells j ≠ Γ.start + rw [Tape.move_cells] + exact Tape.init_nil_cells_ne_start j hj⟩ + +theorem blankTape_startInvariant : Tape.StartInvariant blankTape := by + refine ⟨?_, fun j hj => ?_⟩ + · show ((Tape.init ([] : List Γ)).move Dir3.right).cells 0 = Γ.start + rw [Tape.move_cells] + exact Tape.init_cells_zero [] + · exact blankTape_parked.2 j hj + +/-- **Blank the named tapes, then put their heads back at cell one.** -/ +def wipeRewindTM (targets : List (Fin n)) (r : Fin n) : TM n := + seqTM + (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)) + (bigSeqTM (targets.map rewindWorkTM)) + +/-- **The wipe stage's contract.** The targets come back blank and parked at cell one, the +register that drove the walk is unchanged, and every other tape is untouched. -/ +theorem wipeRewindTM_hoareTime (targets : List (Fin n)) (hnodup : targets.Nodup) + (r : Fin n) (hr : r ∉ targets) (H : ℕ) + (I₀ : Tape) (W₀ : Fin n → Tape) (O₀ : Tape) + (hinpSI : Tape.StartInvariant I₀) (hinpP : Parked I₀) + (hout0 : O₀ = blankTape) + (hworkSI : ∀ j, j ≠ r → Tape.StartInvariant (W₀ j)) + (htargetHead : ∀ j, j ∈ targets → (W₀ j).head ≤ H) + (htargetFar : ∀ j, j ∈ targets → ∀ i, H < i → (W₀ j).cells i = Γ.blank) + (hworkR : W₀ r = regTape H) + (hother : ∀ j, j ≠ r → j ∉ targets → Parked (W₀ j)) : + (wipeRewindTM targets r).HoareTime + (fun inp work out => inp = I₀ ∧ work = W₀ ∧ out = O₀) + (fun inp work out => inp = I₀ ∧ + work = (fun j => if j ∈ targets then blankTape else W₀ j) ∧ out = O₀) + ((targets.length * (H + 4) + H * 4 + 8) + 1 + + (targets.length * (H + 4) + 1)) := by + classical + set W1 : Fin n → Tape := + fun j => if j ∈ targets then (⟨H + 1, (Tape.init ([] : List Γ)).cells⟩ : Tape) else W₀ j + with hW1def + have hW1P : ∀ j, Parked (W1 j) := by + intro j + simp only [hW1def] + split + · exact ⟨by show (1 : ℕ) ≤ H + 1; omega, fun i hi => Tape.init_nil_cells_ne_start i hi⟩ + · by_cases hjr : j = r + · rw [hjr, hworkR] + exact ⟨le_refl 1, fun i hi => by + show regCells H i ≠ Γ.start + simp only [regCells] + split + · omega + · split <;> decide⟩ + · exact hother j hjr (by assumption) + have hO₀P : Parked O₀ := by rw [hout0]; exact blankTape_parked + -- The wipe itself. + have hwipe : (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)).HoareTime + (fun inp work out => inp = I₀ ∧ work = W₀ ∧ out = O₀) + (fun inp work out => inp = I₀ ∧ work = W1 ∧ out = O₀) + (targets.length * (H + 4) + H * 4 + 8) := by + refine (resetTapes_hoareTime targets hnodup r hr H I₀ W₀ O₀ hinpSI hinpP + (by rw [hout0, blankTape]) hworkSI htargetHead hworkR hother).strengthen_post ?_ + rintro inp work out ⟨rfl, rfl, hin, hreg, hout⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + simp only [hW1def] + by_cases hj : j ∈ targets + · rw [if_pos hj, hin j hj] + exact wipedTape_eq_blank H rfl (hworkSI j (fun hjr => hr (hjr ▸ hj))).1 + (fun i hi => htargetFar j hj i hi) + · rw [if_neg hj] + by_cases hjr : j = r + · rw [hjr, hreg, hworkR] + · exact hout j hjr hj + -- Phase transition, then the rewind. + have htrans : ∀ inp work out, (inp = I₀ ∧ work = W1 ∧ out = O₀) → + (transitionInput inp = I₀ ∧ (fun i => transitionTape (work i)) = W1 ∧ + transitionTape out = O₀) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨transitionInput_eq_self hinpP.read_ne_start, + funext fun i => transitionTape_eq_self (hW1P i).read_ne_start, + transitionTape_eq_self hO₀P.read_ne_start⟩ + have hrew : (bigSeqTM (targets.map rewindWorkTM)).HoareTime + (fun inp work out => inp = I₀ ∧ work = W1 ∧ out = O₀) + (fun inp work out => inp = I₀ ∧ + work = (fun j => if j ∈ targets then blankTape else W₀ j) ∧ out = O₀) + (targets.length * (H + 4) + 1) := by + refine ((rewindList_hoareTime targets hnodup (H + 1) I₀ W1 O₀ hinpP hO₀P hW1P + ?_).strengthen_post ?_).mono_bound (by + have : targets.length * (H + 1 + 3) = targets.length * (H + 4) := by ring + omega) + · intro j hj + simp only [hW1def, if_pos hj] + exact ⟨Tape.init_cells_zero [], le_refl _⟩ + · rintro inp work out ⟨rfl, hout, hin, hkeep⟩ + refine ⟨rfl, funext fun j => ?_, hout⟩ + by_cases hj : j ∈ targets + · rw [hin j hj] + simp only [hW1def, if_pos hj] + exact Tape.ext rfl (by rw [blankTape, Tape.move_cells]) + · rw [hkeep j hj] + simp only [hW1def, if_neg hj] + exact seqTM_hoareTime _ _ hwipe htrans hrew + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/WriteOutputBit.lean b/Complexitylib/Models/TuringMachine/Subroutines/WriteOutputBit.lean new file mode 100644 index 00000000..93357b79 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/WriteOutputBit.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps + +/-! +# Publishing a work-tape bit on the output tape + +Every branching combinator in the library — `TM.ifTM` and `TM.loopTM` alike — decides on the +*real output tape's* verdict cell. A machine that keeps its intermediate results on work tapes +therefore has no way to branch on them, and the library has no subroutine that moves a bit from a +work tape to the output. + +`TM.writeOutputBitTM` is that subroutine, and it is as small as it can be: a single transition +that writes the symbol under a designated work head onto the output tape, leaving every tape +otherwise exactly as it was. Parked tapes stay parked, so it composes with everything. + +## Main results + +- `TM.writeOutputBitTM` — publish a work-tape bit on the output tape +- `TM.writeOutputBitTM_hoareTime_frame` — its contract, with a full external frame +- `TM.writeOutputBitTM_clears` — pointed at a blank tape it clears the output, which is what the + wipe subroutine requires +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- Publish the symbol under work head `vIdx` on the output tape, in one transition. -/ +def writeOutputBitTM (vIdx : Fin n) : TM n where + Q := BumpPhase + qstart := .go + qhalt := .done + δ := fun _ iHead wHeads oHead => + (.done, fun i => readBackWrite (wHeads i), readBackWrite (wHeads vIdx), + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + δ_right_of_start := fun _ _ _ _ => + ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + +/-- **Publishing a bit.** One transition writes the symbol under work head `vIdx` at the output +head, leaving the input and every work tape exactly as they were and moving no head. -/ +theorem writeOutputBitTM_hoareTime_frame (vIdx : Fin n) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : Parked inp₀) (hwork : ∀ i, Parked (work₀ i)) (hout : Parked out₀) : + (writeOutputBitTM vIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ + out = out₀.write (readBackWrite ((work₀ vIdx).read)).toΓ) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨⟨BumpPhase.done, inp, work, + out.write (readBackWrite ((work vIdx).read)).toΓ⟩, 1, le_rfl, ?_, rfl, rfl, rfl, rfl⟩ + refine TM.reachesIn.step ?_ TM.reachesIn.zero + simp only [TM.step, writeOutputBitTM, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + · exact hinp.move_idle + · funext i + exact (hwork i).writeAndMove_readBack_idle + · show (out.write (readBackWrite ((work vIdx).read)).toΓ).move (idleDir out.read) = _ + have hne : out.read ≠ Γ.start := hout.2 out.head hout.1 + rw [idleDir, if_neg hne] + rfl + + +/-- **Clearing the output needs no new machine.** Pointing the publisher at a work tape whose head +reads blank writes a blank to the output; if the output was only ever written at its verdict cell, +that restores it to the parked blank tape the wipe subroutine demands. -/ +theorem writeOutputBitTM_clears (vIdx : Fin n) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : Parked inp₀) (hwork : ∀ i, Parked (work₀ i)) (hout : Parked out₀) + (hblank : (work₀ vIdx).read = Γ.blank) + (hhead : out₀.head = 1) + (hcells : ∀ j, j ≠ 1 → out₀.cells j = (Tape.init ([] : List Γ)).cells j) : + (writeOutputBitTM vIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ + out = (Tape.init ([] : List Γ)).move Dir3.right) + 1 := by + refine (writeOutputBitTM_hoareTime_frame vIdx inp₀ work₀ out₀ hinp hwork hout).strengthen_post ?_ + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨rfl, rfl, ?_⟩ + rw [hblank] + have hne0 : ¬ (out₀.head = 0) := by omega + refine Tape.ext ?_ ?_ + · rw [Tape.write_head, hhead] + rfl + · funext j + rw [Tape.move_cells] + simp only [Tape.write, if_neg hne0] + rw [show Function.update out₀.cells out₀.head (readBackWrite Γ.blank).toΓ + = Function.update out₀.cells 1 (readBackWrite Γ.blank).toΓ from by rw [hhead]] + by_cases hj : j = 1 + · subst hj + rw [Function.update_self] + simp [Tape.init, readBackWrite] + · rw [Function.update_of_ne hj] + exact hcells j hj + +end TM + +end Complexity From 5e32507aa6da9795a22070d53f6c512d54a68a86 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Fri, 21 Aug 2026 09:22:25 -0700 Subject: [PATCH 16/24] overnight claude on complexity containments --- .../Classes/Containments/IPSubsetPSPACE.lean | 68 +- .../Containments/Internal/BinArith.lean | 936 +++ .../Containments/Internal/BitCodec.lean | 418 ++ .../Containments/Internal/BlockScan.lean | 1431 +++++ .../Containments/Internal/CountingCert.lean | 191 + .../Containments/Internal/IPAssemble.lean | 305 + .../Classes/Containments/Internal/IPEnc.lean | 459 ++ .../Containments/Internal/IPGameTree.lean | 683 +++ .../Classes/Containments/Internal/IPLeaf.lean | 411 ++ .../Classes/Containments/Internal/IPSem.lean | 970 ++++ .../Classes/Containments/Internal/IPStep.lean | 477 ++ .../Classes/Containments/Internal/IPWalk.lean | 143 + .../Containments/Internal/PVerdict.lean | 372 ++ .../Internal/SavitchAssemble.lean | 296 + .../Containments/Internal/SavitchFrame.lean | 12 +- .../Containments/Internal/SavitchReach.lean | 271 + .../Containments/Internal/SavitchSem.lean | 817 +++ .../Containments/Internal/SavitchSim.lean | 286 + .../Containments/Internal/SavitchStep.lean | 27 +- .../Containments/Internal/SuccMachine.lean | 5125 +++++++++++++++++ .../Containments/Internal/TranscriptEnc.lean | 281 + .../Classes/Containments/NLSubsetCoNL.lean | 90 +- .../Containments/NPSPACESubsetPSPACE.lean | 105 +- .../Classes/Containments/PSPACESubsetIP.lean | 6 +- Complexitylib/Classes/Interactive.lean | 48 +- Complexitylib/Models.lean | 5 + .../Models/TuringMachine/GuessAssembly.lean | 1375 +++++ .../Models/TuringMachine/GuessStream.lean | 542 ++ .../Models/TuringMachine/GuessTape.lean | 307 + .../TuringMachine/Subroutines/BinaryFor.lean | 38 + .../Subroutines/BinaryFor/Defs.lean | 35 + .../Subroutines/BinaryFor/Internal.lean | 1 + .../Subroutines/BinaryFor/Internal/Hoare.lean | 291 + .../TuringMachine/Subroutines/InputMatch.lean | 573 ++ .../TuringMachine/Subroutines/ParkRewind.lean | 68 + .../TuringMachine/Subroutines/Scan.lean | 1575 +++++ ROADMAP.md | 13 +- scripts/AxiomGuard.lean | 9 + 38 files changed, 18905 insertions(+), 155 deletions(-) create mode 100644 Complexitylib/Classes/Containments/Internal/BinArith.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BitCodec.lean create mode 100644 Complexitylib/Classes/Containments/Internal/BlockScan.lean create mode 100644 Complexitylib/Classes/Containments/Internal/CountingCert.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPAssemble.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPEnc.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPGameTree.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPLeaf.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPSem.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPStep.lean create mode 100644 Complexitylib/Classes/Containments/Internal/IPWalk.lean create mode 100644 Complexitylib/Classes/Containments/Internal/PVerdict.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchAssemble.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchReach.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchSem.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SavitchSim.lean create mode 100644 Complexitylib/Classes/Containments/Internal/SuccMachine.lean create mode 100644 Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean create mode 100644 Complexitylib/Models/TuringMachine/GuessAssembly.lean create mode 100644 Complexitylib/Models/TuringMachine/GuessStream.lean create mode 100644 Complexitylib/Models/TuringMachine/GuessTape.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Hoare.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/InputMatch.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/Scan.lean diff --git a/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean b/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean index af4cdd3f..c66efff8 100644 --- a/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean +++ b/Complexitylib/Classes/Containments/IPSubsetPSPACE.lean @@ -6,6 +6,7 @@ Authors: Bolton Bailey module public import Complexitylib.Classes.Interactive public import Complexitylib.Classes.Containments.Internal.IPSubsetPSPACE +public import Complexitylib.Classes.Containments.Internal.IPAssemble public import Complexitylib.Classes.P.Defs /-! @@ -21,30 +22,40 @@ verifier's coins average. Polynomial space evaluates the tree depth-first, holdi messages at a time — the tree is exponentially wide but only polynomially deep, since both the round count and the message lengths are polynomially bounded. -## Progress - -The quantifier over prover strategies is now known to be finite. A strategy is a function on -*all* transcripts, of which there are infinitely many, so the supremum `IP` quantifies is a -priori a supremum over an infinite set — nothing a machine can search. `Protocol.transcript_congr` -and `Protocol.acceptEvent_congr` show that a run of `rounds n` rounds consults the strategy only -on transcripts of length at most `2 · rounds n`; together with the message-length bound carried -by `ProverStrategy.Bounded`, that cuts the search to a finite game tree of polynomial depth. - -## What the proof still needs - -- The optimal-prover value as a recursion over `Protocol.transcript` on that finite tree, and the - fact that deterministic strategies suffice to attain it. -- Rational arithmetic in polynomial space for the averaging step. +## How the proof runs + +Three steps, none of which builds a machine by hand. + +**The maximum over prover strategies becomes a finite recursion.** A strategy is a function on +*all* transcripts, so the supremum `IP` quantifies is a priori a supremum over an infinite set. +`Protocol.gval` (in `Internal.IPGameTree`) *is* that maximum, written as a recursion down the +transcript tree: at a node the coins still in play are those consistent with the verifier messages +recorded above it, a round splits them by the verifier's next message +(`Protocol.consFinset_append`), and the prover picks, for each such message, the reply maximizing +the count below. `Protocol.sval_le_gval` says no bounded strategy beats it and +`Protocol.sval_optStrategy` says one attains it, so `Protocol.mem_iff_gval` turns membership into +one comparison, `2 ^ coins(|x|) < 2 · gval(x)`. That the value never exceeds the coin space +(`Protocol.gval_le_card`) is what keeps every count inside `coins(|x|) + 1` bits. + +**The recursion becomes a walk.** `Protocol.gvalR_zero_enum` and `Protocol.gvalR_succ_enum` write +it as two counter loops, and `Complexity.IPM.step` (in `Internal.IPSem`) walks it on a stack: one +frame per round carrying the two message counters, a running sum and a running maximum, with a +leaf frame carrying the coin counter and its tally. `IPM.run_frame` proves every pushed frame +comes back with its subtree's value, within `IPM.runBound` steps. + +**The walk becomes a machine.** `IPM.ipStep` is that walk written inside the polynomial-time +algebra, `IPM.ipStep_encSst` proves the square commutes, and +`Complexity.SpaceIter.mem_PSPACE_of_iterate` supplies the machine — the same last step Savitch's +theorem takes. The leaf test is a single scan: carrying each frame's transcript body inside the +frame makes the consistency check a per-frame condition, so it may be taken in any order, even +though `Protocol.replay` runs the rounds in the opposite order to the stack. ## Main results -- `Protocol.transcript_length` — a run of `n` rounds produces `2 n` messages - `Protocol.transcript_congr` — strategy extensionality for the transcript -- `Protocol.accepts_congr`, `Protocol.acceptEvent_congr` — and for acceptance - -## TODO - -- Evaluate the game tree; with `PSPACESubsetIP` this gives Shamir's theorem. +- `Protocol.mem_iff_gval` — membership is a comparison of the game-tree value +- `Protocol.walk_decides` — the stack walk ends with the membership bit +- `IP_subset_PSPACE` — the containment -/ @[expose] public section @@ -53,6 +64,21 @@ namespace Complexity /-- **`IP ⊆ PSPACE`**: the optimal prover's acceptance probability is the value of a polynomially deep game tree, evaluated depth-first in polynomial space. -/ -def IPSubsetPSPACE : Prop := IP ⊆ PSPACE +theorem IP_subset_PSPACE : IP ⊆ PSPACE := IP_subset_PSPACE_internal + +/-- **What the game tree computes.** `Protocol.gval` is the number of coin strings on which the +best bounded prover convinces the verifier; membership is that count exceeding half the coin +space. -/ +theorem IP_membership_is_game_value {L : Language} (hL : L ∈ IP) : + ∃ prot : Protocol, ∀ x : List Bool, x ∈ L ↔ + 2 ^ prot.coins x.length + < 2 * prot.gval x (prot.coins x.length) (prot.msgLen x.length) + (prot.rounds x.length) [] := by + obtain ⟨prot, _, _, _, _, _, _, hcomp, hsound⟩ := hL + exact ⟨prot, fun x => Protocol.mem_iff_gval prot x hcomp hsound⟩ + +/-- Shamir's theorem needs only the other half now. -/ +theorem IP_eq_PSPACE_of_pspace_subset_ip (h : PSPACE ⊆ IP) : IP = PSPACE := + subset_antisymm IP_subset_PSPACE h end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BinArith.lean b/Complexitylib/Classes/Containments/Internal/BinArith.lean new file mode 100644 index 00000000..e2dc564b --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BinArith.lean @@ -0,0 +1,936 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchBits + +/-! +# Binary addition and comparison inside the polynomial-time algebra + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.SavitchBits` builds a fixed-width *counter* in the +algebra — increment and overflow. A search that accumulates counts needs more: to add two numbers +and to compare them. Both are the same shape of computation, a single left-to-right scan over the +two operands, and both are written twice here for the same reason the counter was: as a plain +recursion, where the arithmetic is proved, and as a scan on a packed state, which is the shape +`Cobham.iterate_mem_FP` iterates. + +Numbers are little-endian, least significant bit first, and the two operands are the same width. +Addition returns the carry out separately, so nothing is lost to wraparound. + +## Main definitions + +- `Complexity.addBitsLE` — addition with carry, as a recursion +- `Complexity.addBits`, `Complexity.addCarry` — its two components +- `Complexity.ltBitsLE`, `Complexity.ltFlag` — comparison +- `Complexity.strsOfLen`, `Complexity.strsLe` — the strings of a given length, and up to it +- `Complexity.nextStr`, `Complexity.strIdx` — one counter enumerating every short string + +## Main results + +- `Complexity.addBitsLE_binValLE` — the adder is correct +- `Complexity.ltFlag_eq_true_iff` — the comparator is correct +- `Complexity.addBitsFn_mem_FP`, `Complexity.ltFlagFn_mem_FP` — both are in `FP` +- `Complexity.strsLe_eq_image` — the enumeration hits every short string exactly once +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-! ## The bit operations -/ + +/-- The carry out of a full adder. -/ +def majB (c b d : Bool) : Bool := (c && b) || ((c && d) || (b && d)) + +/-- The sum bit of a full adder. -/ +def sumB (c b d : Bool) : Bool := xor (xor c b) d + +theorem majB_sumB (c b d : Bool) : + (sumB c b d).toNat + 2 * (majB c b d).toNat = c.toNat + b.toNat + d.toNat := by + cases c <;> cases b <;> cases d <;> rfl + +theorem binValLE_cons (b : Bool) (w : List Bool) : + binValLE (b :: w) = b.toNat + 2 * binValLE w := by + cases b <;> simp [binValLE] + +/-- Exclusive or of two flags. -/ +def xorBit (x y : List Bool) : List Bool := selectHead x (notBit y) y + +/-- The carry out, on flags. -/ +def majBit (x y z : List Bool) : List Bool := + orBit (andBit x y) (orBit (andBit x z) (andBit y z)) + +/-- The sum bit, on flags. -/ +def sumBit (x y z : List Bool) : List Bool := xorBit (xorBit x y) z + +@[simp] theorem xorBit_flag (c d : Bool) : xorBit [c] [d] = [xor c d] := by + cases c <;> cases d <;> rfl + +@[simp] theorem majBit_flag (c b d : Bool) : majBit [c] [b] [d] = [majB c b d] := by + cases c <;> cases b <;> cases d <;> rfl + +@[simp] theorem sumBit_flag (c b d : Bool) : sumBit [c] [b] [d] = [sumB c b d] := by + cases c <;> cases b <;> cases d <;> rfl + +/-- The leading bit of a string, as a flag, reading past the end as zero. -/ +def bit1 (v : List Bool) : List Bool := (v ++ [false]).take 1 + +@[simp] theorem bit1_nil : bit1 [] = [false] := rfl + +@[simp] theorem bit1_cons (d : Bool) (t : List Bool) : bit1 (d :: t) = [d] := rfl + +theorem bit1_eq (v : List Bool) : bit1 v = [v.headD false] := by + cases v <;> rfl + +/-! ## Addition as a recursion -/ + +/-- Add two little-endian bitstrings with a carry in: the carry out and the sum bits. The +second operand is read through `headD`/`drop`, so the two are stepped in lockstep. -/ +def addBitsLE : Bool → List Bool → List Bool → Bool × List Bool + | c, [], _ => (c, []) + | c, b :: tu, v => + ((addBitsLE (majB c b (v.headD false)) tu (v.drop 1)).1, + sumB c b (v.headD false) :: (addBitsLE (majB c b (v.headD false)) tu (v.drop 1)).2) + +@[simp] theorem addBitsLE_nil (c : Bool) (v : List Bool) : addBitsLE c [] v = (c, []) := rfl + +theorem addBitsLE_cons (c b : Bool) (tu tv : List Bool) : + addBitsLE c (b :: tu) (d :: tv) + = ((addBitsLE (majB c b d) tu tv).1, sumB c b d :: (addBitsLE (majB c b d) tu tv).2) := rfl + +@[simp] theorem addBitsLE_length (c : Bool) (u v : List Bool) : + (addBitsLE c u v).2.length = u.length := by + induction u generalizing c v with + | nil => rfl + | cons b tu ih => simp [addBitsLE, ih] + +/-- **The adder is correct.** -/ +theorem addBitsLE_binValLE (c : Bool) (u v : List Bool) (h : v.length = u.length) : + binValLE (addBitsLE c u v).2 + (addBitsLE c u v).1.toNat * 2 ^ u.length + = binValLE u + binValLE v + c.toNat := by + induction u generalizing c v with + | nil => + have hv : v = [] := List.eq_nil_of_length_eq_zero (by simpa using h) + subst hv + simp [binValLE] + | cons b tu ih => + obtain ⟨d, tv, rfl⟩ : ∃ d tv, v = d :: tv := by + cases v with + | nil => simp at h + | cons d tv => exact ⟨d, tv, rfl⟩ + have htv : tv.length = tu.length := by simpa using h + have hih := ih (majB c b d) tv htv + have hmaj := majB_sumB c b d + have hmul : (addBitsLE (majB c b d) tu tv).1.toNat * (2 ^ tu.length * 2) + = 2 * ((addBitsLE (majB c b d) tu tv).1.toNat * 2 ^ tu.length) := by ring + rw [addBitsLE_cons] + simp only [binValLE_cons, List.length_cons, pow_succ] + omega + +/-! ## Addition as a scan -/ + +/-- One step of the addition scan: the carry, the bits emitted so far, and the two operands +still to read. -/ +def addStep : + List Bool × List Bool × List Bool × List Bool → + List Bool × List Bool × List Bool × List Bool + | (c, acc, [], v) => (c, acc, [], v) + | (c, acc, b :: tu, v) => + (majBit c [b] (bit1 v), acc ++ sumBit c [b] (bit1 v), tu, v.drop 1) + +@[simp] theorem addStep_nil (c acc v : List Bool) : addStep (c, acc, [], v) = (c, acc, [], v) := + rfl + +theorem addStep_flag (c b : Bool) (acc tu v : List Bool) : + addStep ([c], acc, b :: tu, v) + = ([majB c b (v.headD false)], acc ++ [sumB c b (v.headD false)], tu, v.drop 1) := by + rw [addStep, bit1_eq] + simp + +/-- **The scan computes the sum.** -/ +theorem addStep_iterate_run (c : Bool) (acc u v : List Bool) (h : v.length = u.length) : + addStep^[u.length] ([c], acc, u, v) + = ([(addBitsLE c u v).1], acc ++ (addBitsLE c u v).2, [], []) := by + induction u generalizing c acc v with + | nil => + have hv : v = [] := List.eq_nil_of_length_eq_zero (by simpa using h) + subst hv + simp + | cons b tu ih => + obtain ⟨d, tv, rfl⟩ : ∃ d tv, v = d :: tv := by + cases v with + | nil => simp at h + | cons d tv => exact ⟨d, tv, rfl⟩ + have htv : tv.length = tu.length := by simpa using h + rw [List.length_cons, Function.iterate_succ_apply, addStep_flag] + simp only [List.headD_cons, List.drop_succ_cons, List.drop_zero] + rw [ih (majB c b d) (acc ++ [sumB c b d]) tv htv, addBitsLE_cons] + simp + +/-- The scan never has more in hand than it started with. -/ +theorem addStep_iterate_length (c : Bool) (acc u v : List Bool) (n : ℕ) : + (addStep^[n] ([c], acc, u, v)).1.length = 1 ∧ + (addStep^[n] ([c], acc, u, v)).2.1.length + + (addStep^[n] ([c], acc, u, v)).2.2.1.length ≤ acc.length + u.length ∧ + (addStep^[n] ([c], acc, u, v)).2.2.2.length ≤ v.length := by + induction n generalizing c acc u v with + | zero => exact ⟨rfl, le_rfl, le_rfl⟩ + | succ n ih => + rw [Function.iterate_succ_apply] + cases u with + | nil => simpa using ih c acc [] v + | cons b tu => + rw [addStep_flag] + have := ih (majB c b (v.headD false)) (acc ++ [sumB c b (v.headD false)]) tu (v.drop 1) + refine ⟨this.1, le_trans this.2.1 ?_, le_trans this.2.2 ?_⟩ + · simp + omega + · simp + +/-! ## The packed scan -/ + +/-- The packed scan state. -/ +def addPack (c acc ru rv : List Bool) : List Bool := pair c (pair acc (pair ru rv)) + +@[simp] theorem addPack_length (c acc ru rv : List Bool) : + (addPack c acc ru rv).length + = 2 * c.length + 2 * acc.length + 2 * ru.length + rv.length + 6 := by + rw [addPack, pair_length, pair_length, pair_length] + omega + +/-- One step of the packed scan. -/ +def addStepP (z : List Bool) : List Bool := + selectHead (lenLeFlag (fstBlock (sndBlock (sndBlock z))) [false]) + (addPack + (majBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) + (bit1 (sndBlock (sndBlock (sndBlock z))))) + (fstBlock (sndBlock z) ++ + sumBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) + (bit1 (sndBlock (sndBlock (sndBlock z))))) + ((fstBlock (sndBlock (sndBlock z))).drop 1) + ((sndBlock (sndBlock (sndBlock z))).drop 1)) + z + +/-- **The packed step is the unpacked step.** -/ +theorem addStepP_pack (c acc ru rv : List Bool) : + addStepP (addPack c acc ru rv) + = addPack (addStep (c, acc, ru, rv)).1 (addStep (c, acc, ru, rv)).2.1 + (addStep (c, acc, ru, rv)).2.2.1 (addStep (c, acc, ru, rv)).2.2.2 := by + rw [addStepP, addPack] + simp only [fstBlock_pair, sndBlock_pair] + cases ru with + | nil => + have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl + rw [selectHead, hflag] + simp [addPack] + | cons b t => + have hflag : lenLeFlag (b :: t) [false] = [true] := + (lenLeFlag_eq_true_iff (b :: t) [false]).mpr (by simp) + rw [selectHead, hflag] + simp only [List.head?_cons, reduceIte] + rw [addStep, addPack] + simp [addPack] + +/-- **The packed iteration is the unpacked one.** -/ +theorem addStepP_iterate (s : List Bool × List Bool × List Bool × List Bool) (n : ℕ) : + addStepP^[n] (addPack s.1 s.2.1 s.2.2.1 s.2.2.2) + = addPack (addStep^[n] s).1 (addStep^[n] s).2.1 (addStep^[n] s).2.2.1 + (addStep^[n] s).2.2.2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, addStepP_pack, ih (addStep s), + Function.iterate_succ_apply] + +theorem addStepP_iterate_args (c acc ru rv : List Bool) (n : ℕ) : + addStepP^[n] (addPack c acc ru rv) + = addPack (addStep^[n] (c, acc, ru, rv)).1 (addStep^[n] (c, acc, ru, rv)).2.1 + (addStep^[n] (c, acc, ru, rv)).2.2.1 (addStep^[n] (c, acc, ru, rv)).2.2.2 := + addStepP_iterate (c, acc, ru, rv) n + +/-! ## The verdicts -/ + +/-- The packed addition run to completion. -/ +def addRun (u v : List Bool) : List Bool := addStepP^[u.length] (addPack [false] [] u v) + +/-- The sum bits of `u` and `v`. -/ +def addBits (u v : List Bool) : List Bool := fstBlock (sndBlock (addRun u v)) + +/-- The carry out of `u + v`. -/ +def addCarry (u v : List Bool) : List Bool := fstBlock (addRun u v) + +theorem addRun_eq (u v : List Bool) (h : v.length = u.length) : + addRun u v = addPack [(addBitsLE false u v).1] (addBitsLE false u v).2 [] [] := by + rw [addRun, addStepP_iterate_args, addStep_iterate_run false [] u v h] + simp + +@[simp] theorem addBits_eq (u v : List Bool) (h : v.length = u.length) : + addBits u v = (addBitsLE false u v).2 := by + rw [addBits, addRun_eq u v h, addPack] + simp + +@[simp] theorem addCarry_eq (u v : List Bool) (h : v.length = u.length) : + addCarry u v = [(addBitsLE false u v).1] := by + rw [addCarry, addRun_eq u v h, addPack] + simp + +/-- **What the packed addition computes.** -/ +theorem addBits_binValLE (u v : List Bool) (h : v.length = u.length) + (hc : addCarry u v = [false]) : binValLE (addBits u v) = binValLE u + binValLE v := by + have hk := addBitsLE_binValLE false u v h + rw [addCarry_eq u v h] at hc + have hc' : (addBitsLE false u v).1 = false := by + have := congrArg (fun l => l.headD false) hc + simpa using this + rw [hc'] at hk + simp at hk + rw [addBits_eq u v h] + exact hk + +theorem addBits_length (u v : List Bool) (h : v.length = u.length) : + (addBits u v).length = u.length := by + rw [addBits_eq u v h, addBitsLE_length] + +/-! ## Addition is polynomial-time -/ + +theorem addStepP_mem_FP : addStepP ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hc := hfst hid + have hw := hsnd hid + have hacc := hfst hw + have hww := hsnd hw + have hru := hfst hww + have hrv := hsnd hww + have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] + have htakeU : (fun z => bit1 (fstBlock (sndBlock (sndBlock z)))) ∈ FP := by + have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hru hone) + simpa [bit1] using this + have htakeV : (fun z => bit1 (sndBlock (sndBlock (sndBlock z)))) ∈ FP := by + have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hrv hone) + simpa [bit1] using this + have hdropU : (fun z => (fstBlock (sndBlock (sndBlock z))).drop 1) ∈ FP := by + have := dropLenFn_mem_FP hone hru + simpa using this + have hdropV : (fun z => (sndBlock (sndBlock (sndBlock z))).drop 1) ∈ FP := by + have := dropLenFn_mem_FP hone hrv + simpa using this + have hxor : ∀ {a b : List Bool → List Bool}, a ∈ FP → b ∈ FP → + (fun z => xorBit (a z) (b z)) ∈ FP := fun ha hb => + Cobham.selectHeadFn_mem_FP ha (notBitFn_mem_FP hb) hb + have hmaj : (fun z => majBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) + (bit1 (sndBlock (sndBlock (sndBlock z))))) ∈ FP := + orBitFn_mem_FP (andBitFn_mem_FP hc htakeU) + (orBitFn_mem_FP (andBitFn_mem_FP hc htakeV) (andBitFn_mem_FP htakeU htakeV)) + have hsum : (fun z => sumBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) + (bit1 (sndBlock (sndBlock (sndBlock z))))) ∈ FP := + hxor (hxor hc htakeU) htakeV + exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hru hone) + (Cobham.pairFn_mem_FP hmaj + (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hacc hsum) + (Cobham.pairFn_mem_FP hdropU hdropV))) hid + +theorem addRunFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => addRun (a z) (b z)) ∈ FP := by + have hinit : (fun z => addPack [false] [] (a z) (b z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP [false]) + (Cobham.pairFn_mem_FP (constFn_mem_FP []) (Cobham.pairFn_mem_FP ha hb)) + have hwidth : (fun z => addPack [false] (a z) (a z) (b z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP [false]) + (Cobham.pairFn_mem_FP ha (Cobham.pairFn_mem_FP ha hb)) + have hbound : ∀ z, ∀ n ≤ (a z).length, + (addStepP^[n] (addPack [false] [] (a z) (b z))).length + ≤ (addPack [false] (a z) (a z) (b z)).length := by + intro z n _ + rw [addStepP_iterate_args] + obtain ⟨h1, h2, h3⟩ := addStep_iterate_length false [] (a z) (b z) n + have hone1 : ([false] : List Bool).length = 1 := rfl + rw [addPack_length, addPack_length] + simp only [List.length_nil] at h2 + omega + exact Cobham.iterate_mem_FP addStepP_mem_FP hinit ha hwidth hbound + +theorem addBitsFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => addBits (a z) (b z)) ∈ FP := by + have h1 := mem_FP_comp (addRunFn_mem_FP ha hb) Cobham.sndBlock_mem_FP + have h2 := mem_FP_comp h1 Cobham.fstBlock_mem_FP + simpa [Function.comp, addBits] using h2 + +theorem addCarryFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => addCarry (a z) (b z)) ∈ FP := by + have h := mem_FP_comp (addRunFn_mem_FP ha hb) Cobham.fstBlock_mem_FP + simpa [Function.comp, addCarry] using h + +/-! ## Comparison as a recursion -/ + +/-- Scan two little-endian bitstrings from the bottom, keeping the verdict of the highest +position at which they have differed so far. -/ +def ltBitsLE : Bool → List Bool → List Bool → Bool + | f, [], _ => f + | f, b :: tu, v => + ltBitsLE (if b = v.headD false then f else v.headD false) tu (v.drop 1) + +@[simp] theorem ltBitsLE_nil (f : Bool) (v : List Bool) : ltBitsLE f [] v = f := rfl + +theorem ltBitsLE_cons (f b : Bool) (tu v : List Bool) : + ltBitsLE f (b :: tu) v + = ltBitsLE (if b = v.headD false then f else v.headD false) tu (v.drop 1) := rfl + +/-- **The comparator is correct.** -/ +theorem ltBitsLE_spec (f : Bool) (u v : List Bool) (h : v.length = u.length) : + ltBitsLE f u v = if binValLE u < binValLE v then true + else if binValLE v < binValLE u then false else f := by + induction u generalizing f v with + | nil => + have hv : v = [] := List.eq_nil_of_length_eq_zero (by simpa using h) + subst hv + simp [binValLE] + | cons b tu ih => + obtain ⟨d, tv, rfl⟩ : ∃ d tv, v = d :: tv := by + cases v with + | nil => simp at h + | cons d tv => exact ⟨d, tv, rfl⟩ + have htv : tv.length = tu.length := by simpa using h + rw [ltBitsLE_cons] + simp only [List.headD_cons, List.drop_succ_cons, List.drop_zero] + rw [ih _ tv htv, binValLE_cons, binValLE_cons] + have hb : b.toNat ≤ 1 := by cases b <;> simp + have hd : d.toNat ≤ 1 := by cases d <;> simp + rcases lt_trichotomy (binValLE tu) (binValLE tv) with hlt | heq | hgt + · rw [if_pos hlt, if_pos (by omega)] + · rw [if_neg (by omega), if_neg (by omega), heq] + cases b <;> cases d <;> simp + · rw [if_neg (by omega), if_pos hgt, if_neg (by omega), if_pos (by omega)] + +/-! ## Comparison as a scan -/ + +/-- One step of the comparison scan. -/ +def ltStep : List Bool × List Bool × List Bool → List Bool × List Bool × List Bool + | (f, [], v) => (f, [], v) + | (f, b :: tu, v) => (selectHead (eqFlag [b] (bit1 v)) f (bit1 v), tu, v.drop 1) + +@[simp] theorem ltStep_nil (f v : List Bool) : ltStep (f, [], v) = (f, [], v) := rfl + +theorem ltStep_flag (f b : Bool) (tu v : List Bool) : + ltStep ([f], b :: tu, v) + = ([if b = v.headD false then f else v.headD false], tu, v.drop 1) := by + rw [ltStep, bit1_eq] + by_cases hb : b = v.headD false + · rw [if_pos hb, hb] + have : eqFlag [v.headD false] [v.headD false] = [true] := + (eqFlag_eq_true_iff _ _).mpr rfl + rw [this] + rfl + · rw [if_neg hb] + have : eqFlag [b] [v.headD false] = [false] := by + rcases eqFlag_flag [b] [v.headD false] with hh | hh + · exact absurd (by simpa using (eqFlag_eq_true_iff [b] [v.headD false]).mp hh) hb + · exact hh + rw [this] + rfl + +/-- **The scan computes the comparison.** -/ +theorem ltStep_iterate_run (f : Bool) (u v : List Bool) (h : v.length = u.length) : + ltStep^[u.length] ([f], u, v) = ([ltBitsLE f u v], [], []) := by + induction u generalizing f v with + | nil => + have hv : v = [] := List.eq_nil_of_length_eq_zero (by simpa using h) + subst hv + simp + | cons b tu ih => + obtain ⟨d, tv, rfl⟩ : ∃ d tv, v = d :: tv := by + cases v with + | nil => simp at h + | cons d tv => exact ⟨d, tv, rfl⟩ + have htv : tv.length = tu.length := by simpa using h + rw [List.length_cons, Function.iterate_succ_apply, ltStep_flag] + simp only [List.headD_cons, List.drop_succ_cons, List.drop_zero] + rw [ih _ tv htv, ltBitsLE_cons] + simp + +theorem ltStep_iterate_length (f : Bool) (u v : List Bool) (n : ℕ) : + (ltStep^[n] ([f], u, v)).1.length = 1 ∧ + (ltStep^[n] ([f], u, v)).2.1.length ≤ u.length ∧ + (ltStep^[n] ([f], u, v)).2.2.length ≤ v.length := by + induction n generalizing f u v with + | zero => exact ⟨rfl, le_rfl, le_rfl⟩ + | succ n ih => + rw [Function.iterate_succ_apply] + cases u with + | nil => simpa using ih f [] v + | cons b tu => + rw [ltStep_flag] + have := ih (if b = v.headD false then f else v.headD false) tu (v.drop 1) + exact ⟨this.1, le_trans this.2.1 (by simp), le_trans this.2.2 (by simp)⟩ + +/-! ## The packed comparison -/ + +/-- The packed comparison state. -/ +def ltPack (f ru rv : List Bool) : List Bool := pair f (pair ru rv) + +@[simp] theorem ltPack_length (f ru rv : List Bool) : + (ltPack f ru rv).length = 2 * f.length + 2 * ru.length + rv.length + 4 := by + rw [ltPack, pair_length, pair_length] + omega + +/-- One step of the packed comparison. -/ +def ltStepP (z : List Bool) : List Bool := + selectHead (lenLeFlag (fstBlock (sndBlock z)) [false]) + (ltPack + (selectHead (eqFlag (bit1 (fstBlock (sndBlock z))) (bit1 (sndBlock (sndBlock z)))) + (fstBlock z) (bit1 (sndBlock (sndBlock z)))) + ((fstBlock (sndBlock z)).drop 1) + ((sndBlock (sndBlock z)).drop 1)) + z + +theorem ltStepP_pack (f ru rv : List Bool) : + ltStepP (ltPack f ru rv) + = ltPack (ltStep (f, ru, rv)).1 (ltStep (f, ru, rv)).2.1 (ltStep (f, ru, rv)).2.2 := by + rw [ltStepP, ltPack] + simp only [fstBlock_pair, sndBlock_pair] + cases ru with + | nil => + have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl + rw [selectHead, hflag] + simp [ltPack] + | cons b t => + have hflag : lenLeFlag (b :: t) [false] = [true] := + (lenLeFlag_eq_true_iff (b :: t) [false]).mpr (by simp) + rw [selectHead, hflag] + simp only [List.head?_cons, reduceIte] + rw [ltStep, ltPack] + simp [ltPack] + +theorem ltStepP_iterate (s : List Bool × List Bool × List Bool) (n : ℕ) : + ltStepP^[n] (ltPack s.1 s.2.1 s.2.2) + = ltPack (ltStep^[n] s).1 (ltStep^[n] s).2.1 (ltStep^[n] s).2.2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, ltStepP_pack, ih (ltStep s), Function.iterate_succ_apply] + +theorem ltStepP_iterate_args (f ru rv : List Bool) (n : ℕ) : + ltStepP^[n] (ltPack f ru rv) + = ltPack (ltStep^[n] (f, ru, rv)).1 (ltStep^[n] (f, ru, rv)).2.1 + (ltStep^[n] (f, ru, rv)).2.2 := + ltStepP_iterate (f, ru, rv) n + +/-- The packed comparison run to completion. -/ +def ltRun (u v : List Bool) : List Bool := ltStepP^[u.length] (ltPack [false] u v) + +/-- Is `u` below `v`, as a flag. -/ +def ltFlag (u v : List Bool) : List Bool := fstBlock (ltRun u v) + +theorem ltFlag_eq (u v : List Bool) (h : v.length = u.length) : + ltFlag u v = [ltBitsLE false u v] := by + rw [ltFlag, ltRun, ltStepP_iterate_args, ltStep_iterate_run false u v h, ltPack] + simp + +/-- **The flag decides the comparison.** -/ +theorem ltFlag_eq_true_iff (u v : List Bool) (h : v.length = u.length) : + ltFlag u v = [true] ↔ binValLE u < binValLE v := by + rw [ltFlag_eq u v h, ltBitsLE_spec false u v h] + rcases lt_trichotomy (binValLE u) (binValLE v) with hlt | heq | hgt + · rw [if_pos hlt] + simp [hlt] + · rw [if_neg (by omega), if_neg (by omega)] + simp + omega + · rw [if_neg (by omega), if_pos hgt] + simp + omega + +theorem ltFlag_flag (u v : List Bool) (h : v.length = u.length) : + ltFlag u v = [true] ∨ ltFlag u v = [false] := by + rw [ltFlag_eq u v h] + cases ltBitsLE false u v + · exact Or.inr rfl + · exact Or.inl rfl + +/-! ## Comparison is polynomial-time -/ + +theorem ltStepP_mem_FP : ltStepP ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → + (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hf := hfst hid + have hw := hsnd hid + have hru := hfst hw + have hrv := hsnd hw + have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] + have hbU : (fun z => bit1 (fstBlock (sndBlock z))) ∈ FP := by + have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hru hone) + simpa [bit1] using this + have hbV : (fun z => bit1 (sndBlock (sndBlock z))) ∈ FP := by + have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hrv hone) + simpa [bit1] using this + have hdU : (fun z => (fstBlock (sndBlock z)).drop 1) ∈ FP := by + have := dropLenFn_mem_FP hone hru + simpa using this + have hdV : (fun z => (sndBlock (sndBlock z)).drop 1) ∈ FP := by + have := dropLenFn_mem_FP hone hrv + simpa using this + exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hru hone) + (Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP (eqFlagFn_mem_FP hbU hbV) hf hbV) + (Cobham.pairFn_mem_FP hdU hdV)) hid + +theorem ltFlagFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => ltFlag (a z) (b z)) ∈ FP := by + have hinit : (fun z => ltPack [false] (a z) (b z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP ha hb) + have hwidth : (fun z => ltPack [false] (a z) (b z)) ∈ FP := hinit + have hbound : ∀ z, ∀ n ≤ (a z).length, + (ltStepP^[n] (ltPack [false] (a z) (b z))).length + ≤ (ltPack [false] (a z) (b z)).length := by + intro z n _ + rw [ltStepP_iterate_args] + obtain ⟨h1, h2, h3⟩ := ltStep_iterate_length false (a z) (b z) n + have hone1 : ([false] : List Bool).length = 1 := rfl + rw [ltPack_length, ltPack_length] + omega + have h := Cobham.iterate_mem_FP ltStepP_mem_FP hinit ha hwidth hbound + have h1 := mem_FP_comp h Cobham.fstBlock_mem_FP + simpa [Function.comp, ltFlag, ltRun] using h1 + +/-! ## The larger of two numbers -/ + +/-- The larger of two equal-width numbers. -/ +def maxBits (u v : List Bool) : List Bool := selectHead (ltFlag u v) v u + +theorem maxBits_eq (u v : List Bool) (h : v.length = u.length) : + maxBits u v = if binValLE u < binValLE v then v else u := by + rw [maxBits] + by_cases hlt : binValLE u < binValLE v + · rw [if_pos hlt, (ltFlag_eq_true_iff u v h).mpr hlt] + rfl + · rw [if_neg hlt] + rcases ltFlag_flag u v h with hf | hf + · exact absurd ((ltFlag_eq_true_iff u v h).mp hf) hlt + · rw [hf] + rfl + +theorem maxBitsFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => maxBits (a z) (b z)) ∈ FP := + Cobham.selectHeadFn_mem_FP (ltFlagFn_mem_FP ha hb) hb ha + +/-! ## Arithmetic without overflow -/ + +/-- **Adding below the width is exact.** -/ +theorem binValLE_addBits (u v : List Bool) (h : v.length = u.length) + (hlt : binValLE u + binValLE v < 2 ^ u.length) : + binValLE (addBits u v) = binValLE u + binValLE v := by + have hk := addBitsLE_binValLE false u v h + simp only [Bool.toNat_false, Nat.add_zero] at hk + have hc : (addBitsLE false u v).1 = false := by + by_contra hc + simp only [Bool.not_eq_false] at hc + rw [hc, Bool.toNat_true, Nat.one_mul] at hk + have := binValLE_lt (addBitsLE false u v).2 + omega + rw [hc, Bool.toNat_false, Nat.zero_mul, Nat.add_zero] at hk + rw [addBits_eq u v h] + exact hk + +theorem binValLE_maxBits (u v : List Bool) (h : v.length = u.length) : + binValLE (maxBits u v) = max (binValLE u) (binValLE v) := by + rw [maxBits_eq u v h] + by_cases hlt : binValLE u < binValLE v + · rw [if_pos hlt]; omega + · rw [if_neg hlt]; omega + +theorem maxBits_length (u v : List Bool) (h : v.length = u.length) : + (maxBits u v).length = u.length := by + rw [maxBits_eq u v h] + split + · exact h + · rfl + +theorem bumpOver_eq_false_of_lt {w : List Bool} (h : binValLE w + 1 < 2 ^ w.length) : + bumpOver w = false := by + by_contra hc + simp only [Bool.not_eq_false] at hc + rw [bumpOver_iff] at hc + omega + +/-! ## Powers of two as bitstrings -/ + +theorem binValLE_replicate_false : ∀ n : ℕ, binValLE (List.replicate n false) = 0 + | 0 => rfl + | n + 1 => by + simp [List.replicate_succ, binValLE, binValLE_replicate_false n] + +theorem padTo_nil (r : List Bool) : padTo r [] = List.replicate r.length false := by + rw [padTo_eq_append r [] (by simp)] + simp + + +theorem binValLE_replicate_false_append : ∀ (n : ℕ) (z : List Bool), + binValLE (List.replicate n false ++ z) = 2 ^ n * binValLE z + | 0, z => by simp + | n + 1, z => by + rw [List.replicate_succ, List.cons_append, binValLE_cons, + binValLE_replicate_false_append n z, pow_succ] + simp + ring + +/-- The bitstring of `2 ^ t`, one bit wider than `t` bits so that it can be compared with a +doubled `t + 1`-bit count. -/ +def twoPowBits (t : ℕ) : List Bool := List.replicate t false ++ [true, false] + +@[simp] theorem twoPowBits_length (t : ℕ) : (twoPowBits t).length = t + 2 := by + rw [twoPowBits] + simp + +@[simp] theorem binValLE_twoPowBits (t : ℕ) : binValLE (twoPowBits t) = 2 ^ t := by + rw [twoPowBits, binValLE_replicate_false_append] + simp [binValLE] + +/-- **The threshold comparison, as the algebra performs it.** A count `w` of `t + 1` bits exceeds +half of `2 ^ t` exactly when the doubled count is above `2 ^ t`. -/ +theorem two_pow_lt_two_mul_iff (t : ℕ) (w : List Bool) (hw : w.length = t + 1) : + 2 ^ t < 2 * binValLE w ↔ ltFlag (twoPowBits t) (false :: w) = [true] := by + have hlen : (false :: w).length = (twoPowBits t).length := by + rw [List.length_cons, hw, twoPowBits_length] + rw [ltFlag_eq_true_iff _ _ hlen, binValLE_twoPowBits, binValLE_cons] + simp + +/-! ## Selection on a literal flag -/ + +@[simp] theorem selectHead_cons_true (x y : List Bool) : + Cobham.selectHead [true] x y = x := by + rw [Cobham.selectHead]; simp + +@[simp] theorem selectHead_cons_false (x y : List Bool) : + Cobham.selectHead [false] x y = y := by + rw [Cobham.selectHead]; simp + +/-! ## Emptiness and the leading bit -/ + +/-- Is the string empty, as a flag. -/ +def emptyFlag (y : List Bool) : List Bool := lenLeFlag [] y + +@[simp] theorem emptyFlag_nil : emptyFlag [] = [true] := rfl + +theorem emptyFlag_cons (b : Bool) (y : List Bool) : emptyFlag (b :: y) = [false] := by + rw [emptyFlag, lenLeFlag] + simp [nonemptyFlag, notBit] + +theorem emptyFlag_pair (a b : List Bool) : emptyFlag (pair a b) = [false] := by + cases a with + | nil => rw [pair]; rfl + | cons c a => rw [pair_cons_eq]; exact emptyFlag_cons _ _ + +theorem emptyFlagFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => emptyFlag (a z)) ∈ FP := + lenLeFlagFn_mem_FP (constFn_mem_FP []) ha + +/-- Drop the leading bit. -/ +def dropOne (y : List Bool) : List Bool := y.drop 1 + +theorem dropOneFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => dropOne (a z)) ∈ FP := by + have := dropLenFn_mem_FP (constFn_mem_FP [false]) ha + simpa [dropOne] using this + +/-! ## The strings of a given length -/ + +/-- The bitstrings of length exactly `ℓ`. -/ +def strsOfLen (ℓ : ℕ) : Finset (List Bool) := + (Finset.range (2 ^ ℓ)).image (bitsOfLenLE ℓ) + +@[simp] theorem mem_strsOfLen {ℓ : ℕ} {l : List Bool} : l ∈ strsOfLen ℓ ↔ l.length = ℓ := by + rw [strsOfLen, Finset.mem_image] + constructor + · rintro ⟨v, _, rfl⟩ + exact bitsOfLenLE_length ℓ v + · intro h + refine ⟨binValLE l, Finset.mem_range.mpr ?_, ?_⟩ + · have := binValLE_lt l + rwa [h] at this + · rw [← h, bitsOfLenLE_binValLE] + +/-- The bitstrings of length at most `m`. -/ +def strsLe (m : ℕ) : Finset (List Bool) := + (Finset.range (m + 1)).biUnion strsOfLen + +@[simp] theorem mem_strsLe {m : ℕ} {l : List Bool} : l ∈ strsLe m ↔ l.length ≤ m := by + rw [strsLe, Finset.mem_biUnion] + constructor + · rintro ⟨j, hj, hl⟩ + rw [mem_strsOfLen] at hl + rw [hl] + exact Nat.lt_succ_iff.mp (Finset.mem_range.mp hj) + · intro h + exact ⟨l.length, Finset.mem_range.mpr (by omega), mem_strsOfLen.mpr rfl⟩ + +theorem strsLe_nonempty (m : ℕ) : (strsLe m).Nonempty := + ⟨[], mem_strsLe.mpr (by simp)⟩ + +/-! ## Enumerating every short string with one counter + +A search that sums over all strings of length at most `m` must visit each exactly once. One +counter suffices: order the strings by length and then by value, so the successor of the +all-ones string of length `ℓ` is the all-zeros string of length `ℓ + 1`. The position of a string +in that order is `Complexity.strIdx`, and it increases by one at every step, which is what makes +the enumeration a bijection. -/ + +/-- The position of a string in the order: by length first, then by value. -/ +def strIdx (w : List Bool) : ℕ := 2 ^ w.length - 1 + binValLE w + +/-- The next string in the order. -/ +def nextStr (w : List Bool) : List Bool := + if bumpOver w then List.replicate (w.length + 1) false else bumpBits w + +@[simp] theorem strIdx_nil : strIdx [] = 0 := rfl + +theorem strIdx_lower (w : List Bool) : 2 ^ w.length - 1 ≤ strIdx w := by + rw [strIdx]; omega + +theorem strIdx_upper (w : List Bool) : strIdx w + 2 ≤ 2 ^ (w.length + 1) := by + have hlt := binValLE_lt w + have : 2 ^ (w.length + 1) = 2 ^ w.length * 2 := by rw [pow_succ] + have hpos : 0 < 2 ^ w.length := Nat.two_pow_pos _ + rw [strIdx] + omega + +/-- **The counter steps one place along the order.** -/ +theorem strIdx_nextStr (w : List Bool) : strIdx (nextStr w) = strIdx w + 1 := by + rw [nextStr] + by_cases hov : bumpOver w + · rw [if_pos hov, strIdx, strIdx, List.length_replicate, binValLE_replicate_false, + (bumpOver_iff w).mp hov] + have hpos : 0 < 2 ^ w.length := Nat.two_pow_pos _ + have : 2 ^ (w.length + 1) = 2 ^ w.length * 2 := by rw [pow_succ] + omega + · rw [if_neg hov, strIdx, strIdx, bumpBits_length, + binValLE_bumpBits_of_not_over w (by simpa using hov)] + omega + +theorem strIdx_iterate : ∀ i : ℕ, strIdx (nextStr^[i] []) = i := by + intro i + induction i with + | zero => rfl + | succ i ih => rw [Function.iterate_succ_apply', strIdx_nextStr, ih] + +theorem strIdx_injective {w w' : List Bool} (h : strIdx w = strIdx w') : w = w' := by + have hlen : w.length = w'.length := by + by_contra hne + rcases Nat.lt_or_ge w.length w'.length with hlt | hge + · have h1 := strIdx_upper w + have h2 := strIdx_lower w' + have h3 : 2 ^ (w.length + 1) ≤ 2 ^ w'.length := + Nat.pow_le_pow_right (by omega) (by omega) + omega + · have hlt : w'.length < w.length := by omega + have h1 := strIdx_upper w' + have h2 := strIdx_lower w + have h3 : 2 ^ (w'.length + 1) ≤ 2 ^ w.length := + Nat.pow_le_pow_right (by omega) (by omega) + omega + have hval : binValLE w = binValLE w' := by + rw [strIdx, strIdx, hlen] at h + omega + rw [← bitsOfLenLE_binValLE w, ← bitsOfLenLE_binValLE w', hlen, hval] + +theorem strIdx_lt_iff (m : ℕ) (w : List Bool) : + strIdx w < 2 ^ (m + 1) - 1 ↔ w.length ≤ m := by + constructor + · intro h + by_contra hlen + have h1 := strIdx_lower w + have h2 : 2 ^ (m + 1) ≤ 2 ^ w.length := Nat.pow_le_pow_right (by omega) (by omega) + have hpos : 0 < 2 ^ (m + 1) := Nat.two_pow_pos _ + omega + · intro h + have h1 := strIdx_upper w + have h2 : 2 ^ (w.length + 1) ≤ 2 ^ (m + 1) := Nat.pow_le_pow_right (by omega) (by omega) + have hpos : 0 < 2 ^ (m + 1) := Nat.two_pow_pos _ + omega + +/-- **The counter enumerates every short string exactly once.** -/ +theorem strsLe_eq_image (m : ℕ) : + strsLe m = (Finset.range (2 ^ (m + 1) - 1)).image fun i => nextStr^[i] [] := by + classical + ext w + rw [mem_strsLe, Finset.mem_image] + constructor + · intro h + refine ⟨strIdx w, Finset.mem_range.mpr ((strIdx_lt_iff m w).mpr h), ?_⟩ + exact strIdx_injective (by rw [strIdx_iterate]) + · rintro ⟨i, hi, rfl⟩ + refine (strIdx_lt_iff m _).mp ?_ + rw [strIdx_iterate] + exact Finset.mem_range.mp hi + +theorem nextStr_injOn (m : ℕ) : + Set.InjOn (fun i => nextStr^[i] []) (↑(Finset.range (2 ^ (m + 1) - 1)) : Set ℕ) := by + intro i _ j _ h + have := congrArg strIdx h + rwa [strIdx_iterate, strIdx_iterate] at this + +theorem bitsOfLenLE_zero (ℓ : ℕ) : bitsOfLenLE ℓ 0 = List.replicate ℓ false := by + induction ℓ with + | zero => rfl + | succ ℓ ih => rw [bitsOfLenLE, ih, List.replicate_succ]; simp + +/-- **The counter enumerates the strings of one length too**, starting from the zeros. -/ +theorem strsOfLen_eq_image (ℓ : ℕ) : + strsOfLen ℓ + = (Finset.range (2 ^ ℓ)).image fun i => bumpBits^[i] (List.replicate ℓ false) := by + rw [strsOfLen] + refine Finset.image_congr fun i hi => ?_ + rw [← bitsOfLenLE_zero, bumpBits_iterate ℓ i (Finset.mem_range.mp hi)] + +theorem bumpBits_injOn (ℓ : ℕ) : + Set.InjOn (fun i => bumpBits^[i] (List.replicate ℓ false)) + (↑(Finset.range (2 ^ ℓ)) : Set ℕ) := by + intro i hi j hj h + rw [Finset.mem_coe, Finset.mem_range] at hi hj + simp only [← bitsOfLenLE_zero] at h + rw [bumpBits_iterate ℓ i hi, bumpBits_iterate ℓ j hj] at h + have := congrArg binValLE h + rwa [binValLE_bitsOfLenLE ℓ i hi, binValLE_bitsOfLenLE ℓ j hj] at this + +theorem nextStrFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => nextStr (a z)) ∈ FP := by + have heq : (fun z => selectHead (bumpFlag (a z)) (padTo (a z ++ [false]) []) (bumpCode (a z))) + = fun z => nextStr (a z) := by + funext z + rw [nextStr, bumpFlag_eq, bumpCode_eq] + by_cases hov : bumpOver (a z) + · rw [if_pos hov, hov, selectHead, padTo_nil] + simp + · rw [if_neg hov, selectHead] + simp only [Bool.not_eq_true] at hov + rw [hov] + simp + refine mem_FP_of_eq ?_ fun z => congrFun heq z + exact Cobham.selectHeadFn_mem_FP (bumpFlagFn_mem_FP ha) + (padToFn_mem_FP (Cobham.appendFn_mem_FP ha (constFn_mem_FP [false])) (constFn_mem_FP [])) + (bumpCodeFn_mem_FP ha) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BitCodec.lean b/Complexitylib/Classes/Containments/Internal/BitCodec.lean new file mode 100644 index 00000000..5e962081 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BitCodec.lean @@ -0,0 +1,418 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.CodeSearch +public import Complexitylib.Models.TuringMachine.GuessStream +public import Complexitylib.Classes.Containments.Internal.WitnessEnum + +/-! +# Fixed-width bit layouts + +⚠️ Unreviewed by Bolton + +A machine that searches the configuration space of another machine has to hold configurations in +registers and step a counter through all of them. Both want the same thing: a **fixed-width** +bit layout, so that a register is a fixed number of cells and the enumeration is one binary +counter. + +`Complexity.BitCodec` is that layout, packaged so it can be built up field by field. Each codec +carries its width, an encoder, a decoder that is total on every bitstring, and the two facts a +caller needs: the encoding has the declared width, and decoding inverts it. The combinators — +`Complexity.BitCodec.prod`, `Complexity.BitCodec.fn`, `Complexity.BitCodec.equiv` — discharge +those obligations once, so a record layout is assembled rather than proved. + +The decoder being total matters. The machine enumerates *all* bitstrings of the layout's width, +not just the ones in the image, so every register value must denote something; the ones outside +the image simply denote a configuration that no walk ever reaches. + +So does where the head positions go. A machine reads a register by scanning it, so a head stored +as a number in its own field would be useless — to check the cell it points at, the scan would +have to turn around. `Complexity.tapeCodec` therefore stores the head as a **marker beside each +cell**: the scan learns at every cell whether the head is there, which is what makes a +`Complexity.Scanner` able to check a transition of the simulated machine without ever counting. + +## Main definitions + +- `Complexity.BitCodec` — a fixed-width bit layout +- `Complexity.BitCodec.fin`, `.gamma`, `.bool`, `.prod`, `.fn`, `.equiv` — the combinators +- `Complexity.tapeCodec` — a tape window, with the head marked beside the cell it is on +- `Complexity.codeCodec` — the layout of a configuration code + +## Main results + +- `Complexity.BitCodec.enc_injective` — a layout distinguishes what it encodes +- `Complexity.codeCodec_width` — the width of a configuration code +-/ + +@[expose] public section + +namespace Complexity + +/-- A fixed-width bit layout for `α`: an encoder of constant width, and a decoder that is total +on every bitstring and inverts it. -/ +structure BitCodec (α : Type) where + /-- The number of bits an encoded value occupies. -/ + width : ℕ + /-- The encoder. -/ + enc : α → List Bool + /-- The decoder, total on every bitstring. -/ + dec : List Bool → α + /-- Encodings have the declared width. -/ + enc_length : ∀ a, (enc a).length = width + /-- Decoding inverts encoding. -/ + dec_enc : ∀ a, dec (enc a) = a + +namespace BitCodec + +theorem enc_injective {α : Type} (c : BitCodec α) : Function.Injective c.enc := by + intro a b h + rw [← c.dec_enc a, ← c.dec_enc b, h] + +/-! ## Leaves -/ + +/-- A bounded index, little-endian in `w` bits. -/ +def fin (m w : ℕ) [NeZero m] (h : m ≤ 2 ^ w) : BitCodec (Fin m) where + width := w + enc i := bitsOfLenLE w i.val + dec l := ⟨binValLE (l.take w) % m, Nat.mod_lt _ (NeZero.pos m)⟩ + enc_length _ := bitsOfLenLE_length _ _ + dec_enc i := by + have hlen : (bitsOfLenLE w i.val).length = w := bitsOfLenLE_length _ _ + have htake : (bitsOfLenLE w i.val).take w = bitsOfLenLE w i.val := by + rw [List.take_of_length_le (le_of_eq hlen)] + have hval : binValLE (bitsOfLenLE w i.val) = i.val := + binValLE_bitsOfLenLE w i.val (lt_of_lt_of_le i.isLt h) + apply Fin.ext + show binValLE ((bitsOfLenLE w i.val).take w) % m = i.val + rw [htake, hval, Nat.mod_eq_of_lt i.isLt] + +/-- A tape symbol, in two bits. -/ +def gamma : BitCodec Γ where + width := 2 + enc g := + match g with + | .zero => [false, false] + | .one => [true, false] + | .blank => [false, true] + | .start => [true, true] + dec l := + match l.take 2 with + | [false, false] => .zero + | [true, false] => .one + | [false, true] => .blank + | _ => .start + enc_length g := by cases g <;> rfl + dec_enc g := by cases g <;> rfl + +/-- A single bit. -/ +def bool : BitCodec Bool where + width := 1 + enc b := [b] + dec l := l.headI + enc_length _ := rfl + dec_enc _ := rfl + +/-! ## Reading a value out of a scan + +A scan puts a register's leading bits into a table (`Complexity.Scanner.bitsStep`). This reads the +value they encode back out, which is how a check recovers, say, the simulated machine's state from +the parameters it was handed. -/ + +/-- The value a table of bits encodes. -/ +def ofTable {α : Type} (c : BitCodec α) (f : Fin c.width → Bool) : α := + c.dec (List.ofFn f) + +theorem ofTable_eq {α : Type} (c : BitCodec α) (a : α) (f : Fin c.width → Bool) + (h : ∀ i : Fin c.width, + f i = (c.enc a)[i.val]'(by rw [c.enc_length]; exact i.isLt)) : + c.ofTable f = a := by + have hlist : List.ofFn f = c.enc a := by + refine List.ext_getElem (by simp [c.enc_length]) ?_ + intro i h1 h2 + have hi : i < c.width := by simpa using h1 + rw [List.getElem_ofFn] + exact h ⟨i, hi⟩ + rw [ofTable, hlist, c.dec_enc] + +/-! ## Combinators -/ + +/-- Two layouts side by side. -/ +def prod {α β : Type} (c : BitCodec α) (d : BitCodec β) : BitCodec (α × β) where + width := c.width + d.width + enc p := c.enc p.1 ++ d.enc p.2 + dec l := (c.dec (l.take c.width), d.dec (l.drop c.width)) + enc_length p := by + rw [List.length_append, c.enc_length, d.enc_length] + dec_enc p := by + have h1 : (c.enc p.1 ++ d.enc p.2).take c.width = c.enc p.1 := by + rw [List.take_append_of_le_length (le_of_eq (c.enc_length p.1).symm), + List.take_of_length_le (le_of_eq (c.enc_length p.1))] + have h2 : (c.enc p.1 ++ d.enc p.2).drop c.width = d.enc p.2 := by + rw [← c.enc_length p.1, List.drop_left] + rw [h1, h2, c.dec_enc, d.dec_enc] + +/-- Transport a layout along an equivalence. -/ +def equiv {α β : Type} (e : α ≃ β) (c : BitCodec β) : BitCodec α where + width := c.width + enc a := c.enc (e a) + dec l := e.symm (c.dec l) + enc_length a := c.enc_length _ + dec_enc a := by rw [c.dec_enc, Equiv.symm_apply_apply] + +/-- The `i`-th fixed-width chunk of a concatenation. -/ +theorem take_drop_flatten {α : Type} (w : ℕ) : + ∀ (L : List (List α)), (∀ l ∈ L, l.length = w) → + ∀ (i : ℕ), (hi : i < L.length) → ((L.flatten).drop (i * w)).take w = L[i] := by + intro L + induction L with + | nil => intro _ i hi; simp at hi + | cons l L ih => + intro hlen i hi + cases i with + | zero => + have hl : l.length = w := hlen l (by simp) + simp only [Nat.zero_mul, List.drop_zero, List.flatten_cons] + rw [List.take_append_of_le_length (le_of_eq hl.symm), + List.take_of_length_le (le_of_eq hl)] + rfl + | succ i => + have hl : l.length = w := hlen l (by simp) + have hdrop : ((l :: L).flatten).drop ((i + 1) * w) = (L.flatten).drop (i * w) := by + have h1 : (l ++ L.flatten).drop (l.length + i * w) = (L.flatten).drop (i * w) := by + rw [← List.drop_drop, List.drop_left] + rw [List.flatten_cons, show (i + 1) * w = l.length + i * w by rw [hl]; ring] + exact h1 + rw [hdrop, ih (fun x hx => hlen x (by simp [hx])) i (by simpa using hi)] + rfl + +/-- A fixed number of copies of a layout, side by side. -/ +def fn {α : Type} (m : ℕ) (c : BitCodec α) : BitCodec (Fin m → α) where + width := m * c.width + enc f := ((List.finRange m).map (fun i => c.enc (f i))).flatten + dec l := fun i => c.dec ((l.drop (i.val * c.width)).take c.width) + enc_length f := by + rw [List.length_flatten] + have : ((List.finRange m).map (fun i => c.enc (f i))).map List.length + = (List.finRange m).map (fun _ => c.width) := by + rw [List.map_map] + exact List.map_congr_left (fun i _ => c.enc_length (f i)) + rw [this] + simp + dec_enc f := by + funext i + have hlen : ∀ l ∈ (List.finRange m).map (fun i => c.enc (f i)), l.length = c.width := by + intro l hl + obtain ⟨j, -, rfl⟩ := List.mem_map.mp hl + exact c.enc_length _ + have hi : i.val < ((List.finRange m).map (fun i => c.enc (f i))).length := by + simp [i.isLt] + rw [take_drop_flatten c.width _ hlen i.val hi] + simp [c.dec_enc] + +end BitCodec + +/-! ## The layout of a configuration code -/ + +/-- Bits enough to index `m` values. -/ +def bitWidth (m : ℕ) : ℕ := Nat.clog 2 m + +theorem le_two_pow_bitWidth (m : ℕ) : m ≤ 2 ^ bitWidth m := + Nat.le_pow_clog (by norm_num) m + +/-- The layout of a bounded index. -/ +def finCodec (m : ℕ) [NeZero m] : BitCodec (Fin m) := + BitCodec.fin m (bitWidth m) (le_two_pow_bitWidth m) + +@[simp] theorem finCodec_width (m : ℕ) [NeZero m] : (finCodec m).width = bitWidth m := rfl + +/-- The layout of a machine state. -/ +noncomputable def qCodec (Q : Type) [Fintype Q] [Nonempty Q] : BitCodec Q := + haveI : NeZero (Fintype.card Q) := ⟨Fintype.card_ne_zero⟩ + BitCodec.equiv (Fintype.equivFin Q) (finCodec (Fintype.card Q)) + +/-! ## Marking a head position where the scan will meet it + +A machine reads a register by scanning it, so a head position stored as a number in its own field +is useless: to check the cell it points at, the scan would have to come back. Storing it as a +**marker beside each cell** makes the head local — the scan learns, at each cell, whether the head +is there. -/ + +/-- Where the marker sits, or `0` if there is none. -/ +def markIdx {m : ℕ} (f : Fin m → Bool × Γ) : ℕ := + NTM.searchIdx (fun q => if h : q < m then (f ⟨q, h⟩).1 else false) m + +/-- Mark the cell the head is on. The marker comes first in the chunk, so that a scan knows +whether the head is on a cell before it reads that cell's symbol. -/ +def mark {m : ℕ} (p : Fin m × (Fin m → Γ)) : Fin m → Bool × Γ := + fun i => (decide (i = p.1), p.2 i) + +/-- Read the head position back off the markers. Total: with no marker, or several, it reads the +head as sitting at the first cell. -/ +def unmark {m : ℕ} [NeZero m] (f : Fin m → Bool × Γ) : Fin m × (Fin m → Γ) := + (⟨min (markIdx f) (m - 1), by + have hm : 0 < m := Nat.pos_of_neZero m + omega⟩, + fun i => (f i).2) + +theorem markIdx_mark {m : ℕ} (p : Fin m × (Fin m → Γ)) : markIdx (mark p) = p.1.val := by + refine NTM.searchIdx_eq p.1.isLt ?_ ?_ + · simp [mark, p.1.isLt] + · intro q hq + by_cases h : q < m + · have hqp : (⟨q, h⟩ : Fin m) = p.1 := by simpa [mark, h] using hq + exact congrArg Fin.val hqp + · simp [h] at hq + +@[simp] theorem unmark_mark {m : ℕ} [NeZero m] (p : Fin m × (Fin m → Γ)) : + unmark (mark p) = p := by + have hm : 0 < m := Nat.pos_of_neZero m + refine Prod.ext ?_ rfl + apply Fin.ext + show min (markIdx (mark p)) (m - 1) = p.1.val + rw [markIdx_mark] + have := p.1.isLt + omega + +/-- The two bits a symbol occupies. -/ +def gammaBits : Γ → Bool × Bool + | .zero => (false, false) + | .one => (true, false) + | .blank => (false, true) + | .start => (true, true) + +theorem gamma_enc_eq (g : Γ) : + BitCodec.gamma.enc g = [(gammaBits g).1, (gammaBits g).2] := by + cases g <;> rfl + +/-- The layout of one work tape's window: each cell beside a bit saying whether the head is on +it. -/ +def tapeCodec (m : ℕ) [NeZero m] : BitCodec (Fin m × (Fin m → Γ)) where + width := m * 3 + enc p := (BitCodec.fn m (BitCodec.bool.prod BitCodec.gamma)).enc (mark p) + dec l := unmark ((BitCodec.fn m (BitCodec.bool.prod BitCodec.gamma)).dec l) + enc_length p := (BitCodec.fn m (BitCodec.bool.prod BitCodec.gamma)).enc_length _ + dec_enc p := by + rw [(BitCodec.fn m (BitCodec.bool.prod BitCodec.gamma)).dec_enc, unmark_mark] + +/-- **One chunk of an encoded window**: the head marker, then the cell's two symbol bits. -/ +theorem tapeCodec_enc_chunk {m : ℕ} [NeZero m] (hd : Fin m) (cl : Fin m → Γ) (p : Fin m) : + (((tapeCodec m).enc (hd, cl)).drop (p.val * 3)).take 3 + = [decide (p = hd), (gammaBits (cl p)).1, (gammaBits (cl p)).2] := by + have hlen : ∀ l ∈ (List.finRange m).map + (fun i => (BitCodec.bool.prod BitCodec.gamma).enc (mark (hd, cl) i)), l.length = 3 := by + intro l hl + obtain ⟨i, -, rfl⟩ := List.mem_map.mp hl + exact (BitCodec.bool.prod BitCodec.gamma).enc_length _ + have hi : p.val < ((List.finRange m).map + (fun i => (BitCodec.bool.prod BitCodec.gamma).enc (mark (hd, cl) i))).length := by + simp [p.isLt] + have hchunk := BitCodec.take_drop_flatten 3 _ hlen p.val hi + rw [show (tapeCodec m).enc (hd, cl) = ((List.finRange m).map + (fun i => (BitCodec.bool.prod BitCodec.gamma).enc (mark (hd, cl) i))).flatten from rfl, + hchunk] + simp only [List.getElem_map, List.getElem_finRange] + show (BitCodec.bool.enc (mark (hd, cl) _).1) ++ (BitCodec.gamma.enc (mark (hd, cl) _).2) = _ + rw [gamma_enc_eq] + rfl + +/-- **The layout of a configuration code.** -/ +noncomputable def codeCodec (Q : Type) [Fintype Q] [Nonempty Q] (k nn S : ℕ) : + BitCodec (Code Q k nn S) := + (qCodec Q).prod ((finCodec (nn + S + 2)).prod + ((BitCodec.fn k (tapeCodec (S + 1))).prod (tapeCodec (S + 2)))) + +/-- The width of a configuration code: a constant for the state, a pointer into the input, and +the window itself. -/ +theorem codeCodec_width (Q : Type) [Fintype Q] [Nonempty Q] (k nn S : ℕ) : + (codeCodec Q k nn S).width = + bitWidth (Fintype.card Q) + (bitWidth (nn + S + 2) + + (k * ((S + 1) * 3) + (S + 2) * 3)) := rfl + +/-! ## The layout is logarithmically wide -/ + +theorem bitWidth_le {m w : ℕ} (h : m ≤ 2 ^ w) : bitWidth m ≤ w := + Nat.clog_le_of_le_pow h + +theorem bitWidth_le_self (m : ℕ) : bitWidth m ≤ m := + bitWidth_le (le_of_lt (Nat.lt_two_pow_self)) + +/-- **A configuration code is logarithmically wide.** Every field is either a constant, a pointer +into the input, or a piece of the window, so the whole layout fits in a logarithmic window of its +own — which is what lets a machine hold two of them at once and still be a log-space machine. -/ +theorem codeCodec_width_le (Q : Type) [Fintype Q] [Nonempty Q] (k C D : ℕ) : + ∃ C' D' : ℕ, ∀ nn : ℕ, + (codeCodec Q k nn (logWindow C D nn)).width ≤ logWindow C' D' nn := by + refine ⟨C + 1 + 3 * k * C + 3 * C, + bitWidth (Fintype.card Q) + 4 * D + 3 * k * D + 3 * k + 10, fun nn => ?_⟩ + set L := Nat.log 2 nn with hL + set S := logWindow C D nn with hS + have hSval : S = C * L + D := by rw [hS, logWindow, hL] + have hin : nn + S + 2 ≤ 2 ^ (L + S + 4) := by + have h1 : nn ≤ 2 ^ (L + 1) := le_of_lt (Nat.lt_pow_succ_log_self (by norm_num) nn) + have h2 : S + 2 ≤ 2 ^ (S + 2) := le_of_lt (Nat.lt_two_pow_self) + have h3 : (2 : ℕ) ^ (L + 1) ≤ 2 ^ (L + S + 3) := Nat.pow_le_pow_right (by norm_num) (by omega) + have h4 : (2 : ℕ) ^ (S + 2) ≤ 2 ^ (L + S + 3) := Nat.pow_le_pow_right (by norm_num) (by omega) + have h5 : (2 : ℕ) ^ (L + S + 3) + 2 ^ (L + S + 3) = 2 ^ (L + S + 4) := by ring + omega + have h2 : bitWidth (nn + S + 2) ≤ L + S + 4 := bitWidth_le hin + rw [codeCodec_width, logWindow] + calc bitWidth (Fintype.card Q) + (bitWidth (nn + S + 2) + (k * ((S + 1) * 3) + (S + 2) * 3)) + ≤ bitWidth (Fintype.card Q) + ((L + S + 4) + (k * ((S + 1) * 3) + (S + 2) * 3)) := by + gcongr + _ = (C + 1 + 3 * k * C + 3 * C) * L + + (bitWidth (Fintype.card Q) + 4 * D + 3 * k * D + 3 * k + 10) := by + rw [hSval]; ring + +/-! ## Combining logarithmic bounds + +The machine's space is the largest of its registers, and each register has its own logarithmic +bound; these say the family is closed under the operations the accounting needs. -/ + +theorem logWindow_mono {C C' D D' : ℕ} (hC : C ≤ C') (hD : D ≤ D') (n : ℕ) : + logWindow C D n ≤ logWindow C' D' n := by + rw [logWindow, logWindow] + exact Nat.add_le_add (Nat.mul_le_mul_right _ hC) hD + +theorem logWindow_add (C₁ D₁ C₂ D₂ n : ℕ) : + logWindow C₁ D₁ n + logWindow C₂ D₂ n = logWindow (C₁ + C₂) (D₁ + D₂) n := by + rw [logWindow, logWindow, logWindow] + ring + +theorem logWindow_mul (a C D n : ℕ) : a * logWindow C D n = logWindow (a * C) (a * D) n := by + rw [logWindow, logWindow] + ring + +theorem max_logWindow_le (C₁ D₁ C₂ D₂ n : ℕ) : + max (logWindow C₁ D₁ n) (logWindow C₂ D₂ n) ≤ logWindow (max C₁ C₂) (max D₁ D₂) n := + max_le (logWindow_mono (le_max_left _ _) (le_max_left _ _) n) + (logWindow_mono (le_max_right _ _) (le_max_right _ _) n) + +/-- **A polynomial counter is logarithmically wide.** The search counts rounds and codes up to +`A * (n + 1) ^ B`, so its counters fit in a logarithmic number of cells — which is what keeps the +whole machine inside a logarithmic window. -/ +theorem bitWidth_poly_le (A B : ℕ) : + ∀ n : ℕ, bitWidth (A * (n + 1) ^ B + 1) ≤ logWindow B (A + B + 1) n := by + intro n + set L := Nat.log 2 n with hL + have h1 : n + 1 ≤ 2 ^ (L + 1) := Nat.lt_pow_succ_log_self (by norm_num) n + have h2 : (n + 1) ^ B ≤ (2 ^ (L + 1)) ^ B := Nat.pow_le_pow_left h1 B + have h3 : ((2 : ℕ) ^ (L + 1)) ^ B = 2 ^ (B * (L + 1)) := by + rw [← pow_mul, Nat.mul_comm] + have h4 : A ≤ 2 ^ A := le_of_lt Nat.lt_two_pow_self + have h5 : A * (n + 1) ^ B ≤ 2 ^ A * 2 ^ (B * (L + 1)) := + Nat.mul_le_mul h4 (by rw [← h3]; exact h2) + have h6 : (2 : ℕ) ^ A * 2 ^ (B * (L + 1)) = 2 ^ (A + B * (L + 1)) := by rw [← pow_add] + have h7 : (1 : ℕ) ≤ 2 ^ (A + B * (L + 1)) := Nat.one_le_two_pow + have h8 : (2 : ℕ) ^ (A + B * (L + 1) + 1) = 2 ^ (A + B * (L + 1)) + 2 ^ (A + B * (L + 1)) := by + rw [pow_succ]; ring + have hle : A * (n + 1) ^ B + 1 ≤ 2 ^ (A + B * (L + 1)) + 1 := by omega + have hfin : A * (n + 1) ^ B + 1 ≤ 2 ^ (A + B * (L + 1) + 1) := by omega + have hb := bitWidth_le hfin + rw [logWindow, ← hL] + calc bitWidth (A * (n + 1) ^ B + 1) ≤ A + B * (L + 1) + 1 := hb + _ = B * L + (A + B + 1) := by ring + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/BlockScan.lean b/Complexitylib/Classes/Containments/Internal/BlockScan.lean new file mode 100644 index 00000000..b9a45061 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/BlockScan.lean @@ -0,0 +1,1431 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BitCodec +public import Complexitylib.Models.TuringMachine.Subroutines.Scan + +/-! +# Checking one tape window against its successor + +⚠️ Unreviewed by Bolton + +A configuration of the simulated machine is held in registers, one per field, and the machine +checks a *guessed* successor rather than computing one — on a nondeterministic machine that is +free, and checking is a scan. + +This file is the part of that check concerning one tape window. The window is a marked block: one +chunk per cell, each chunk three bits, the head marker first so that a rightward scan knows +whether the head is on a cell before it reads that cell's symbol. The checks are + +- the marker is on exactly one chunk, +- the symbols agree everywhere except under the marker, where the new window carries the written + symbol — except at cell zero, where a write is a no-op, +- the new marker sits where the direction says. + +Each is a fold over chunks, and `Complexity.Scanner.cellFold_chunk` turns it into the cell-level +fold a `Complexity.Scanner` runs. + +## Main definitions + +- `Complexity.markOf`, `Complexity.symOf` — the marker and symbol of a chunk +- `Complexity.markCount` — how many chunks carry the marker +- `Complexity.markStep`, `Complexity.agreeStep` — the marker-count and symbol folds +- `Complexity.stayStep`, `Complexity.rightStep`, `Complexity.leftStep` — one fold per direction +- `Complexity.dirStep`, `Complexity.movedMark` — the three folded into one, and where the marker + must land +- `Complexity.HoldsWindow`, `Complexity.HoldsBits` — a register whose cells spell out an encoded + window, or any bitstring +- `Complexity.inHeadStep`, `Complexity.inHeadEmit` — the input-head check, all three directions +- `Complexity.blockStep`, `Complexity.blockEmit` — the four checks run together +- `Complexity.SuccParams`, `Complexity.succParamsCodec` — what the check is handed, and its + layout + +## Main results + +- `Complexity.markStep_run` — the count fold reports whether there are none, one, or more +- `Complexity.agreeStep_run`, `Complexity.agreeOk_iff` — what the symbol check reports +- `Complexity.stayStep_run`, `Complexity.rightStep_run`, `Complexity.leftStep_state` — what each + displacement check reports +- `Complexity.dirEmit_run` — and what the combined displacement check reports, whichever way the + head moves +- `Complexity.blockEmit_run` — and what all four together report on one block +- `Complexity.markOf_of_holds`, `Complexity.symOf_of_holds` — what a scan reads off an encoded + window +- `Complexity.markCount_eq` — an encoded window carries exactly one marker +- `Complexity.eq_run_of_holds`, `Complexity.eq_run_state` — the comparison scan decides equality + of what two registers hold, and so decides the state field +- `Complexity.valUpTo_of_holds` — what a scan reads a register as, as a number +- `Complexity.tableSlice_eq`, `Complexity.ofTable_of_holdsBits`, `Complexity.ofTable_of_holds` — + and through a codec, as a value: whatever bits a register holds, and when they are an + encoding +- `Complexity.plusOne_of_holds`, `Complexity.plusOne_of_holds_fin` — the increment scan decides + the input-head field +- `Complexity.inHeadEmit_of_holds` — and the input-head check, whichever way the head moves +- `Complexity.moved_of_holds`, `Complexity.sym_of_holds` — the displacement and symbol + conditions, read as statements about the decoded windows +- `Complexity.blockEmit_holds` — and the whole check: the scan accepts exactly when the new + window is the old one stepped +- `Complexity.mem_codeSucc_iff` — a successor code is the code of one step +- `Complexity.succCode_state`, `Complexity.succCode_inputHead`, `Complexity.succCode_work_head`, + `Complexity.succCode_work_cells`, `Complexity.succCode_output_head`, + `Complexity.succCode_output_cells` — a successor's fields, one by one +- `Complexity.eq_succCode_iff` — and all of them at once: under the space bound a code is a + successor exactly when every field is what the transition makes it +- `Complexity.params_eq` — the guessed parameters are pinned by the checks themselves +- `Complexity.eq_succCode_of_checks` — so the conditions the checks establish say exactly that + one code is the successor of another +- `Complexity.mem_codeSucc_of_checks` — and hence that it is a successor at all +-/ + +@[expose] public section + +namespace Complexity + +variable {j : ℕ} + +/-- The head marker of chunk `p` of the block starting after cell `off`, on register `r`. -/ +def markOf (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (r : Fin (j + 1)) (p : ℕ) : Bool := + decide (cols (off + 3 * p + 1) r = Γ.one) + +/-- The two symbol bits of chunk `p`, on register `r`. -/ +def symOf (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (r : Fin (j + 1)) (p : ℕ) : Bool × Bool := + (decide (cols (off + 3 * p + 2) r = Γ.one), decide (cols (off + 3 * p + 3) r = Γ.one)) + +/-- How many of the first `m` chunks carry the marker. -/ +def markCount (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (r : Fin (j + 1)) : ℕ → ℕ + | 0 => 0 + | p + 1 => markCount cols off r p + (if markOf cols off r p then 1 else 0) + +/-- Count the markers, saturating at two: the first component says there is at least one, the +second that there are at least two. -/ +-- The last two columns are the chunk's symbol bits, which this check ignores; the arity is +-- fixed by `Complexity.Scanner.chunkRun`. +@[nolint unusedArguments] +def markStep (r : Fin (j + 1)) (x : Bool × Bool) + (c1 _c2 _c3 : Fin (j + 1) → Γ) : Bool × Bool := + if c1 r = Γ.one then (true, x.1 || x.2) else x + +/-- **What the marker count reports.** -/ +theorem markStep_run (r : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, Scanner.chunkRun (markStep r) cols off (false, false) m + = (decide (0 < markCount cols off r m), decide (1 < markCount cols off r m)) := by + intro m + induction m with + | zero => simp [Scanner.chunkRun, markCount] + | succ m ih => + rw [Scanner.chunkRun, ih, markStep, markCount] + by_cases h : cols (off + 3 * m + 1) r = Γ.one + · have hm : markOf cols off r m = true := by simp [markOf, h] + rw [if_pos h, hm] + refine Prod.ext ?_ ?_ + · simp + · show (decide (0 < markCount cols off r m) || decide (1 < markCount cols off r m)) + = decide (1 < markCount cols off r m + 1) + rcases Nat.eq_zero_or_pos (markCount cols off r m) with h0 | h0 + · simp [h0] + · have h1 : 0 < markCount cols off r m := h0 + simp [h1] + · have hm : markOf cols off r m = false := by simp [markOf, h] + rw [if_neg h, hm] + simp + +/-! ## The symbols -/ + +/-- What the new window should carry at chunk `p`. -/ +def wantSym (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a : Fin (j + 1)) (wrB : Bool × Bool) + (p : ℕ) : Bool × Bool := + if markOf cols off a p && decide (0 < p) then wrB else symOf cols off a p + +/-- The symbol conditions on the first `m` chunks. -/ +def agreeOk (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a b : Fin (j + 1)) + (symB wrB : Bool × Bool) : ℕ → Bool + | 0 => true + | p + 1 => + agreeOk cols off a b symB wrB p && + decide (symOf cols off b p = wantSym cols off a wrB p) && + (!markOf cols off a p || decide (symOf cols off a p = symB)) + +/-- The symbol-agreement fold. Its second component remembers that chunk zero has gone by, which +is what suppresses the write there. -/ +def agreeStep (a b : Fin (j + 1)) (symB wrB : Bool × Bool) (x : Bool × Bool) + (c1 c2 c3 : Fin (j + 1) → Γ) : Bool × Bool := + let mA := decide (c1 a = Γ.one) + let bA := (decide (c2 a = Γ.one), decide (c3 a = Γ.one)) + let bB := (decide (c2 b = Γ.one), decide (c3 b = Γ.one)) + (x.1 && decide (bB = (if mA && x.2 then wrB else bA)) && (!mA || decide (bA = symB)), true) + +/-- **What the symbol check reports.** -/ +theorem agreeStep_run (a b : Fin (j + 1)) (symB wrB : Bool × Bool) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, Scanner.chunkRun (agreeStep a b symB wrB) cols off (true, false) m + = (agreeOk cols off a b symB wrB m, decide (0 < m)) := by + intro m + induction m with + | zero => simp [Scanner.chunkRun, agreeOk] + | succ m ih => + rw [Scanner.chunkRun, ih, agreeStep, agreeOk] + refine Prod.ext ?_ (by simp) + show (agreeOk cols off a b symB wrB m && + decide ((decide (cols (off + 3 * m + 2) b = Γ.one), + decide (cols (off + 3 * m + 3) b = Γ.one)) + = (if decide (cols (off + 3 * m + 1) a = Γ.one) && decide (0 < m) then wrB + else (decide (cols (off + 3 * m + 2) a = Γ.one), + decide (cols (off + 3 * m + 3) a = Γ.one)))) && + (!decide (cols (off + 3 * m + 1) a = Γ.one) || + decide ((decide (cols (off + 3 * m + 2) a = Γ.one), + decide (cols (off + 3 * m + 3) a = Γ.one)) = symB))) = _ + rfl + +/-- The fold's verdict spelled out. -/ +theorem agreeOk_iff (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a b : Fin (j + 1)) + (symB wrB : Bool × Bool) : + ∀ m : ℕ, agreeOk cols off a b symB wrB m = true ↔ + ∀ p < m, symOf cols off b p = wantSym cols off a wrB p ∧ + (markOf cols off a p = true → symOf cols off a p = symB) := by + intro m + induction m with + | zero => simp [agreeOk] + | succ m ih => + rw [agreeOk] + simp only [Bool.and_eq_true, decide_eq_true_eq, Bool.or_eq_true, Bool.not_eq_true'] + rw [ih] + constructor + · rintro ⟨⟨hall, hsym⟩, hmark⟩ p hp + rcases Nat.lt_or_ge p m with hlt | hge + · exact hall p hlt + · have hpm : p = m := by omega + subst hpm + refine ⟨hsym, fun hm => ?_⟩ + rcases hmark with h | h + · rw [h] at hm; exact absurd hm (by simp) + · exact h + · intro hall + refine ⟨⟨fun p hp => hall p (by omega), (hall m (by omega)).1⟩, ?_⟩ + by_cases hm : markOf cols off a m = true + · exact Or.inr ((hall m (by omega)).2 hm) + · exact Or.inl (by simpa using hm) + +/-! ## Where the marker moves -/ + +/-- The head stays: the markers must agree. -/ +-- The last two columns are the chunk's symbol bits, which this check ignores; the arity is +-- fixed by `Complexity.Scanner.chunkRun`. +@[nolint unusedArguments] +def stayStep (a b : Fin (j + 1)) (x : Bool) (c1 _c2 _c3 : Fin (j + 1) → Γ) : Bool := + x && (decide (c1 a = Γ.one) == decide (c1 b = Γ.one)) + +theorem stayStep_run (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, Scanner.chunkRun (stayStep a b) cols off true m = true ↔ + ∀ p < m, markOf cols off a p = markOf cols off b p := by + intro m + induction m with + | zero => simp [Scanner.chunkRun] + | succ m ih => + rw [Scanner.chunkRun, stayStep, Bool.and_eq_true, ih] + constructor + · rintro ⟨hall, hlast⟩ p hp + rcases Nat.lt_or_ge p m with h | h + · exact hall p h + · have hpm : p = m := by omega + subst hpm + simpa [markOf] using hlast + · intro hall + exact ⟨fun p hp => hall p (by omega), by simpa [markOf] using hall m (by omega)⟩ + +/-- The marker the rightward rule expects at chunk `p`. -/ +def prevMark (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a : Fin (j + 1)) (p : ℕ) : Bool := + if p = 0 then false else markOf cols off a (p - 1) + +/-- The head moves right: the new marker is one chunk on. -/ +-- The last two columns are the chunk's symbol bits, which this check ignores; the arity is +-- fixed by `Complexity.Scanner.chunkRun`. +@[nolint unusedArguments] +def rightStep (a b : Fin (j + 1)) (x : Bool × Bool) (c1 _c2 _c3 : Fin (j + 1) → Γ) : + Bool × Bool := + (x.1 && (decide (c1 b = Γ.one) == x.2), decide (c1 a = Γ.one)) + +theorem rightStep_run (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, + (Scanner.chunkRun (rightStep a b) cols off (true, false) m).2 + = (if m = 0 then false else markOf cols off a (m - 1)) ∧ + ((Scanner.chunkRun (rightStep a b) cols off (true, false) m).1 = true ↔ + ∀ p < m, markOf cols off b p = prevMark cols off a p) := by + intro m + induction m with + | zero => simp [Scanner.chunkRun] + | succ m ih => + obtain ⟨ih2, ih1⟩ := ih + rw [Scanner.chunkRun, rightStep] + refine ⟨by simp [markOf], ?_⟩ + show (_ && (decide (cols (off + 3 * m + 1) b = Γ.one) == + (Scanner.chunkRun (rightStep a b) cols off (true, false) m).2)) = true ↔ _ + rw [Bool.and_eq_true, ih1, ih2] + constructor + · rintro ⟨hall, hlast⟩ p hp + rcases Nat.lt_or_ge p m with h | h + · exact hall p h + · have hpm : p = m := by omega + rw [hpm, markOf, prevMark] + exact beq_iff_eq.mp hlast + · intro hall + refine ⟨fun p hp => hall p (by omega), ?_⟩ + have hm := hall m (by omega) + rw [markOf, prevMark] at hm + exact beq_iff_eq.mpr hm + +/-- The head moves left: the new marker is one chunk back, except from chunk zero, where moving +left stays put. The fold carries the previous chunk's new marker, whether chunk zero has gone by, +and whether the old marker was on chunk zero. -/ +-- The last two columns are the chunk's symbol bits, which this check ignores; the arity is +-- fixed by `Complexity.Scanner.chunkRun`. +@[nolint unusedArguments] +def leftStep (a b : Fin (j + 1)) (x : Bool × Bool × Bool × Bool) + (c1 _c2 _c3 : Fin (j + 1) → Γ) : Bool × Bool × Bool × Bool := + let mA := decide (c1 a = Γ.one) + let mB := decide (c1 b = Γ.one) + if x.2.2.1 then + ((if x.2.2.2 then x.1 && !mB else x.1 && (x.2.1 == mA)), mB, true, x.2.2.2) + else ((if mA then mB else true), mB, true, mA) + +/-- **The state of the leftward-move check.** -/ +theorem leftStep_state (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, 0 < m → + (Scanner.chunkRun (leftStep a b) cols off (true, false, false, false) m).2.2.1 = true ∧ + (Scanner.chunkRun (leftStep a b) cols off (true, false, false, false) m).2.2.2 + = markOf cols off a 0 ∧ + (Scanner.chunkRun (leftStep a b) cols off (true, false, false, false) m).2.1 + = markOf cols off b (m - 1) ∧ + ((Scanner.chunkRun (leftStep a b) cols off (true, false, false, false) m).1 = true ↔ + (if markOf cols off a 0 then + markOf cols off b 0 = true ∧ ∀ p, 1 ≤ p → p < m → markOf cols off b p = false + else ∀ p, 1 ≤ p → p < m → markOf cols off b (p - 1) = markOf cols off a p)) := by + intro m + induction m with + | zero => intro h; exact absurd h (by omega) + | succ m ih => + intro _ + rcases Nat.eq_zero_or_pos m with hm0 | hm0 + · subst hm0 + rw [Scanner.chunkRun, Scanner.chunkRun, leftStep] + refine ⟨rfl, rfl, rfl, ?_⟩ + by_cases hA : markOf cols off a 0 = true + · have hA' : cols (off + 3 * 0 + 1) a = Γ.one := by simpa [markOf] using hA + rw [if_pos hA] + simp only [hA', if_true, decide_true] + constructor + · intro h + exact ⟨by simpa [markOf] using h, by omega⟩ + · rintro ⟨h, -⟩ + simpa [markOf] using h + · have hA' : ¬ (cols (off + 3 * 0 + 1) a = Γ.one) := by simpa [markOf] using hA + rw [if_neg hA] + simp only [hA', decide_false] + exact ⟨fun _ p h1 h2 => absurd h2 (by omega), fun _ => rfl⟩ + · obtain ⟨h1, h2, h3, h4⟩ := ih hm0 + rw [Scanner.chunkRun, leftStep] + simp only [h1, if_true, h2, h3] + refine ⟨by simp, by simp, by simp [markOf], ?_⟩ + by_cases hA : markOf cols off a 0 = true + · rw [if_pos hA] at h4 ⊢ + rw [if_pos hA] + rw [Bool.and_eq_true, h4] + constructor + · rintro ⟨⟨hb0, hall⟩, hlast⟩ + refine ⟨hb0, fun p hp1 hp2 => ?_⟩ + rcases Nat.lt_or_ge p m with h | h + · exact hall p hp1 h + · have hpm : p = m := by omega + rw [hpm, markOf] + simpa using hlast + · rintro ⟨hb0, hall⟩ + refine ⟨⟨hb0, fun p hp1 hp2 => hall p hp1 (by omega)⟩, ?_⟩ + have := hall m hm0 (by omega) + rw [markOf] at this + simp [this] + · rw [if_neg hA] at h4 ⊢ + rw [if_neg hA, Bool.and_eq_true, h4] + constructor + · rintro ⟨hall, hlast⟩ p hp1 hp2 + rcases Nat.lt_or_ge p m with h | h + · exact hall p hp1 h + · have hpm : p = m := by omega + rw [hpm, markOf, markOf] + exact beq_iff_eq.mp hlast + · intro hall + refine ⟨fun p hp1 hp2 => hall p hp1 (by omega), ?_⟩ + have hmm := hall m hm0 (by omega) + rw [markOf, markOf] at hmm + exact beq_iff_eq.mpr hmm + +/-! ## One displacement check, whichever way the head moves -/ + +/-- The displacement check for one block, in the direction the transition dictates. The three +directions need different amounts of memory; this gives them all the widest state. -/ +def dirStep (a b : Fin (j + 1)) (d : Dir3) (x : Bool × Bool × Bool × Bool) + (c1 c2 c3 : Fin (j + 1) → Γ) : Bool × Bool × Bool × Bool := + match d with + | .stay => (stayStep a b x.1 c1 c2 c3, x.2) + | .right => + let y := rightStep a b (x.1, x.2.1) c1 c2 c3 + (y.1, y.2, x.2.2) + | .left => leftStep a b x c1 c2 c3 + +/-- The verdict of the displacement check. -/ +def dirEmit (d : Dir3) (x : Bool × Bool × Bool × Bool) : Bool := + match d with + | .stay => x.1 + | .right => x.1 + | .left => if x.2.2.2 then x.1 else x.1 && !x.2.1 + +theorem dirStep_stay (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) + (y : Bool × Bool × Bool) : + ∀ m : ℕ, (Scanner.chunkRun (dirStep a b Dir3.stay) cols off (true, y) m).1 + = Scanner.chunkRun (stayStep a b) cols off true m := by + intro m + induction m with + | zero => rfl + | succ m ih => + rw [Scanner.chunkRun, Scanner.chunkRun, ← ih] + rfl + +theorem dirStep_right (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (z : Bool × Bool) : + ∀ m : ℕ, ((Scanner.chunkRun (dirStep a b Dir3.right) cols off (true, false, z) m).1, + (Scanner.chunkRun (dirStep a b Dir3.right) cols off (true, false, z) m).2.1) + = Scanner.chunkRun (rightStep a b) cols off (true, false) m := by + intro m + induction m with + | zero => rfl + | succ m ih => + rw [Scanner.chunkRun, Scanner.chunkRun, ← ih] + rfl + +theorem dirStep_left (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, Scanner.chunkRun (dirStep a b Dir3.left) cols off (true, false, false, false) m + = Scanner.chunkRun (leftStep a b) cols off (true, false, false, false) m := by + intro m + induction m with + | zero => rfl + | succ m ih => rw [Scanner.chunkRun, Scanner.chunkRun, ih]; rfl + +/-- Where the marker must sit in the new block, given the direction. -/ +def movedMark (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a : Fin (j + 1)) (d : Dir3) (p : ℕ) : + Bool := + match d with + | .stay => markOf cols off a p + | .right => prevMark cols off a p + | .left => if markOf cols off a 0 then decide (p = 0) else markOf cols off a (p + 1) + +/-- **What the displacement check reports.** -/ +theorem dirEmit_run (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (d : Dir3) + (m : ℕ) (hm : 0 < m) (hend : markOf cols off a m = false) : + dirEmit d (Scanner.chunkRun (dirStep a b d) cols off (true, false, false, false) m) = true ↔ + ∀ p < m, markOf cols off b p = movedMark cols off a d p := by + cases d with + | stay => + show (Scanner.chunkRun (dirStep a b Dir3.stay) cols off (true, false, false, false) m).1 + = true ↔ _ + rw [dirStep_stay a b cols off (false, false, false) m, stayStep_run] + exact ⟨fun h p hp => (h p hp).symm, fun h p hp => (h p hp).symm⟩ + | right => + show (Scanner.chunkRun (dirStep a b Dir3.right) cols off (true, false, false, false) m).1 + = true ↔ _ + have hproj := dirStep_right a b cols off (false, false) m + have h1 : (Scanner.chunkRun (dirStep a b Dir3.right) cols off (true, false, false, false) m).1 + = (Scanner.chunkRun (rightStep a b) cols off (true, false) m).1 := by + rw [← hproj] + rw [h1] + exact (rightStep_run a b cols off m).2 + | left => + set y := Scanner.chunkRun (dirStep a b Dir3.left) cols off (true, false, false, false) m + with hy + show (if y.2.2.2 then y.1 else y.1 && !y.2.1) = true ↔ _ + rw [hy] + rw [dirStep_left a b cols off m] + obtain ⟨-, h2, h3, h4⟩ := leftStep_state a b cols off m hm + rw [h2, h3] + by_cases hA : markOf cols off a 0 = true + · rw [if_pos hA, h4, if_pos hA] + simp only [movedMark, hA, if_true] + constructor + · rintro ⟨hb0, hall⟩ p hp + rcases Nat.eq_zero_or_pos p with h0 | h0 + · rw [h0, hb0]; simp + · rw [hall p h0 hp]; simp; omega + · intro hall + refine ⟨by simpa using hall 0 hm, fun p h1 h2 => ?_⟩ + have := hall p h2 + rw [this] + simp + omega + · rw [if_neg hA, Bool.and_eq_true, h4, if_neg hA] + have hA' : markOf cols off a 0 = false := by simpa using hA + simp only [movedMark, hA', Bool.not_eq_true', Bool.false_eq_true, if_false] + constructor + · rintro ⟨hall, hlast⟩ p hp + rcases Nat.lt_or_ge p (m - 1) with h | h + · have := hall (p + 1) (by omega) (by omega) + simpa using this + · have hpm : p = m - 1 := by omega + rw [hpm, hlast, show m - 1 + 1 = m by omega, hend] + · intro hall + refine ⟨fun p h1 h2 => ?_, ?_⟩ + · have := hall (p - 1) (by omega) + rw [this, show p - 1 + 1 = p by omega] + · have := hall (m - 1) (by omega) + rw [this, show m - 1 + 1 = m by omega, hend] + +/-! ## A register that holds an encoded window -/ + +/-- The cells of register `r`, from `off + 1` on, spell out the encoding of the window +`(hd, cl)`. -/ +def HoldsWindow {m : ℕ} [NeZero m] (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (r : Fin (j + 1)) + (hd : Fin m) (cl : Fin m → Γ) : Prop := + ∀ q, (hq : q < m * 3) → cols (off + q + 1) r + = Γ.ofBool (((tapeCodec m).enc (hd, cl))[q]'(by rw [(tapeCodec m).enc_length]; exact hq)) + +private theorem enc_getElem {m : ℕ} [NeZero m] (hd : Fin m) (cl : Fin m → Γ) (p : Fin m) + (i : ℕ) (hi : i < 3) (hb : p.val * 3 + i < ((tapeCodec m).enc (hd, cl)).length) : + ((tapeCodec m).enc (hd, cl))[p.val * 3 + i]'hb + = ([decide (p = hd), (gammaBits (cl p)).1, (gammaBits (cl p)).2])[i]'(by simpa using hi) := by + have hchunk := tapeCodec_enc_chunk hd cl p + have hlt : i < (((tapeCodec m).enc (hd, cl)).drop (p.val * 3)).length := by + rw [List.length_drop] + rw [(tapeCodec m).enc_length] at hb ⊢ + omega + have h1 : (((tapeCodec m).enc (hd, cl)).drop (p.val * 3))[i]'hlt + = ((tapeCodec m).enc (hd, cl))[p.val * 3 + i]'hb := by + rw [List.getElem_drop] + have h2 : ((((tapeCodec m).enc (hd, cl)).drop (p.val * 3)).take 3)[i]'(by + rw [List.length_take]; omega) + = (((tapeCodec m).enc (hd, cl)).drop (p.val * 3))[i]'hlt := by + rw [List.getElem_take] + rw [← h1, ← h2] + congr 1 + +/-- The marker a scan reads off an encoded window. -/ +theorem markOf_of_holds {m : ℕ} [NeZero m] {cols : ℕ → Fin (j + 1) → Γ} {off : ℕ} + {r : Fin (j + 1)} {hd : Fin m} {cl : Fin m → Γ} (h : HoldsWindow cols off r hd cl) + (p : Fin m) : markOf cols off r p.val = decide (p = hd) := by + have hb : p.val * 3 + 0 < m * 3 := by have := p.isLt; omega + have hc := h (p.val * 3 + 0) hb + rw [markOf, show off + 3 * p.val + 1 = off + (p.val * 3 + 0) + 1 by omega, hc, + enc_getElem hd cl p 0 (by omega)] + cases hdec : decide (p = hd) <;> simp [Γ.ofBool] + +/-- The symbol bits a scan reads off an encoded window. -/ +theorem symOf_of_holds {m : ℕ} [NeZero m] {cols : ℕ → Fin (j + 1) → Γ} {off : ℕ} + {r : Fin (j + 1)} {hd : Fin m} {cl : Fin m → Γ} (h : HoldsWindow cols off r hd cl) + (p : Fin m) : symOf cols off r p.val = gammaBits (cl p) := by + have hb1 : p.val * 3 + 1 < m * 3 := by have := p.isLt; omega + have hb2 : p.val * 3 + 2 < m * 3 := by have := p.isLt; omega + have hc1 := h (p.val * 3 + 1) hb1 + have hc2 := h (p.val * 3 + 2) hb2 + rw [symOf, show off + 3 * p.val + 2 = off + (p.val * 3 + 1) + 1 by omega, + show off + 3 * p.val + 3 = off + (p.val * 3 + 2) + 1 by omega, hc1, hc2, + enc_getElem hd cl p 1 (by omega), enc_getElem hd cl p 2 (by omega)] + refine Prod.ext ?_ ?_ <;> + [cases (gammaBits (cl p)).1; cases (gammaBits (cl p)).2] <;> + simp [Γ.ofBool] + +theorem gammaBits_injective : Function.Injective gammaBits := by + intro g g' h + cases g <;> cases g' <;> simp_all [gammaBits] + +/-- Counting the markers of a register that holds an encoded window. -/ +theorem markCount_eq (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a : Fin (j + 1)) (hd : ℕ) : + ∀ m : ℕ, (∀ p < m, markOf cols off a p = decide (p = hd)) → + markCount cols off a m = if hd < m then 1 else 0 := by + intro m + induction m with + | zero => intro _; simp [markCount] + | succ m ih => + intro h + rw [markCount, ih (fun p hp => h p (by omega)), h m (by omega)] + by_cases hlt : hd < m + · simp [hlt, show ¬ (m = hd) by omega, show hd < m + 1 by omega] + · by_cases heq : hd = m + · simp [heq] + · simp [hlt, show ¬ (m = hd) by omega, show ¬ (hd < m + 1) by omega] + +/-- Where the head lands. -/ +def movedIdx (d : Dir3) (h : ℕ) : ℕ := + match d with + | .stay => h + | .right => h + 1 + | .left => h - 1 + +/-- **What the displacement condition says about the decoded heads.** -/ +theorem moved_of_holds {m : ℕ} (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a b : Fin (j + 1)) + (hd hd' : ℕ) (hdm : hd < m) (hdm' : hd' < m) (d : Dir3) + (ha : ∀ p < m, markOf cols off a p = decide (p = hd)) + (hb : ∀ p < m, markOf cols off b p = decide (p = hd')) + (hend : markOf cols off a m = false) : + (∀ p < m, markOf cols off b p = movedMark cols off a d p) ↔ hd' = movedIdx d hd := by + have hmark : ∀ p, p ≤ m → markOf cols off a p = decide (p = hd) := by + intro p hp + rcases Nat.lt_or_ge p m with h | h + · exact ha p h + · have hpm : p = m := by omega + rw [hpm, hend, eq_comm, decide_eq_false_iff_not] + omega + cases d with + | stay => + simp only [movedMark, movedIdx] + constructor + · intro h + have := h hd' hdm' + rw [hb hd' hdm', ha hd' hdm'] at this + simpa using this.symm + · intro h p hp + rw [hb p hp, ha p hp, h] + | right => + simp only [movedMark, movedIdx, prevMark] + constructor + · intro h + have hh := h hd' hdm' + rw [hb hd' hdm'] at hh + simp only [decide_true] at hh + by_cases h0 : hd' = 0 + · rw [h0, if_pos rfl] at hh + exact absurd hh.symm (by simp) + · rw [if_neg h0, hmark (hd' - 1) (by omega)] at hh + have : hd' - 1 = hd := by simpa using hh.symm + omega + · intro h p hp + rw [hb p hp, h] + by_cases h0 : p = 0 + · rw [h0, if_pos rfl] + simp + · rw [if_neg h0, hmark (p - 1) (by omega)] + congr 1 + simp only [eq_iff_iff] + omega + | left => + simp only [movedMark, movedIdx] + rw [ha 0 (by omega)] + by_cases h0 : hd = 0 + · rw [h0] + simp only [decide_true, if_true] + constructor + · intro h + have hh := h hd' hdm' + rw [hb hd' hdm'] at hh + simpa using hh.symm + · intro h p hp + rw [hb p hp, h] + · rw [decide_eq_false (by omega : ¬ (0 = hd))] + constructor + · intro h + have hh := h hd' hdm' + rw [hb hd' hdm', hmark (hd' + 1) (by omega)] at hh + simp only [decide_true] at hh + have : hd' + 1 = hd := by simpa using hh.symm + omega + · intro h p hp + rw [hb p hp, hmark (p + 1) (by omega)] + congr 1 + simp only [eq_iff_iff] + omega + +/-- **What the symbol condition says about the decoded windows.** -/ +theorem sym_of_holds {m : ℕ} (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (a b : Fin (j + 1)) + (hd : Fin m) (cl cl' : Fin m → Γ) (sym wr : Γ) + (ha : ∀ p : Fin m, markOf cols off a p.val = decide (p = hd)) + (hsa : ∀ p : Fin m, symOf cols off a p.val = gammaBits (cl p)) + (hsb : ∀ p : Fin m, symOf cols off b p.val = gammaBits (cl' p)) : + (∀ p < m, symOf cols off b p = wantSym cols off a (gammaBits wr) p ∧ + (markOf cols off a p = true → symOf cols off a p = gammaBits sym)) ↔ + ((∀ p : Fin m, cl' p = if p = hd ∧ 0 < p.val then wr else cl p) ∧ cl hd = sym) := by + have key : ∀ p : Fin m, + (symOf cols off b p.val = wantSym cols off a (gammaBits wr) p.val ↔ + cl' p = if p = hd ∧ 0 < p.val then wr else cl p) := by + intro p + rw [wantSym, ha p, hsa p, hsb p] + have hiff : ((decide (p = hd) && decide (0 < p.val)) = true) ↔ (p = hd ∧ 0 < p.val) := by + simp only [Bool.and_eq_true, decide_eq_true_eq] + by_cases hc : p = hd ∧ 0 < p.val + · rw [if_pos hc, if_pos (hiff.mpr hc)] + exact ⟨fun h => gammaBits_injective h, fun h => by rw [h]⟩ + · rw [if_neg hc, if_neg (fun h => hc (hiff.mp h))] + exact ⟨fun h => gammaBits_injective h, fun h => by rw [h]⟩ + constructor + · intro h + refine ⟨fun p => (key p).mp (h p.val p.isLt).1, ?_⟩ + have hmark : markOf cols off a hd.val = true := by rw [ha hd]; simp + have := (h hd.val hd.isLt).2 hmark + rw [hsa hd] at this + exact gammaBits_injective this + · rintro ⟨h1, h2⟩ p hp + refine ⟨(key ⟨p, hp⟩).mpr (h1 ⟨p, hp⟩), fun hm => ?_⟩ + rw [ha ⟨p, hp⟩] at hm + have hpd : (⟨p, hp⟩ : Fin m) = hd := by simpa using hm + rw [hsa ⟨p, hp⟩, hpd, h2] + +/-! ## Registers that hold a bitstring -/ + +/-- The cells of register `r`, from `off + 1` on, spell out `bits`. -/ +def HoldsBits (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (r : Fin (j + 1)) + (bits : List Bool) : Prop := + ∀ q, (hq : q < bits.length) → cols (off + q + 1) r = Γ.ofBool (bits[q]'hq) + +theorem ofBool_injective : Function.Injective Γ.ofBool := by + intro b b' h + cases b <;> cases b' <;> simp_all [Γ.ofBool] + +/-- A register determines the bits it holds. -/ +theorem HoldsBits.inj {cols : ℕ → Fin (j + 1) → Γ} {off : ℕ} {r : Fin (j + 1)} + {b₁ b₂ : List Bool} (h₁ : HoldsBits cols off r b₁) (h₂ : HoldsBits cols off r b₂) + (hlen : b₁.length = b₂.length) : b₁ = b₂ := by + refine List.ext_getElem hlen ?_ + intro i hi₁ hi₂ + have hc₁ := h₁ i hi₁ + have hc₂ := h₂ i hi₂ + exact ofBool_injective (hc₁.symm.trans hc₂) + +/-- A list is a prefix of the enumeration of a stream that agrees with it. -/ +theorem isPrefix_ofFn {L : List Bool} {n : ℕ} (b : ℕ → Bool) (hlen : L.length ≤ n) + (hb : ∀ q, (hq : q < L.length) → b q = L[q]) : + L <+: List.ofFn (fun q : Fin n => b q.val) := by + have htake : (List.ofFn (fun q : Fin n => b q.val)).take L.length = L := by + refine List.ext_getElem (by simp; omega) ?_ + intro q h1 h2 + rw [List.getElem_take, List.getElem_ofFn] + exact hb q h2 + exact ⟨_, by rw [← htake]; exact List.take_append_drop _ _⟩ + +/-- Holding a list of bits means holding any prefix of it: a register guessed one bit wider than +a field still holds the field. -/ +theorem HoldsBits.of_isPrefix {cols : ℕ → Fin (j + 1) → Γ} {off : ℕ} {r : Fin (j + 1)} + {L L' : List Bool} (h : HoldsBits cols off r L) (hp : L' <+: L) : + HoldsBits cols off r L' := by + intro q hq + obtain ⟨s, rfl⟩ := hp + rw [h q (by rw [List.length_append]; omega), List.getElem_append_left hq] + +/-- Holding a list means holding what follows a prefix of it, read from after that prefix. A +register whose field sits after a block of padding is read this way: the scan that checks the +field starts where the padding ends. -/ +theorem HoldsBits.drop_prefix {cols : ℕ → Fin (j + 1) → Γ} {r : Fin (j + 1)} + {L M : List Bool} (h : HoldsBits cols 0 r (L ++ M)) : HoldsBits cols L.length r M := by + intro q hq + have hlt : L.length + q < (L ++ M).length := by rw [List.length_append]; omega + have := h (L.length + q) hlt + rw [Nat.zero_add] at this + have hidx : L.length + q - L.length = q := by omega + rw [this, List.getElem_append_right (by omega)] + simp only [hidx] + +/-- Reading a register from an offset, as a scan that starts there. -/ +theorem HoldsBits.shift {cols : ℕ → Fin (j + 1) → Γ} {off : ℕ} {r : Fin (j + 1)} + {L : List Bool} (h : HoldsBits cols off r L) : + HoldsBits (fun t => cols (off + t)) 0 r L := by + intro q hq + show cols (off + (0 + q + 1)) r = _ + rw [show off + (0 + q + 1) = off + q + 1 by omega] + exact h q hq + +/-- **The comparison scan decides equality of what two registers hold.** -/ +theorem eq_run_of_holds (cols : ℕ → Fin (j + 1) → Γ) (r r' : Fin (j + 1)) + (bits bits' : List Bool) (hlen : bits.length = bits'.length) + (h : HoldsBits cols 0 r bits) (h' : HoldsBits cols 0 r' bits') : + (Scanner.eq j r r').run cols bits.length = true ↔ bits = bits' := by + rw [Scanner.eq_run] + constructor + · intro hall + refine List.ext_getElem hlen ?_ + intro i h1 h2 + have hc := hall (i + 1) (by omega) (by omega) + rw [show (i + 1) = 0 + i + 1 by omega, h i h1, h' i h2] at hc + exact ofBool_injective hc + · rintro rfl q h1 h2 + obtain ⟨i, rfl⟩ : ∃ i, q = i + 1 := ⟨q - 1, by omega⟩ + rw [show (i + 1) = 0 + i + 1 by omega, h i (by omega), h' i (by omega)] + +/-- **The state check.** Two registers holding encoded states agree exactly when the states do. -/ +theorem eq_run_state {Q : Type} [Fintype Q] [Nonempty Q] (cols : ℕ → Fin (j + 1) → Γ) + (r r' : Fin (j + 1)) (q q' : Q) + (h : HoldsBits cols 0 r ((qCodec Q).enc q)) (h' : HoldsBits cols 0 r' ((qCodec Q).enc q')) : + (Scanner.eq j r r').run cols (qCodec Q).width = true ↔ q = q' := by + have hlen : ((qCodec Q).enc q).length = ((qCodec Q).enc q').length := by + rw [(qCodec Q).enc_length, (qCodec Q).enc_length] + rw [show (qCodec Q).width = ((qCodec Q).enc q).length from ((qCodec Q).enc_length q).symm, + eq_run_of_holds cols r r' _ _ hlen h h'] + exact ⟨fun hb => (qCodec Q).enc_injective hb, fun hq => by rw [hq]⟩ + +/-! ## Reading a register as a number + +`Complexity.Scanner.plusOne` speaks in `Complexity.Scanner.valUpTo`, the value of the bits a scan +has passed; `Complexity.finCodec` stores a number as `Complexity.bitsOfLenLE`, whose value is +`Complexity.binValLE`. Both are little-endian, so they agree. -/ + +theorem binValLE_concat (l : List Bool) (b : Bool) : + binValLE (l ++ [b]) = binValLE l + (if b then 2 ^ l.length else 0) := by + induction l with + | nil => cases b <;> simp [binValLE] + | cons c l ih => + have hp : (2 : ℕ) ^ (l.length + 1) = 2 * 2 ^ l.length := by rw [pow_succ]; ring + simp only [List.cons_append, binValLE, ih, List.length_cons, hp] + cases c <;> cases b <;> simp <;> omega + +/-- **What a scan reads a register as.** -/ +theorem valUpTo_of_holds (cols : ℕ → Fin (j + 1) → Γ) (r : Fin (j + 1)) (bits : List Bool) + (h : HoldsBits cols 0 r bits) : + ∀ p, p ≤ bits.length → + Scanner.valUpTo (Scanner.bitAt cols r) p = binValLE (bits.take p) := by + intro p + induction p with + | zero => intro _; simp [Scanner.valUpTo, binValLE] + | succ p ih => + intro hp + have hple : p < bits.length := by omega + rw [Scanner.valUpTo, ih (by omega)] + have hbit : Scanner.bitAt cols r (p + 1) = bits[p]'hple := by + rw [Scanner.bitAt, show p + 1 = 0 + p + 1 by omega, h p hple] + cases bits[p]'hple <;> simp [Γ.ofBool] + have hsplit : bits.take (p + 1) = bits.take p ++ [bits[p]'hple] := by + rw [List.take_add_one] + simp [List.getElem?_eq_getElem hple] + rw [hbit, hsplit, binValLE_concat, List.length_take, min_eq_left (by omega)] + +/-- **The increment check decides the input-head condition.** -/ +theorem plusOne_of_holds (cols : ℕ → Fin (j + 1) → Γ) (r r' : Fin (j + 1)) (w u v : ℕ) + (hu : u < 2 ^ w) (hv : v < 2 ^ w) + (h : HoldsBits cols 0 r (bitsOfLenLE w u)) (h' : HoldsBits cols 0 r' (bitsOfLenLE w v)) : + (Scanner.plusOne j r r').emit ((Scanner.plusOne j r r').run cols w) = true ↔ v = u + 1 := by + have hlen : (bitsOfLenLE w u).length = w := bitsOfLenLE_length w u + have hlen' : (bitsOfLenLE w v).length = w := bitsOfLenLE_length w v + rw [Scanner.plusOne_run, valUpTo_of_holds cols r _ h w (by omega), + valUpTo_of_holds cols r' _ h' w (by omega), + List.take_of_length_le (le_of_eq hlen), List.take_of_length_le (le_of_eq hlen'), + binValLE_bitsOfLenLE w u hu, binValLE_bitsOfLenLE w v hv] + +/-- The same, for registers holding a bounded index. -/ +theorem plusOne_of_holds_fin {m : ℕ} [NeZero m] (cols : ℕ → Fin (j + 1) → Γ) + (r r' : Fin (j + 1)) (u v : Fin m) + (h : HoldsBits cols 0 r ((finCodec m).enc u)) (h' : HoldsBits cols 0 r' ((finCodec m).enc v)) : + (Scanner.plusOne j r r').emit ((Scanner.plusOne j r r').run cols (bitWidth m)) = true ↔ + v.val = u.val + 1 := + plusOne_of_holds cols r r' (bitWidth m) u.val v.val + (lt_of_lt_of_le u.isLt (le_two_pow_bitWidth m)) + (lt_of_lt_of_le v.isLt (le_two_pow_bitWidth m)) h h' + +/-! ## Reading a value off a register with a scan -/ + +/-- The leading `c` bits a scan has read from one register. -/ +def tableSlice {s w : ℕ} (table : Fin s → Fin w → Bool) (t : Fin s) (c : ℕ) (hc : c ≤ w) : + Fin c → Bool := fun i => table t ⟨i.val, lt_of_lt_of_le i.isLt hc⟩ + +/-- **What a scan has in its table**: the bits the register holds. -/ +theorem tableSlice_eq (bits : List Bool) (c : ℕ) (hlen : bits.length = c) + (cols : ℕ → Fin (j + 1) → Γ) (off s w : ℕ) (regs : Fin s → Fin (j + 1)) (t : Fin s) + (hc : c ≤ w) (x₀ : Fin s → Fin w → Bool) + (h : HoldsBits (fun q => cols (off + q)) 0 (regs t) bits) (i : Fin c) : + tableSlice (Scanner.auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (Scanner.bitsStep s w regs) + (fun q => cols (off + q)) w).2 t c hc i + = bits[i.val]'(by rw [hlen]; exact i.isLt) := by + have hread := (Scanner.bitsStep_run s w regs (fun q => cols (off + q)) x₀ w le_rfl).2 t + ⟨i.val, lt_of_lt_of_le i.isLt hc⟩ (lt_of_lt_of_le i.isLt hc) + have hh := h i.val (by rw [hlen]; exact i.isLt) + simp only [Nat.zero_add] at hh + rw [tableSlice, hread, Scanner.bitAt] + simp only [hh] + cases bits[i.val]'(by rw [hlen]; exact i.isLt) <;> simp [Γ.ofBool] + +/-- **What a scan reads a register as, through a codec**, whatever bits it holds. -/ +theorem ofTable_of_holdsBits {α : Type} (codec : BitCodec α) (bits : List Bool) + (hlen : bits.length = codec.width) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (s w : ℕ) + (regs : Fin s → Fin (j + 1)) (t : Fin s) (hc : codec.width ≤ w) + (x₀ : Fin s → Fin w → Bool) + (h : HoldsBits (fun q => cols (off + q)) 0 (regs t) bits) : + codec.ofTable (tableSlice + (Scanner.auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (Scanner.bitsStep s w regs) + (fun q => cols (off + q)) w).2 t codec.width hc) = codec.dec bits := by + rw [BitCodec.ofTable] + congr 1 + refine List.ext_getElem (by simp [hlen]) ?_ + intro i h1 h2 + have hi : i < codec.width := by simpa using h1 + rw [List.getElem_ofFn] + exact tableSlice_eq bits codec.width hlen cols off s w regs t hc x₀ h ⟨i, hi⟩ + +/-- The same, when the register holds an encoding. -/ +theorem ofTable_of_holds {α : Type} (codec : BitCodec α) (val : α) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (s w : ℕ) (regs : Fin s → Fin (j + 1)) (t : Fin s) + (hc : codec.width ≤ w) (x₀ : Fin s → Fin w → Bool) + (h : HoldsBits (fun q => cols (off + q)) 0 (regs t) (codec.enc val)) : + codec.ofTable (tableSlice + (Scanner.auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (Scanner.bitsStep s w regs) + (fun q => cols (off + q)) w).2 t codec.width hc) = val := by + rw [ofTable_of_holdsBits codec (codec.enc val) (codec.enc_length val) cols off s w regs t hc + x₀ h, codec.dec_enc] + +/-- The same, for a scan that starts at the first cell. -/ +theorem ofTable_of_holds_zero {α : Type} (codec : BitCodec α) (val : α) + (cols : ℕ → Fin (j + 1) → Γ) (s w : ℕ) (regs : Fin s → Fin (j + 1)) (t : Fin s) + (hc : codec.width ≤ w) (x₀ : Fin s → Fin w → Bool) + (h : HoldsBits cols 0 (regs t) (codec.enc val)) : + codec.ofTable (tableSlice + (Scanner.auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (Scanner.bitsStep s w regs) cols w).2 + t codec.width hc) = val := by + have hshift : (fun q => cols (0 + q)) = cols := by + funext q + rw [Nat.zero_add] + have hgen := ofTable_of_holds codec val cols 0 s w regs t hc x₀ (by rw [hshift]; exact h) + rwa [hshift] at hgen + +/-! ## The input head, whichever way it moves -/ + +/-- The input-head check, in the direction the transition dictates. The three directions share a +common state: `stay` compares, `right` checks an increment, and `left` checks one with the +registers swapped, since `v = u - 1` with `u > 0` is `u = v + 1`. -/ +def inHeadStep (r r' : Fin (j + 1)) (d : Dir3) (x : Bool × Bool) (col : Fin (j + 1) → Γ) : + Bool × Bool := + match d with + | .stay => ((Scanner.eq j r r').stepR x.1 col, x.2) + | .right => (Scanner.plusOne j r r').stepR x col + | .left => (Scanner.plusOne j r' r).stepR x col + +/-- The verdict of the input-head check. -/ +def inHeadEmit (d : Dir3) (x : Bool × Bool) : Bool := + match d with + | .stay => x.1 + | .right => !x.1 && x.2 + | .left => !x.1 && x.2 + +theorem inHeadStep_right_eq (r r' : Fin (j + 1)) : + inHeadStep r r' Dir3.right = (Scanner.plusOne j r r').stepR := rfl + +theorem inHeadStep_left_eq (r r' : Fin (j + 1)) : + inHeadStep r r' Dir3.left = (Scanner.plusOne j r' r).stepR := rfl + +theorem inHeadStep_stay_fst (r r' : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) + (y : Bool) : + ∀ p : ℕ, (Scanner.cellFold (inHeadStep r r' Dir3.stay) cols off (true, y) p).1 + = Scanner.cellFold (Scanner.eq j r r').stepR cols off true p := by + intro p + induction p with + | zero => rfl + | succ p ih => + rw [Scanner.cellFold, Scanner.cellFold, ← ih] + rfl + +theorem bitsOfLenLE_inj {w u v : ℕ} (hu : u < 2 ^ w) (hv : v < 2 ^ w) + (h : bitsOfLenLE w u = bitsOfLenLE w v) : u = v := by + rw [← binValLE_bitsOfLenLE w u hu, ← binValLE_bitsOfLenLE w v hv, h] + +/-- **What the input-head check reports.** -/ +theorem inHeadEmit_of_holds (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (r r' : Fin (j + 1)) + (d : Dir3) (w u v : ℕ) (hu : u < 2 ^ w) (hv : v < 2 ^ w) + (h : HoldsBits (fun t => cols (off + t)) 0 r (bitsOfLenLE w u)) + (h' : HoldsBits (fun t => cols (off + t)) 0 r' (bitsOfLenLE w v)) + (hleft : d = Dir3.left → 0 < u) : + inHeadEmit d (Scanner.cellFold (inHeadStep r r' d) cols off (true, true) w) = true ↔ + v = movedIdx d u := by + have hlu : (bitsOfLenLE w u).length = w := bitsOfLenLE_length w u + have hlv : (bitsOfLenLE w v).length = w := bitsOfLenLE_length w v + cases d with + | stay => + have hcf : (Scanner.eq j r r').runR (fun t => cols (off + t)) w + = Scanner.cellFold (Scanner.eq j r r').stepR (fun t => cols (off + t)) 0 true w := + Scanner.runR_eq_cellFold (Scanner.eq j r r') _ w + have hrun : (Scanner.eq j r r').run (fun t => cols (off + t)) w + = (Scanner.eq j r r').runR (fun t => cols (off + t)) w := by + rw [Scanner.run, Scanner.eq_runL] + show (Scanner.cellFold (inHeadStep r r' Dir3.stay) cols off (true, true) w).1 = true ↔ _ + rw [inHeadStep_stay_fst, Scanner.cellFold_shift, ← hcf, ← hrun, + show w = (bitsOfLenLE w u).length from hlu.symm] + refine Iff.trans (eq_run_of_holds (fun t => cols (off + t)) r r' _ _ (by rw [hlu, hlv]) h h') + ?_ + refine ⟨fun hb => (bitsOfLenLE_inj hu hv hb).symm, fun hb => ?_⟩ + rw [show movedIdx Dir3.stay u = u from rfl] at hb + rw [hb] + | right => + have hcf : (Scanner.plusOne j r r').runR (fun t => cols (off + t)) w + = Scanner.cellFold (Scanner.plusOne j r r').stepR (fun t => cols (off + t)) 0 + (true, true) w := Scanner.runR_eq_cellFold (Scanner.plusOne j r r') _ w + have hrun : (Scanner.plusOne j r r').run (fun t => cols (off + t)) w + = (Scanner.plusOne j r r').runR (fun t => cols (off + t)) w := by + rw [Scanner.run] + exact Scanner.ofRight_runL (Bool × Bool) _ _ _ _ w _ + show (Scanner.plusOne j r r').emit + (Scanner.cellFold (inHeadStep r r' Dir3.right) cols off (true, true) w) = true ↔ _ + rw [inHeadStep_right_eq, Scanner.cellFold_shift, ← hcf, ← hrun, + plusOne_of_holds (fun t => cols (off + t)) r r' w u v hu hv h h'] + rfl + | left => + have hpos := hleft rfl + have hcf : (Scanner.plusOne j r' r).runR (fun t => cols (off + t)) w + = Scanner.cellFold (Scanner.plusOne j r' r).stepR (fun t => cols (off + t)) 0 + (true, true) w := Scanner.runR_eq_cellFold (Scanner.plusOne j r' r) _ w + have hrun : (Scanner.plusOne j r' r).run (fun t => cols (off + t)) w + = (Scanner.plusOne j r' r).runR (fun t => cols (off + t)) w := by + rw [Scanner.run] + exact Scanner.ofRight_runL (Bool × Bool) _ _ _ _ w _ + show (Scanner.plusOne j r' r).emit + (Scanner.cellFold (inHeadStep r r' Dir3.left) cols off (true, true) w) = true ↔ _ + rw [inHeadStep_left_eq, Scanner.cellFold_shift, ← hcf, ← hrun, + plusOne_of_holds (fun t => cols (off + t)) r' r w v u hv hu h' h] + show u = v + 1 ↔ v = movedIdx Dir3.left u + show u = v + 1 ↔ v = u - 1 + omega + +/-! ## The whole check on one block -/ + +/-- The four checks on one block, run together: the marker counts on each register, the symbols, +and the displacement. -/ +def blockStep (a b : Fin (j + 1)) (symB wrB : Bool × Bool) (d : Dir3) + (x : (Bool × Bool) × (Bool × Bool) × (Bool × Bool) × (Bool × Bool × Bool × Bool)) + (c1 c2 c3 : Fin (j + 1) → Γ) : + (Bool × Bool) × (Bool × Bool) × (Bool × Bool) × (Bool × Bool × Bool × Bool) := + (markStep a x.1 c1 c2 c3, markStep b x.2.1 c1 c2 c3, + agreeStep a b symB wrB x.2.2.1 c1 c2 c3, dirStep a b d x.2.2.2 c1 c2 c3) + +/-- Where the combined check starts. -/ +def blockStart : (Bool × Bool) × (Bool × Bool) × (Bool × Bool) × (Bool × Bool × Bool × Bool) := + ((false, false), (false, false), (true, false), (true, false, false, false)) + +/-- The combined verdict: one marker on each register, the symbols right, the head moved right. -/ +def blockEmit (d : Dir3) + (x : (Bool × Bool) × (Bool × Bool) × (Bool × Bool) × (Bool × Bool × Bool × Bool)) : Bool := + (x.1.1 && !x.1.2) && (x.2.1.1 && !x.2.1.2) && x.2.2.1.1 && dirEmit d x.2.2.2 + +theorem blockStep_run (a b : Fin (j + 1)) (symB wrB : Bool × Bool) (d : Dir3) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) : + ∀ m : ℕ, Scanner.chunkRun (blockStep a b symB wrB d) cols off blockStart m + = (Scanner.chunkRun (markStep a) cols off (false, false) m, + Scanner.chunkRun (markStep b) cols off (false, false) m, + Scanner.chunkRun (agreeStep a b symB wrB) cols off (true, false) m, + Scanner.chunkRun (dirStep a b d) cols off (true, false, false, false) m) := by + intro m + induction m with + | zero => rfl + | succ m ih => + rw [Scanner.chunkRun, ih, Scanner.chunkRun, Scanner.chunkRun, Scanner.chunkRun, + Scanner.chunkRun] + rfl + +/-- **What the whole block check reports.** -/ +theorem blockEmit_run (a b : Fin (j + 1)) (symB wrB : Bool × Bool) (d : Dir3) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (m : ℕ) (hm : 0 < m) + (hend : markOf cols off a m = false) : + blockEmit d (Scanner.chunkRun (blockStep a b symB wrB d) cols off blockStart m) = true ↔ + markCount cols off a m = 1 ∧ markCount cols off b m = 1 ∧ + (∀ p < m, symOf cols off b p = wantSym cols off a wrB p ∧ + (markOf cols off a p = true → symOf cols off a p = symB)) ∧ + (∀ p < m, markOf cols off b p = movedMark cols off a d p) := by + rw [blockEmit, blockStep_run] + simp only [markStep_run, agreeStep_run] + simp only [Bool.and_eq_true, Bool.not_eq_true', decide_eq_true_eq, decide_eq_false_iff_not, + agreeOk_iff, dirEmit_run a b cols off d m hm hend] + constructor + · rintro ⟨⟨⟨⟨h1, h2⟩, h3, h4⟩, h5⟩, h6⟩ + exact ⟨by omega, by omega, h5, h6⟩ + · rintro ⟨h1, h2, h3, h4⟩ + exact ⟨⟨⟨⟨by omega, by omega⟩, ⟨by omega, by omega⟩⟩, h3⟩, h4⟩ + +/-- **The block check, as a statement about decoded windows.** The scan accepts exactly when the +new window is the old one stepped: the symbol under the head is the one the transition was +computed from, the cells are unchanged except under the head, where the written symbol appears — +save at cell zero, where a write is a no-op — and the head has moved as the direction says. -/ +theorem blockEmit_holds {m : ℕ} [NeZero m] (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) + (a b : Fin (j + 1)) (hd hd' : Fin m) (cl cl' : Fin m → Γ) + (ha : HoldsWindow cols off a hd cl) (hb : HoldsWindow cols off b hd' cl') + (sym wr : Γ) (d : Dir3) (hm : 0 < m) (hend : markOf cols off a m = false) : + blockEmit d (Scanner.chunkRun (blockStep a b (gammaBits sym) (gammaBits wr) d) cols off + blockStart m) = true ↔ + (cl hd = sym ∧ (∀ p : Fin m, cl' p = if p = hd ∧ 0 < p.val then wr else cl p) ∧ + hd'.val = movedIdx d hd.val) := by + have hA : ∀ p < m, markOf cols off a p = decide (p = hd.val) := by + intro p hp + rw [markOf_of_holds ha ⟨p, hp⟩] + simp [Fin.ext_iff] + have hB : ∀ p < m, markOf cols off b p = decide (p = hd'.val) := by + intro p hp + rw [markOf_of_holds hb ⟨p, hp⟩] + simp [Fin.ext_iff] + rw [blockEmit_run a b (gammaBits sym) (gammaBits wr) d cols off m hm hend, + markCount_eq cols off a hd.val m hA, markCount_eq cols off b hd'.val m hB, + if_pos hd.isLt, if_pos hd'.isLt, + sym_of_holds cols off a b hd cl cl' sym wr (markOf_of_holds ha) (symOf_of_holds ha) + (symOf_of_holds hb), + moved_of_holds cols off a b hd.val hd'.val hd.isLt hd'.isLt d hA hB hend] + constructor + · rintro ⟨-, -, ⟨h1, h2⟩, h3⟩ + exact ⟨h2, h1, h3⟩ + · rintro ⟨h2, h1, h3⟩ + exact ⟨rfl, rfl, ⟨h1, h2⟩, h3⟩ + +/-! ## The parameters a successor check is handed + +The check does not guess what the simulated machine *does* — it guesses only what the machine +*sees*, and computes the transition itself. The state is verified against the old code's state +field, and each head symbol by the block check's own `symOk` conjunct, so nothing here is taken on +trust. -/ + +/-- What the simulated machine sees at one step: its choice bit, its state, and the symbol under +each of its heads. -/ +structure SuccParams (Q : Type) (k : ℕ) where + /-- The nondeterministic choice. -/ + beta : Bool + /-- The state. -/ + q : Q + /-- The symbol under the input head. -/ + inSym : Γ + /-- The symbol under each work head. -/ + wSym : Fin k → Γ + /-- The symbol under the output head. -/ + oSym : Γ + +/-- `SuccParams` is a plain record, so it lays out as a product. The symbol under the input head +comes **first**: it is the one field a machine checks against its own input tape rather than by +scanning, and `TM.inMatchTM` reads the two cells at the start of the register. -/ +def succParamsEquiv (Q : Type) (k : ℕ) : + SuccParams Q k ≃ Γ × Bool × Q × (Fin k → Γ) × Γ where + toFun p := (p.inSym, p.beta, p.q, p.wSym, p.oSym) + invFun t := ⟨t.2.1, t.2.2.1, t.1, t.2.2.2.1, t.2.2.2.2⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- The layout of a parameter block. -/ +noncomputable def succParamsCodec (Q : Type) [Fintype Q] [Nonempty Q] (k : ℕ) : + BitCodec (SuccParams Q k) := + BitCodec.equiv (succParamsEquiv Q k) + (BitCodec.gamma.prod (BitCodec.bool.prod ((qCodec Q).prod + ((BitCodec.fn k BitCodec.gamma).prod BitCodec.gamma)))) + +theorem succParamsCodec_width (Q : Type) [Fintype Q] [Nonempty Q] (k : ℕ) : + (succParamsCodec Q k).width = 2 + (1 + (bitWidth (Fintype.card Q) + (k * 2 + 2))) := rfl + +/-- What the simulated machine does, given what it sees. -/ +def succTrans {k : ℕ} (tm : NTM k) (p : SuccParams tm.Q k) : + tm.Q × (Fin k → Γw) × Γw × Dir3 × (Fin k → Dir3) × Dir3 := + tm.δ p.beta p.q p.inSym p.wSym p.oSym + +/-- The symbol the simulated machine writes on work tape `i`. -/ +def succWrite {k : ℕ} (tm : NTM k) (p : SuccParams tm.Q k) (i : Fin k) : Γ := + ((succTrans tm p).2.1 i).toΓ + +/-- Which way work head `i` moves. -/ +def succDir {k : ℕ} (tm : NTM k) (p : SuccParams tm.Q k) (i : Fin k) : Dir3 := + (succTrans tm p).2.2.2.2.1 i + +/-- The state the simulated machine moves to. -/ +def succState {k : ℕ} (tm : NTM k) (p : SuccParams tm.Q k) : tm.Q := + (succTrans tm p).1 + +/-! ## What the successor relation on codes says + +`Complexity.NTM.codeSucc` is `cfgCode ∘ stepCfg ∘ decodeCfg`. Decoding reads the transition's +inputs straight off the code's fields, so a successor is determined by the code and the choice +bit — which is what lets the check guess only what the machine sees. -/ + +section Codes + +variable {k : ℕ} (tm : NTM k) (x : List Bool) (S : ℕ) + +/-- The symbol under the simulated input head. -/ +def inSymOf (a : Code tm.Q k x.length S) : Γ := + (Tape.init (x.map Γ.ofBool)).cells a.2.1.val + +/-- The symbol under simulated work head `i`. -/ +def wSymOf (a : Code tm.Q k x.length S) (i : Fin k) : Γ := + (a.2.2.1 i).2 (a.2.2.1 i).1 + +/-- The symbol under the simulated output head. -/ +def oSymOf (a : Code tm.Q k x.length S) : Γ := + a.2.2.2.2 a.2.2.2.1 + +/-- What the simulated machine sees, read off a code. -/ +def paramsOf (a : Code tm.Q k x.length S) (β : Bool) : SuccParams tm.Q k := + { beta := β, q := a.1, inSym := inSymOf tm x S a, wSym := wSymOf tm x S a, + oSym := oSymOf tm x S a } + +@[simp] theorem decodeCfg_state (a : Code tm.Q k x.length S) : + (decodeCfg x S a).state = a.1 := rfl + +theorem decodeCfg_input_read (a : Code tm.Q k x.length S) : + (decodeCfg x S a).input.read = inSymOf tm x S a := rfl + +theorem decodeCfg_work_read (a : Code tm.Q k x.length S) (i : Fin k) : + ((decodeCfg x S a).work i).read = wSymOf tm x S a i := by + show (if h : (a.2.2.1 i).1.val < S + 1 then (a.2.2.1 i).2 ⟨_, h⟩ else Γ.blank) = _ + rw [dif_pos (a.2.2.1 i).1.isLt] + rfl + +theorem decodeCfg_output_read (a : Code tm.Q k x.length S) : + (decodeCfg x S a).output.read = oSymOf tm x S a := by + show (if h : a.2.2.2.1.val < S + 2 then a.2.2.2.2 ⟨_, h⟩ else Γ.blank) = _ + rw [dif_pos a.2.2.2.1.isLt] + rfl + +/-- The transition a code and a choice bit determine. -/ +theorem stepCfg_decodeCfg_delta (a : Code tm.Q k x.length S) (β : Bool) : + tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read + = succTrans tm (paramsOf tm x S a β) := by + rw [succTrans, decodeCfg_input_read, decodeCfg_output_read] + congr 1 + funext i + exact decodeCfg_work_read tm x S a i + +/-- The successor of a code under one choice. -/ +def succCode (β : Bool) (a : Code tm.Q k x.length S) : Code tm.Q k x.length S := + cfgCode x.length S (tm.stepCfg β (decodeCfg x S a)) + +/-- **Membership in `codeSucc`, unpacked.** -/ +theorem mem_codeSucc_iff (a a' : Code tm.Q k x.length S) : + a' ∈ NTM.codeSucc tm x S a ↔ a.1 ≠ tm.qhalt ∧ ∃ β : Bool, a' = succCode tm x S β a := by + rw [NTM.codeSucc, decodeCfg_state] + by_cases h : a.1 = tm.qhalt + · rw [if_pos h] + simp [h] + · rw [if_neg h] + simp only [Finset.mem_insert, Finset.mem_singleton, h, ne_eq, not_false_eq_true, true_and] + constructor + · rintro (h1 | h1) + · exact ⟨false, h1⟩ + · exact ⟨true, h1⟩ + · rintro ⟨β, hβ⟩ + cases β + · exact Or.inl hβ + · exact Or.inr hβ + +theorem head_move (t : Tape) (d : Dir3) : (t.move d).head = movedIdx d t.head := by + cases d <;> rfl + +/-- The state of a successor. -/ +theorem succCode_state (a : Code tm.Q k x.length S) (β : Bool) : + (succCode tm x S β a).1 = succState tm (paramsOf tm x S a β) := by + show ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).1) = _ + simp only [stepCfg_decodeCfg_delta] + rfl + +/-- The input head of a successor. -/ +theorem succCode_inputHead (a : Code tm.Q k x.length S) (β : Bool) : + (succCode tm x S β a).2.1.val + = min (movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.1 a.2.1.val) + (x.length + S + 1) := by + show min ((decodeCfg x S a).input.move + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) + (decodeCfg x S a).output.read).2.2.2.1)).head (x.length + S + 1) = _ + rw [head_move] + simp only [stepCfg_decodeCfg_delta] + rfl + +/-- The head of a successor's work window. -/ +theorem succCode_work_head (a : Code tm.Q k x.length S) (β : Bool) (i : Fin k) : + ((succCode tm x S β a).2.2.1 i).1.val + = min (movedIdx (succDir tm (paramsOf tm x S a β) i) (a.2.2.1 i).1.val) S := by + show min (((tm.stepCfg β (decodeCfg x S a)).work i).head) S = _ + congr 1 + show ((((decodeCfg x S a).work i).writeAndMove _ _).head) = _ + rw [show ((decodeCfg x S a).work i).writeAndMove + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).2.1 i) + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).2.2.2.2.1 i) + = (((decodeCfg x S a).work i).write _).move + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).2.2.2.2.1 i) + from rfl, head_move, Tape.write_head, stepCfg_decodeCfg_delta] + rfl + +/-- The cells of a successor's work window. -/ +theorem succCode_work_cells (a : Code tm.Q k x.length S) (β : Bool) (i : Fin k) + (p : Fin (S + 1)) : + ((succCode tm x S β a).2.2.1 i).2 p + = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm (paramsOf tm x S a β) i + else (a.2.2.1 i).2 p := by + have hcells : ((tm.stepCfg β (decodeCfg x S a)).work i).cells + = ((((decodeCfg x S a).work i).write + (((succTrans tm (paramsOf tm x S a β)).2.1 i) : Γ))).cells := by + show ((((decodeCfg x S a).work i).writeAndMove _ _)).cells = _ + rw [Tape.move_cells] + simp only [stepCfg_decodeCfg_delta] + show ((tm.stepCfg β (decodeCfg x S a)).work i).cells p.val = _ + rw [hcells, Tape.write] + have hbase : ∀ q : Fin (S + 1), ((decodeCfg x S a).work i).cells q.val = (a.2.2.1 i).2 q := by + intro q + show (if h : q.val < S + 1 then (a.2.2.1 i).2 ⟨q.val, h⟩ else Γ.blank) = _ + rw [dif_pos q.isLt] + have hhead : ((decodeCfg x S a).work i).head = (a.2.2.1 i).1.val := rfl + by_cases h0 : (a.2.2.1 i).1.val = 0 + · rw [if_pos (by rw [hhead, h0])] + rw [hbase p, if_neg] + rintro ⟨hp, hpos⟩ + rw [hp, h0] at hpos + omega + · rw [if_neg (by rw [hhead]; exact h0)] + show Function.update ((decodeCfg x S a).work i).cells + ((decodeCfg x S a).work i).head _ p.val = _ + rw [hhead] + by_cases hp : p.val = (a.2.2.1 i).1.val + · rw [hp, Function.update_self, if_pos ⟨Fin.ext hp, by omega⟩] + rfl + · rw [Function.update_of_ne hp, hbase p, if_neg] + rintro ⟨hq, -⟩ + exact hp (by rw [hq]) + +/-- The head of a successor's output window. -/ +theorem succCode_output_head (a : Code tm.Q k x.length S) (β : Bool) : + (succCode tm x S β a).2.2.2.1.val + = min (movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.2.2 a.2.2.2.1.val) (S + 1) := by + show min (((tm.stepCfg β (decodeCfg x S a)).output).head) (S + 1) = _ + congr 1 + show (((decodeCfg x S a).output.writeAndMove _ _).head) = _ + rw [show (decodeCfg x S a).output.writeAndMove + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).2.2.1) + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).2.2.2.2.2) + = ((decodeCfg x S a).output.write _).move + ((tm.δ β (decodeCfg x S a).state (decodeCfg x S a).input.read + (fun i => ((decodeCfg x S a).work i).read) (decodeCfg x S a).output.read).2.2.2.2.2) + from rfl, head_move, Tape.write_head] + simp only [stepCfg_decodeCfg_delta] + rfl + +/-- The cells of a successor's output window. -/ +theorem succCode_output_cells (a : Code tm.Q k x.length S) (β : Bool) (p : Fin (S + 2)) : + (succCode tm x S β a).2.2.2.2 p + = if p = a.2.2.2.1 ∧ 0 < p.val then + (((succTrans tm (paramsOf tm x S a β)).2.2.1 : Γw) : Γ) + else a.2.2.2.2 p := by + have hcells : ((tm.stepCfg β (decodeCfg x S a)).output).cells + = (((decodeCfg x S a).output.write + (((succTrans tm (paramsOf tm x S a β)).2.2.1 : Γw) : Γ))).cells := by + show (((decodeCfg x S a).output.writeAndMove _ _)).cells = _ + rw [Tape.move_cells] + simp only [stepCfg_decodeCfg_delta] + show ((tm.stepCfg β (decodeCfg x S a)).output).cells p.val = _ + rw [hcells, Tape.write] + have hbase : ∀ q : Fin (S + 2), (decodeCfg x S a).output.cells q.val = a.2.2.2.2 q := by + intro q + show (if h : q.val < S + 2 then a.2.2.2.2 ⟨q.val, h⟩ else Γ.blank) = _ + rw [dif_pos q.isLt] + have hhead : (decodeCfg x S a).output.head = a.2.2.2.1.val := rfl + by_cases h0 : a.2.2.2.1.val = 0 + · rw [if_pos (by rw [hhead, h0])] + rw [hbase p, if_neg] + rintro ⟨hp, hpos⟩ + rw [hp, h0] at hpos + omega + · rw [if_neg (by rw [hhead]; exact h0)] + show Function.update (decodeCfg x S a).output.cells + (decodeCfg x S a).output.head _ p.val = _ + rw [hhead] + by_cases hp : p.val = a.2.2.2.1.val + · rw [hp, Function.update_self, if_pos ⟨Fin.ext hp, by omega⟩] + · rw [Function.update_of_ne hp, hbase p, if_neg] + rintro ⟨hq, -⟩ + exact hp (by rw [hq]) + +/-- **A successor, field by field.** Under the space bound the clamps in `cfgCode` are inert, so a +code is the successor of another exactly when every field is what the transition makes it — which +is what the scans check. -/ +theorem eq_succCode_iff (a a' : Code tm.Q k x.length S) (β : Bool) + (hin : movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.1 a.2.1.val + ≤ x.length + S + 1) + (hw : ∀ i, movedIdx (succDir tm (paramsOf tm x S a β) i) (a.2.2.1 i).1.val ≤ S) + (ho : movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.2.2 a.2.2.2.1.val ≤ S + 1) : + a' = succCode tm x S β a ↔ + (a'.1 = succState tm (paramsOf tm x S a β) ∧ + a'.2.1.val = movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.1 a.2.1.val ∧ + (∀ i, (a'.2.2.1 i).1.val + = movedIdx (succDir tm (paramsOf tm x S a β) i) (a.2.2.1 i).1.val ∧ + ∀ p, (a'.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val + then succWrite tm (paramsOf tm x S a β) i else (a.2.2.1 i).2 p) ∧ + (a'.2.2.2.1.val + = movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, a'.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm (paramsOf tm x S a β)).2.2.1 : Γw) : Γ) + else a.2.2.2.2 p)) := by + constructor + · rintro rfl + refine ⟨succCode_state tm x S a β, ?_, fun i => ⟨?_, ?_⟩, ?_, ?_⟩ + · rw [succCode_inputHead, min_eq_left hin] + · rw [succCode_work_head, min_eq_left (hw i)] + · exact succCode_work_cells tm x S a β i + · rw [succCode_output_head, min_eq_left ho] + · exact succCode_output_cells tm x S a β + · rintro ⟨h1, h2, h3, h4, h5⟩ + refine Prod.ext (by rw [h1, succCode_state]) (Prod.ext ?_ (Prod.ext ?_ (Prod.ext ?_ ?_))) + · exact Fin.ext (by rw [h2, succCode_inputHead, min_eq_left hin]) + · funext i + refine Prod.ext ?_ ?_ + · exact Fin.ext (by rw [(h3 i).1, succCode_work_head, min_eq_left (hw i)]) + · funext p + rw [(h3 i).2 p, succCode_work_cells] + · exact Fin.ext (by rw [h4, succCode_output_head, min_eq_left ho]) + · funext p + rw [h5 p, succCode_output_cells] + +/-- **The guessed parameters are forced.** Each field of what the check was handed is pinned by +one of the checks: the state by the comparison against the old code's state field, each head +symbol by that block's own `symOk` conjunct, and the input symbol by the machine reading its own +input head. -/ +theorem params_eq (a : Code tm.Q k x.length S) (P : SuccParams tm.Q k) + (hq : a.1 = P.q) (hin : P.inSym = inSymOf tm x S a) + (hwk : ∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) + (hot : a.2.2.2.2 a.2.2.2.1 = P.oSym) : + P = paramsOf tm x S a P.beta := by + cases P with + | mk beta q inSym wSym oSym => + simp only [paramsOf, SuccParams.mk.injEq] + refine ⟨trivial, hq.symm, hin, ?_, hot.symm⟩ + funext i + exact (hwk i).symm + +/-- **A successor, from the conditions the checks establish.** -/ +theorem eq_succCode_of_checks (a b : Code tm.Q k x.length S) (P : SuccParams tm.Q k) + (β : Bool) (hbeta : P.beta = β) + (hq : a.1 = P.q) (hin : P.inSym = inSymOf tm x S a) + (hwsym : ∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) + (hosym : a.2.2.2.2 a.2.2.2.1 = P.oSym) + (hclampIn : movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ≤ x.length + S + 1) + (hclampW : ∀ i, movedIdx (succDir tm P i) (a.2.2.1 i).1.val ≤ S) + (hclampO : movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ≤ S + 1) : + b = succCode tm x S β a ↔ + (b.1 = succState tm P ∧ + b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ∧ + (∀ i, (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val ∧ + ∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) ∧ + (b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p)) := by + have hP : P = paramsOf tm x S a β := by + rw [params_eq tm x S a P hq hin hwsym hosym, hbeta] + subst hP + exact eq_succCode_iff tm x S a b β hclampIn hclampW hclampO + +/-- **Membership in `codeSucc`, from the conditions the checks establish.** -/ +theorem mem_codeSucc_of_checks (a b : Code tm.Q k x.length S) (P : SuccParams tm.Q k) + (hne : a.1 ≠ tm.qhalt) + (hq : a.1 = P.q) (hin : P.inSym = inSymOf tm x S a) + (hwsym : ∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) + (hosym : a.2.2.2.2 a.2.2.2.1 = P.oSym) + (hclampIn : movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ≤ x.length + S + 1) + (hclampW : ∀ i, movedIdx (succDir tm P i) (a.2.2.1 i).1.val ≤ S) + (hclampO : movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ≤ S + 1) + (hstate : b.1 = succState tm P) + (hhead : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val) + (hwork : ∀ i, (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val ∧ + ∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) + (hout : b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) : + b ∈ NTM.codeSucc tm x S a := by + refine (mem_codeSucc_iff tm x S a b).mpr ⟨hne, P.beta, ?_⟩ + exact (eq_succCode_of_checks tm x S a b P P.beta rfl hq hin hwsym hosym hclampIn hclampW + hclampO).mpr ⟨hstate, hhead, hwork, hout⟩ + +end Codes + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/CountingCert.lean b/Complexitylib/Classes/Containments/Internal/CountingCert.lean new file mode 100644 index 00000000..46bdef45 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/CountingCert.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.InductiveCounting +public import Complexitylib.Classes.Containments.Internal.CodeSearch + +/-! +# The certificate Immerman–Szelepcsényi's machine guesses + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.InductiveCounting` isolates the counting principle: +a subset of a round as large as the round *is* the round. This file turns that principle into the +shape a machine can verify, which is what stands between it and `NL ⊆ coNL`. + +Two things have to be checkable with only logarithmically many bits in hand. + +*Membership in a round* becomes a **walk**: a code lies in round `i` exactly when there is a +sequence of `i` steps from the start, each of which either stays put or moves to a successor +(`Complexity.NTM.mem_reachCodes_iff_walk`). A machine verifies such a walk holding only the +current code and the step index — never the walk itself. + +*Non-membership* becomes a **round list**: a list of distinct members of the round, at least as +long as the round (`Complexity.NTM.RoundList`). A machine never holds the list either; it guesses +the entries one at a time, checks each against a walk, counts them, and compares the count against +the round's size. `Complexity.NTM.not_mem_of_roundList` is what licenses the negative conclusion, +and `Complexity.NTM.roundList_exists` is what says an honest prover can always supply one. + +## Main definitions + +- `Complexity.NTM.RoundList` — a list that exhausts a round + +## Main results + +- `Complexity.NTM.mem_reachCodes_iff_walk` — membership in a round is a walk +- `Complexity.NTM.roundList_exists` — a round can always be listed +- `Complexity.NTM.not_mem_of_roundList`, `Complexity.NTM.mem_of_roundList` — what a list decides +- `Complexity.NTM.card_reachCodes_zero` — the count the machine starts from +- `Complexity.NL_complement_certificate_internal` — the complement as a certificate +-/ + +@[expose] public section + +namespace Complexity + +namespace NTM + +variable {k : ℕ} {tm : NTM k} {x : List Bool} {S : ℕ} + +/-! ## Membership is a walk -/ + +/-- **Membership in a round is a walk.** A code lies in round `i` exactly when some sequence of +`i` steps from the start reaches it, each step either staying put or moving to a successor. This +is the form a machine verifies: it holds only the current code and the step index. -/ +theorem mem_reachCodes_iff_walk (tm : NTM k) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q k x.length S) : + ∀ (i : ℕ) (a : Code tm.Q k x.length S), + a ∈ reachCodes tm x S a₀ i ↔ + ∃ f : ℕ → Code tm.Q k x.length S, f 0 = a₀ ∧ f i = a ∧ + ∀ j < i, f (j + 1) = f j ∨ f (j + 1) ∈ codeSucc tm x S (f j) := by + intro i + induction i with + | zero => + intro a + constructor + · intro h + rw [reachCodes, Finset.mem_singleton] at h + exact ⟨fun _ => a₀, rfl, h.symm, by omega⟩ + · rintro ⟨f, h0, hi, _⟩ + rw [reachCodes, Finset.mem_singleton, ← hi, ← h0] + | succ i ih => + intro a + rw [mem_reachCodes_succ_iff] + constructor + · intro h + obtain ⟨b, hb, hstep⟩ : ∃ b ∈ reachCodes tm x S a₀ i, + a = b ∨ a ∈ codeSucc tm x S b := by + rcases h with h | ⟨b, hb, hab⟩ + · exact ⟨a, h, Or.inl rfl⟩ + · exact ⟨b, hb, Or.inr hab⟩ + obtain ⟨f, h0, hfi, hf⟩ := (ih b).mp hb + refine ⟨fun j => if j ≤ i then f j else a, by simp [h0], by simp, fun j hj => ?_⟩ + dsimp only + rcases Nat.lt_or_ge j i with hlt | hge + · rw [if_pos (by omega), if_pos (by omega)] + exact hf j hlt + · have hji : j = i := by omega + subst hji + rw [if_neg (by omega), if_pos (by omega), hfi] + exact hstep + · rintro ⟨f, h0, hfi, hf⟩ + have hmem : f i ∈ reachCodes tm x S a₀ i := + (ih (f i)).mpr ⟨f, h0, rfl, fun j hj => hf j (by omega)⟩ + rcases hf i (by omega) with h | h + · exact Or.inl (by rw [← hfi, h]; exact hmem) + · exact Or.inr ⟨f i, hmem, by rw [← hfi]; exact h⟩ + +/-! ## A round as a list -/ + +/-- A list that exhausts a round: distinct members, at least as many as the round has. The +machine never holds such a list — it guesses the entries one at a time and counts them. -/ +def RoundList (tm : NTM k) (x : List Bool) (S : ℕ) (a₀ : Code tm.Q k x.length S) (i : ℕ) + (l : List (Code tm.Q k x.length S)) : Prop := + l.Nodup ∧ (∀ a ∈ l, a ∈ reachCodes tm x S a₀ i) ∧ + (reachCodes tm x S a₀ i).card ≤ l.length + +/-- **A round can always be listed**, so an honest prover can supply the certificate. -/ +theorem roundList_exists (tm : NTM k) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q k x.length S) (i : ℕ) : + ∃ l, RoundList tm x S a₀ i l := + ⟨(reachCodes tm x S a₀ i).toList, Finset.nodup_toList _, + fun _ ha => Finset.mem_toList.mp ha, le_of_eq (Finset.length_toList _).symm⟩ + +open Classical in +theorem roundList_toFinset {a₀ : Code tm.Q k x.length S} {i : ℕ} + {l : List (Code tm.Q k x.length S)} (h : RoundList tm x S a₀ i l) : + l.toFinset = reachCodes tm x S a₀ i := by + classical + refine eq_reachCodes_of_card_le (fun a ha => h.2.1 a (List.mem_toFinset.mp ha)) ?_ + rw [List.toFinset_card_of_nodup h.1] + exact h.2.2 + +open Classical in +/-- **What a round list decides, negatively.** A code absent from a list that exhausts the round +is not in the round — a negative fact, certified by a count. -/ +theorem not_mem_of_roundList {a₀ : Code tm.Q k x.length S} {i : ℕ} + {l : List (Code tm.Q k x.length S)} (h : RoundList tm x S a₀ i l) + {a : Code tm.Q k x.length S} (ha : a ∉ l) : a ∉ reachCodes tm x S a₀ i := by + classical + rw [← roundList_toFinset h, List.mem_toFinset] + exact ha + +open Classical in +/-- And positively: every member of the round appears. -/ +theorem mem_of_roundList {a₀ : Code tm.Q k x.length S} {i : ℕ} + {l : List (Code tm.Q k x.length S)} (h : RoundList tm x S a₀ i l) + {a : Code tm.Q k x.length S} (ha : a ∈ reachCodes tm x S a₀ i) : a ∈ l := by + classical + rw [← List.mem_toFinset, roundList_toFinset h] + exact ha + +/-- The list is exactly as long as the round, so the count a machine accumulates is the round's +size. -/ +theorem roundList_length {a₀ : Code tm.Q k x.length S} {i : ℕ} + {l : List (Code tm.Q k x.length S)} (h : RoundList tm x S a₀ i l) : + l.length = (reachCodes tm x S a₀ i).card := by + classical + rw [← List.toFinset_card_of_nodup h.1, roundList_toFinset h] + +/-! ## The count the machine starts from -/ + +@[simp] theorem card_reachCodes_zero (tm : NTM k) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q k x.length S) : (reachCodes tm x S a₀ 0).card = 1 := by + rw [reachCodes, Finset.card_singleton] + +end NTM + +/-! ## The complement, as a certificate -/ + +/-- **The complement of an `NL` language is a certificate a machine can guess.** An input is +*outside* the language exactly when the last round of the search can be listed with none of its +members accepting. Every quantity here is an explicit arithmetic function of the input length, +and the list is only ever consumed one entry at a time: the machine guesses an entry, verifies it +by a walk (`Complexity.NTM.mem_reachCodes_iff_walk`), checks it is not accepting, counts it, and +at the end compares the count against the round's size. That comparison is what makes the +absence of an accepting code a *positive* certificate. -/ +theorem NL_complement_certificate_internal {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (C D A B : ℕ), + ∀ x : List Bool, x ∉ L ↔ + ∃ l : List (Code tm.Q k x.length (logWindow C D x.length)), + NTM.RoundList tm x (logWindow C D x.length) + (cfgCode x.length (logWindow C D x.length) (tm.initCfg x)) + (A * (x.length + 1) ^ B) l ∧ + ∀ a ∈ l, ¬ ((decodeCfg x (logWindow C D x.length) a).state = tm.qhalt ∧ + (decodeCfg x (logWindow C D x.length) a).output.cells 1 = Γ.one) := by + obtain ⟨k, tm, C, D, A, B, hsearch⟩ := NL_finite_search hL + refine ⟨k, tm, C, D, A, B, fun x => ?_⟩ + constructor + · intro hx + obtain ⟨l, hl⟩ := NTM.roundList_exists tm x (logWindow C D x.length) + (cfgCode x.length (logWindow C D x.length) (tm.initCfg x)) (A * (x.length + 1) ^ B) + refine ⟨l, hl, fun a ha hacc => hx ?_⟩ + exact (hsearch x).mpr ⟨a, hl.2.1 a ha, hacc⟩ + · rintro ⟨l, hl, hno⟩ hx + obtain ⟨a, hmem, hacc⟩ := (hsearch x).mp hx + exact hno a (NTM.mem_of_roundList hl hmem) hacc + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPAssemble.lean b/Complexitylib/Classes/Containments/Internal/IPAssemble.lean new file mode 100644 index 00000000..0f814d4d --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPAssemble.lean @@ -0,0 +1,305 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.IPLeaf +public import Complexitylib.Classes.Containments.Internal.SpaceIterate + +/-! +# `IP ⊆ PSPACE`, assembled + +⚠️ Unreviewed by Bolton + +Everything is in place: `Complexity.IPM.ipStep` is the walk of the game tree written inside the +polynomial-time algebra, `Complexity.Protocol.walk_decides` says its orbit ends with the +membership bit, `Complexity.IPM.runBound_le` bounds how long that takes, and +`Complexity.IPM.encSst_length_le` bounds how much room it needs. This file hands them to +`Complexity.SpaceIter.mem_PSPACE_of_iterate`. + +## Main definitions + +- `Complexity.ipG` — the function the space-bounded iteration runs + +## Main results + +- `Complexity.ipG_iterate` — the packed orbit is the abstract one +- `Complexity.IP_subset_PSPACE_internal` — the containment +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-! ## The iterated function -/ + +/-- The function the space-bounded iteration runs: the running state is the first component and +the input the second, so the very first call — on `pair [] x` — builds the initial state. -/ +noncomputable def ipG (prot : Protocol) (vd : List Bool → List Bool) + (rp cp mp : Polynomial ℕ) (z : List Bool) : List Bool := + pair + (selectHead (emptyFlag (fstBlock z)) + (IPM.ipInit (polyRuler cp (sndBlock z)) (polyRuler rp (sndBlock z))) + (IPM.ipStep (polyRuler mp (sndBlock z)) (polyRuler cp (sndBlock z)) + (okFn prot.vmsg vd (polyRuler rp (sndBlock z)) (sndBlock z)) (fstBlock z))) + (sndBlock z) + +theorem ipG_nil (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Polynomial ℕ) + (x : List Bool) : + ipG prot vd rp cp mp (pair [] x) + = pair (IPM.ipInit (polyRuler cp x) (polyRuler rp x)) x := by + rw [ipG, fstBlock_pair, sndBlock_pair, emptyFlag_nil, selectHead_cons_true] + +theorem ipG_step (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Polynomial ℕ) + (st x : List Bool) (h : st ≠ []) : + ipG prot vd rp cp mp (pair st x) + = pair (IPM.ipStep (polyRuler mp x) (polyRuler cp x) + (okFn prot.vmsg vd (polyRuler rp x) x) st) x := by + obtain ⟨b, t, rfl⟩ : ∃ b t, st = b :: t := by + cases st with + | nil => exact absurd rfl h + | cons b t => exact ⟨b, t, rfl⟩ + rw [ipG, fstBlock_pair, sndBlock_pair, emptyFlag_cons, selectHead_cons_false] + +/-! ## The orbit -/ + +section + +open Classical + +variable (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Polynomial ℕ) + (hcp : ∀ n, prot.coins n = cp.eval n) (hmp : ∀ n, prot.msgLen n = mp.eval n) + (hvd : ∀ z, vd z = [decide (z ∈ prot.verdict)]) + +include hcp in +theorem cr_length (x : List Bool) : (polyRuler cp x).length = (prot.walkParams x).t := by + rw [polyRuler_length] + show cp.eval x.length = prot.coins x.length + rw [hcp] + +include hmp in +theorem mr_length (x : List Bool) : (polyRuler mp x).length = (prot.walkParams x).m := by + rw [polyRuler_length] + show mp.eval x.length = prot.msgLen x.length + rw [hmp] + +include hcp hmp hvd in +/-- **The packed orbit is the abstract one.** -/ +theorem ipG_iterate (x : List Bool) : + ∀ j : ℕ, (ipG prot vd rp cp mp)^[j + 1] (pair [] x) + = pair (IPM.encSst ((IPM.step (prot.walkParams x))^[j] + ⟨false, false, none, + [IPM.freshFrm (prot.walkParams x) [] (polyRuler rp x)]⟩)) x := by + have hokf := okFn_hokf prot vd hvd (polyRuler rp x) x ((polyRuler rp x).length + 1) le_rfl + intro j + induction j with + | zero => + rw [Function.iterate_one, ipG_nil, + IPM.ipInit_eq _ (prot.walkParams x) (cr_length prot cp hcp x), + Function.iterate_zero_apply] + | succ j ih => + rw [Function.iterate_succ_apply' (IPM.step (prot.walkParams x)) j, + Function.iterate_succ_apply', ih, ipG_step _ _ _ _ _ _ _ (IPM.encSst_ne_nil _), + IPM.ipStep_encSst (prot.walkParams x) _ _ (mr_length prot mp hmp x) + (cr_length prot cp hcp x) _ ((polyRuler rp x).length + 1) hokf _ + (IPM.iterate_encOk (prot.walkParams x) _ j _ + (IPM.encOk_start (prot.walkParams x) (polyRuler rp x)))] + +end + +/-! ## The run at a fixed input -/ + +open Classical in +/-- What a run of `T` steps at `x` achieves. -/ +noncomputable def IPRunSpec (prot : Protocol) (L : Language) (rp : Polynomial ℕ) + (x : List Bool) (T : ℕ) : Prop := + T ≤ IPM.runBound (prot.walkParams x) (prot.rounds x.length) ∧ + (∀ j ≤ T, ((IPM.step (prot.walkParams x))^[j] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] (polyRuler rp x)]⟩).done + = false) ∧ + ((IPM.step (prot.walkParams x))^[T + 1] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] (polyRuler rp x)]⟩).done + = true ∧ + ((((IPM.step (prot.walkParams x))^[T + 2] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] (polyRuler rp x)]⟩).done = true) + ↔ x ∈ L) + +section + +open Classical + +variable (prot : Protocol) {L : Language} (rp : Polynomial ℕ) + (hrp : ∀ n, prot.rounds n = rp.eval n) + (hcomp : ∀ y ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen y.length) ∧ + 2 / 3 ≤ eventProb (prot.acceptEvent S y)) + (hsound : ∀ y ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen y.length) → + eventProb (prot.acceptEvent S y) ≤ 1 / 3) + +include hrp hcomp hsound in +theorem ipRun_exists (x : List Bool) : ∃ T, IPRunSpec prot L rp x T := by + have hlvl : (polyRuler rp x).length = prot.rounds x.length := by + rw [polyRuler_length, hrp] + obtain ⟨T, hT, h1, h2, h3⟩ := + Protocol.walk_decides prot hcomp hsound x (polyRuler rp x) hlvl + exact ⟨T, hT, h1, h2, h3⟩ + +end + +/-- The number of steps the walk takes at `x`. -/ +noncomputable def ipT (prot : Protocol) (L : Language) (rp : Polynomial ℕ) + (hex : ∀ x : List Bool, ∃ T, IPRunSpec prot L rp x T) (x : List Bool) : ℕ := + Classical.choose (hex x) + +theorem ipT_spec (prot : Protocol) (L : Language) (rp : Polynomial ℕ) + (hex : ∀ x : List Bool, ∃ T, IPRunSpec prot L rp x T) (x : List Bool) : + IPRunSpec prot L rp x (ipT prot L rp hex x) := + Classical.choose_spec (hex x) + +/-! ## The containment -/ + +open Classical in +/-- **`IP ⊆ PSPACE`, for one protocol.** -/ +theorem ip_mem_PSPACE (prot : Protocol) {L : Language} (rp cp mp r w : Polynomial ℕ) + (hrp : ∀ n, prot.rounds n = rp.eval n) (hcp : ∀ n, prot.coins n = cp.eval n) + (hmp : ∀ n, prot.msgLen n = mp.eval n) + (hcomp : ∀ y ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen y.length) ∧ + 2 / 3 ≤ eventProb (prot.acceptEvent S y)) + (hsound : ∀ y ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen y.length) → + eventProb (prot.acceptEvent S y) ≤ 1 / 3) + (hr : ∀ n, 2 * (2 * (cp.eval n + 1) + (rp.eval n + 1) * + (2 * (2 * (rp.eval n + 1) + 2 * mp.eval n + 2 * (mp.eval n + cp.eval n) + + 4 * (cp.eval n + 1) + (rp.eval n + 1) * (8 * (mp.eval n + cp.eval n) + 4) + 10) + + 2) + 10) + 2 + n ≤ r.eval n) + (hw : ∀ n, cp.eval n + 2 + (2 * mp.eval n + 3) * rp.eval n ≤ w.eval n) : + L ∈ PSPACE := by + classical + obtain ⟨vd, hvdFP, hvd⟩ := exists_verdictFlag prot + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : (fun z : List Bool => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hcr : (fun z => polyRuler cp (sndBlock z)) ∈ FP := polyRulerFn_mem_FP cp hsnd + have hmr : (fun z => polyRuler mp (sndBlock z)) ∈ FP := polyRulerFn_mem_FP mp hsnd + have hrr : (fun z => polyRuler rp (sndBlock z)) ∈ FP := polyRulerFn_mem_FP rp hsnd + have hGfp : ipG prot vd rp cp mp ∈ FP := by + refine Cobham.pairFn_mem_FP (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hfst) + (IPM.ipInitFn_mem_FP hcr hrr) ?_) hsnd + exact IPM.ipStepFn_mem_FP hmr hcr hfst + (fun hu hv => okFnFn_mem_FP prot.vmsg_mem hvdFP hrr hsnd hu hv) + have hex := ipRun_exists prot rp hrp hcomp hsound + have horb := ipG_iterate prot vd rp cp mp hcp hmp hvd + have hN : ∀ x : List Bool, (fun y => ipT prot L rp hex y + 2) x = ipT prot L rp hex x + 2 := + fun _ => rfl + refine SpaceIter.mem_PSPACE_of_iterate hGfp r w (fun x => ipT prot L rp hex x + 2) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ + · -- lengths + intro x i _ + have hbase := hr x.length + have hM : IPM.msgW (prot.walkParams x) ≤ mp.eval x.length + cp.eval x.length := by + show max (prot.msgLen x.length) (prot.coins x.length) ≤ _ + rw [hmp, hcp] + omega + cases i with + | zero => + rw [Function.iterate_zero_apply, pair_length, List.length_nil] + omega + | succ j => + rw [horb x j, pair_length] + have hlen := IPM.encSst_length_le (prot.walkParams x) ((polyRuler rp x).length + 1) _ + (IPM.iterate_encOk (prot.walkParams x) _ j _ + (IPM.encOk_start (prot.walkParams x) (polyRuler rp x))) + (IPM.iterate_sizeOk (prot.walkParams x) j _ + (IPM.sizeOk_start (prot.walkParams x) (polyRuler rp x))) + have hbound := IPM.stateBound_le (prot.walkParams x) ((polyRuler rp x).length + 1) + (mp.eval x.length + cp.eval x.length) hM + have ht : (prot.walkParams x).t = cp.eval x.length := by + show prot.coins x.length = _ + rw [hcp] + have hm : (prot.walkParams x).m = mp.eval x.length := by + show prot.msgLen x.length = _ + rw [hmp] + rw [ht, hm, polyRuler_length] at hbound + rw [polyRuler_length] at hlen + omega + · intro x + rw [hN x] + omega + · -- the step count + intro x + rw [hN x] + obtain ⟨hT, _, _, _⟩ := ipT_spec prot L rp hex x + have hle := IPM.runBound_le (prot.walkParams x) (prot.rounds x.length) + have ht : (prot.walkParams x).t = cp.eval x.length := by + show prot.coins x.length = _ + rw [hcp] + have hm : (prot.walkParams x).m = mp.eval x.length := by + show prot.msgLen x.length = _ + rw [hmp] + rw [ht, hm, hrp] at hle + rw [hrp] at hT + have hmono : (2 : ℕ) ^ (cp.eval x.length + 2 + (2 * mp.eval x.length + 3) * rp.eval x.length) + ≤ 2 ^ w.eval x.length := Nat.pow_le_pow_right (by omega) (hw x.length) + omega + · -- the flag stays down + intro x i hi hlt + obtain ⟨_, hdown, _, _⟩ := ipT_spec prot L rp hex x + rw [hN x] at hlt + cases i with + | zero => omega + | succ j => + rw [horb x j, IPM.headD_pair_encSst] + exact hdown j (by omega) + · -- the flag goes up + intro x + obtain ⟨_, _, hup, _⟩ := ipT_spec prot L rp hex x + rw [hN x, show ipT prot L rp hex x + 2 = (ipT prot L rp hex x + 1) + 1 from rfl, + horb x (ipT prot L rp hex x + 1), IPM.headD_pair_encSst] + exact hup + · intro x + rw [hN x, horb x (ipT prot L rp hex x + 2)] + intro hc + have := congrArg List.length hc + rw [pair_length] at this + simp at this + · -- the answer + intro x + obtain ⟨_, _, _, hans⟩ := ipT_spec prot L rp hex x + rw [hN x, horb x (ipT prot L rp hex x + 2), IPM.headD_pair_encSst] + exact hans.symm + +/-- The polynomial bounding the length of the state the walk carries. -/ +noncomputable def ipStatePoly (rp cp mp : Polynomial ℕ) : Polynomial ℕ := + 2 * (2 * (cp + 1) + (rp + 1) * + (2 * (2 * (rp + 1) + 2 * mp + 2 * (mp + cp) + 4 * (cp + 1) + + (rp + 1) * (8 * (mp + cp) + 4) + 10) + 2) + 10) + 2 + Polynomial.X + +/-- The polynomial bounding the logarithm of the number of steps it takes. -/ +noncomputable def ipCountPoly (rp cp mp : Polynomial ℕ) : Polynomial ℕ := + cp + 2 + (2 * mp + 3) * rp + +theorem ipStatePoly_eval (rp cp mp : Polynomial ℕ) (n : ℕ) : + (ipStatePoly rp cp mp).eval n + = 2 * (2 * (cp.eval n + 1) + (rp.eval n + 1) * + (2 * (2 * (rp.eval n + 1) + 2 * mp.eval n + 2 * (mp.eval n + cp.eval n) + + 4 * (cp.eval n + 1) + (rp.eval n + 1) * (8 * (mp.eval n + cp.eval n) + 4) + 10) + + 2) + 10) + 2 + n := by + simp [ipStatePoly] + +theorem ipCountPoly_eval (rp cp mp : Polynomial ℕ) (n : ℕ) : + (ipCountPoly rp cp mp).eval n + = cp.eval n + 2 + (2 * mp.eval n + 3) * rp.eval n := by + simp [ipCountPoly] + +/-- **`IP ⊆ PSPACE`.** The optimal prover's acceptance count is the value of a polynomially deep +game tree, and a stack machine walks that tree in polynomial space. -/ +theorem IP_subset_PSPACE_internal : IP ⊆ PSPACE := by + intro L hL + obtain ⟨prot, rp, cp, mp, hrp, hcp, hmp, hcomp, hsound⟩ := hL + exact ip_mem_PSPACE prot rp cp mp (ipStatePoly rp cp mp) (ipCountPoly rp cp mp) + hrp hcp hmp hcomp hsound + (fun n => le_of_eq (ipStatePoly_eval rp cp mp n).symm) + (fun n => le_of_eq (ipCountPoly_eval rp cp mp n).symm) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPEnc.lean b/Complexitylib/Classes/Containments/Internal/IPEnc.lean new file mode 100644 index 00000000..3677ed32 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPEnc.lean @@ -0,0 +1,459 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.IPSem + +/-! +# The walk's state on a bitstring + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.IPSem` walks the game tree on an inductive state. +A machine has to hold that state on a tape, so this file writes it as a bitstring — a frame is +five blocks, the stack a right-nested chain of pairs — and records the invariant the encoding +needs: a returning value is a *count*, so it is never empty, which is what tells `some` from +`none`. + +## Main definitions + +- `Complexity.IPM.encFrm`, `Complexity.IPM.encStk`, `Complexity.IPM.encSst` — the encoding +- `Complexity.IPM.EncOk` — the invariant the encoding relies on + +## Main results + +- `Complexity.IPM.step_encOk` — the invariant is preserved +-/ + +@[expose] public section + +namespace Complexity + +namespace IPM + +open Cobham + +/-! ## The encoding -/ + +/-- A frame on the tape: five blocks. -/ +def encFrm (f : Frm) : List Bool := + pair f.lvl (pair f.v (pair f.a (pair f.sum (pair f.best f.body)))) + +/-- The stack on the tape: a right-nested chain of pairs, empty stack being the empty string. -/ +def encStk : List Frm → List Bool + | [] => [] + | f :: fs => pair (encFrm f) (encStk fs) + +@[simp] theorem encStk_nil : encStk [] = [] := rfl + +@[simp] theorem encStk_cons (f : Frm) (fs : List Frm) : + encStk (f :: fs) = pair (encFrm f) (encStk fs) := rfl + +/-- A returning value on the tape. A count is never empty, so the empty string means *nothing is +returning*. -/ +def encRet : Option (List Bool) → List Bool + | none => [] + | some w => w + +@[simp] theorem encRet_none : encRet none = [] := rfl + +@[simp] theorem encRet_some (w : List Bool) : encRet (some w) = w := rfl + +/-- The state on the tape. -/ +def encSst (s : Sst) : List Bool := + pair [s.done] (pair [s.ansBit] (pair (encRet s.ret) (encStk s.stk))) + +theorem encSst_ne_nil (s : Sst) : encSst s ≠ [] := by + intro h + have := congrArg List.length h + rw [encSst, pair_length] at this + simp at this + +theorem encSst_headD (s : Sst) : (encSst s).headD false = s.done := by + rw [encSst, pair_cons_eq] + rfl + +theorem headD_pair_encSst (s : Sst) (x : List Bool) : + (pair (encSst s) x).headD false = s.done := by + rw [encSst, pair_cons_eq, pair_cons_eq] + rfl + +/-! ## The invariant the encoding relies on -/ +/-- Every frame carries the body of the rounds below it. -/ +def BodyOk : List Frm → Prop + | [] => True + | f :: fs => f.body = encBodyR (roundsOf fs) ∧ BodyOk fs + +@[simp] theorem bodyOk_nil : BodyOk [] := trivial + +theorem bodyOk_cons {f : Frm} {fs : List Frm} (h : f.body = encBodyR (roundsOf fs)) + (h' : BodyOk fs) : BodyOk (f :: fs) := ⟨h, h'⟩ + +/-- The stack descends exactly one level per frame, so its depth is the level it started at. -/ +def StkDepth (D : ℕ) : List Frm → Prop + | [] => True + | f :: fs => fs.length + f.lvl.length + 1 = D ∧ StkDepth D fs + +theorem StkDepth.length_le {D : ℕ} : ∀ {stk : List Frm}, StkDepth D stk → stk.length ≤ D + | [], _ => by simp + | f :: fs, h => by + rw [List.length_cons] + have := h.1 + omega + + +/-- The encoding is faithful when nothing is returning while the stack is empty, and every count +on the state has the width a count is held in — so that a returning value is never empty. -/ +structure EncOk (P : Params) (D : ℕ) (s : Sst) : Prop where + /-- Nothing returns to an empty stack. -/ + stkOk : s.stk = [] → s.ret ≠ none + /-- A returning value is a count. -/ + retLen : ∀ w, s.ret = some w → w.length = P.t + 1 + /-- So are the accumulators on the stack. -/ + frmLen : ∀ f ∈ s.stk, f.sum.length = P.t + 1 ∧ f.best.length = P.t + 1 + /-- Every frame carries the body of the rounds below it. -/ + bodyOk : BodyOk s.stk + /-- The stack is no deeper than the level it started at. -/ + depthOk : StkDepth D s.stk + +theorem encRet_ne_nil {P : Params} {D : ℕ} {s : Sst} (h : EncOk P D s) {w : List Bool} + (hw : s.ret = some w) : w ≠ [] := by + intro hc + have := h.retLen w hw + rw [hc] at this + simp at this + +theorem zeroCount_length (P : Params) : (zeroCount P).length = P.t + 1 := by + rw [zeroCount, List.length_replicate] + +theorem freshFrm_len (P : Params) (body lvl : List Bool) : + (freshFrm P body lvl).sum.length = P.t + 1 ∧ (freshFrm P body lvl).best.length = P.t + 1 := + ⟨zeroCount_length P, zeroCount_length P⟩ + + +/-- **The invariant is preserved.** -/ +theorem step_encOk (P : Params) (D : ℕ) {s : Sst} (h : EncOk P D s) : + EncOk P D (step P s) := by + obtain ⟨d, a, r, stk⟩ := s + cases d + · cases stk with + | nil => + obtain ⟨b, rfl⟩ : ∃ b, r = some b := by + cases r with + | none => exact absurd rfl (h.stkOk rfl) + | some b => exact ⟨b, rfl⟩ + rw [step_of_empty] + exact { stkOk := fun _ => by simp + retLen := fun w hw => h.retLen w hw + frmLen := fun f hf => by simp at hf + bodyOk := trivial + depthOk := trivial } + | cons f fs => + have hfl := h.frmLen f (List.mem_cons_self) + have hrest : ∀ g ∈ fs, g.sum.length = P.t + 1 ∧ g.best.length = P.t + 1 := + fun g hg => h.frmLen g (List.mem_cons_of_mem _ hg) + cases r with + | none => + by_cases hl : f.lvl = [] + · by_cases hov : bumpOver f.a = true + · rw [step_leaf_last P a f fs hl hov] + refine { stkOk := fun _ => by simp + retLen := fun w hw => ?_ + frmLen := fun g hg => hrest g hg + bodyOk := h.bodyOk.2 + depthOk := h.depthOk.2 } + simp only [Option.some.injEq] at hw + rw [← hw] + by_cases hokb : P.ok (roundsOf fs) f.a + · rw [if_pos hokb, bumpBits_length] + exact hfl.1 + · rw [if_neg hokb] + exact hfl.1 + · rw [step_leaf_next P a f fs hl (by simpa using hov)] + refine { stkOk := fun hc => by simp at hc + retLen := fun w hw => by simp at hw + frmLen := fun g hg => ?_ + bodyOk := ⟨h.bodyOk.1, h.bodyOk.2⟩ + depthOk := ⟨h.depthOk.1, h.depthOk.2⟩ } + rcases List.mem_cons.mp hg with rfl | hg + · refine ⟨?_, hfl.2⟩ + show (if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum).length = P.t + 1 + by_cases hokb : P.ok (roundsOf fs) f.a + · rw [if_pos hokb, bumpBits_length] + exact hfl.1 + · rw [if_neg hokb] + exact hfl.1 + · exact hrest g hg + · rw [step_push P a f fs hl] + refine { stkOk := fun hc => by simp at hc + retLen := fun w hw => by simp at hw + frmLen := fun g hg => ?_ + bodyOk := ⟨?_, h.bodyOk⟩ + depthOk := ⟨?_, h.depthOk⟩ } + · rcases List.mem_cons.mp hg with rfl | hg + · exact freshFrm_len P _ _ + · exact h.frmLen g hg + · show f.body ++ encMsg f.v ++ encMsg f.a = encBodyR (roundsOf (f :: fs)) + rw [roundsOf_cons, encBodyR_append, h.bodyOk.1] + · have hpos : 1 ≤ f.lvl.length := by + cases hlv : f.lvl with + | nil => exact absurd hlv hl + | cons _ t => simp + have hd := h.depthOk.1 + show (f :: fs).length + (f.lvl.drop 1).length + 1 = D + rw [List.length_cons, List.length_drop] + omega + | some r => + have hrlen : r.length = P.t + 1 := h.retLen r rfl + have hmaxlen : (maxBits f.best r).length = P.t + 1 := by + rw [maxBits_length _ _ (by rw [hrlen, hfl.2]), hfl.2] + have haddlen : (addBits f.sum (maxBits f.best r)).length = P.t + 1 := by + rw [addBits_length _ _ (by rw [hmaxlen, hfl.1]), hfl.1] + by_cases ha : (nextStr f.a).length ≤ P.m + · rw [step_ret_more_a P a f fs r ha] + refine { stkOk := fun hc => by simp at hc + retLen := fun w hw => by simp at hw + frmLen := fun g hg => ?_ + bodyOk := ⟨h.bodyOk.1, h.bodyOk.2⟩ + depthOk := ⟨h.depthOk.1, h.depthOk.2⟩ } + rcases List.mem_cons.mp hg with rfl | hg + · exact ⟨hfl.1, hmaxlen⟩ + · exact hrest g hg + · by_cases hv : (nextStr f.v).length ≤ P.m + · rw [step_ret_more_v P a f fs r ha hv] + refine { stkOk := fun hc => by simp at hc + retLen := fun w hw => by simp at hw + frmLen := fun g hg => ?_ + bodyOk := ⟨h.bodyOk.1, h.bodyOk.2⟩ + depthOk := ⟨h.depthOk.1, h.depthOk.2⟩ } + rcases List.mem_cons.mp hg with rfl | hg + · exact ⟨haddlen, zeroCount_length P⟩ + · exact hrest g hg + · rw [step_ret_pop P a f fs r ha hv] + exact { stkOk := fun _ => by simp + retLen := fun w hw => by + simp only [Option.some.injEq] at hw + rw [← hw] + exact haddlen + frmLen := fun g hg => hrest g hg + bodyOk := h.bodyOk.2 + depthOk := h.depthOk.2 } + · rw [step_of_done] + exact { stkOk := h.stkOk + retLen := h.retLen + frmLen := h.frmLen + bodyOk := h.bodyOk + depthOk := h.depthOk } + +theorem iterate_encOk (P : Params) (D : ℕ) : + ∀ (j : ℕ) (s : Sst), EncOk P D s → EncOk P D ((step P)^[j] s) := by + intro j + induction j with + | zero => intro s h; exact h + | succ j ih => + intro s h + rw [Function.iterate_succ_apply] + exact ih _ (step_encOk P D h) + +theorem encOk_start (P : Params) (lvl : List Bool) : + EncOk P (lvl.length + 1) ⟨false, false, none, [freshFrm P [] lvl]⟩ := + { stkOk := fun hc => by simp at hc + retLen := fun w hw => by simp at hw + frmLen := fun f hf => by + rcases List.mem_cons.mp hf with rfl | hf + · exact freshFrm_len P [] lvl + · simp at hf + bodyOk := ⟨rfl, trivial⟩ + depthOk := ⟨by + show [].length + (freshFrm P [] lvl).lvl.length + 1 = lvl.length + 1 + simp [freshFrm], trivial⟩ } + +/-! ## How long an encoded state is -/ + +/-- The width a message counter can reach. -/ +def msgW (P : Params) : ℕ := max P.m P.t + +/-- Every frame's counters are within the widths the walk uses. -/ +def SizeOk (P : Params) : List Frm → Prop + | [] => True + | f :: fs => f.v.length ≤ P.m ∧ f.a.length ≤ msgW P ∧ SizeOk P fs + +theorem step_sizeOk (P : Params) {s : Sst} (h : SizeOk P s.stk) : SizeOk P (step P s).stk := by + obtain ⟨d, a, r, stk⟩ := s + cases d + · cases stk with + | nil => + cases r with + | none => exact trivial + | some b => exact trivial + | cons f fs => + obtain ⟨hv, ha, hrest⟩ := h + cases r with + | none => + by_cases hl : f.lvl = [] + · by_cases hov : bumpOver f.a = true + · rw [step_leaf_last P a f fs hl hov] + exact hrest + · rw [step_leaf_next P a f fs hl (by simpa using hov)] + refine ⟨hv, ?_, hrest⟩ + show (bumpBits f.a).length ≤ msgW P + rw [bumpBits_length] + exact ha + · rw [step_push P a f fs hl] + refine ⟨?_, ?_, hv, ha, hrest⟩ + · show ([] : List Bool).length ≤ P.m + simp + · show (if f.lvl.drop 1 = [] then zeroCoin P else []).length ≤ msgW P + split + · rw [zeroCoin, List.length_replicate] + exact le_max_right _ _ + · simp + | some r => + by_cases hA : (nextStr f.a).length ≤ P.m + · rw [step_ret_more_a P a f fs r hA] + exact ⟨hv, le_trans hA (le_max_left _ _), hrest⟩ + · by_cases hV : (nextStr f.v).length ≤ P.m + · rw [step_ret_more_v P a f fs r hA hV] + refine ⟨hV, ?_, hrest⟩ + show ([] : List Bool).length ≤ msgW P + simp + · rw [step_ret_pop P a f fs r hA hV] + exact hrest + · rw [step_of_done] + exact h + +theorem iterate_sizeOk (P : Params) : + ∀ (j : ℕ) (s : Sst), SizeOk P s.stk → SizeOk P ((step P)^[j] s).stk := by + intro j + induction j with + | zero => intro s h; exact h + | succ j ih => + intro s h + rw [Function.iterate_succ_apply] + exact ih _ (step_sizeOk P h) + +theorem sizeOk_start (P : Params) (lvl : List Bool) : + SizeOk P [freshFrm P [] lvl] := by + refine ⟨?_, ?_, trivial⟩ + · show ([] : List Bool).length ≤ P.m + simp + · show (if lvl = [] then zeroCoin P else []).length ≤ msgW P + split + · rw [zeroCoin, List.length_replicate] + exact le_max_right _ _ + · simp + +/-- **The transcript body a stack records is polynomially long.** -/ +theorem body_length_le (P : Params) : + ∀ fs : List Frm, SizeOk P fs → + (encBodyR (roundsOf fs)).length ≤ fs.length * (8 * msgW P + 4) := by + intro fs + induction fs with + | nil => intro _; simp + | cons f fs ih => + intro h + obtain ⟨hv, ha, hrest⟩ := h + have hv' : f.v.length ≤ msgW P := le_trans hv (le_max_left _ _) + have h1 := encMsg_length_le f.v + have h2 := encMsg_length_le f.a + have := ih hrest + have hexp : (fs.length + 1) * (8 * msgW P + 4) + = fs.length * (8 * msgW P + 4) + (8 * msgW P + 4) := by ring + rw [roundsOf_cons, encBodyR_append, List.length_append, List.length_append, + List.length_cons] + omega + +theorem encFrm_length_le (P : Params) (D B : ℕ) (f : Frm) (hl : f.lvl.length + 1 ≤ D) + (hv : f.v.length ≤ P.m) (ha : f.a.length ≤ msgW P) (hs : f.sum.length = P.t + 1) + (hb : f.best.length = P.t + 1) (hbody : f.body.length ≤ B) : + (encFrm f).length ≤ 2 * D + 2 * P.m + 2 * msgW P + 4 * (P.t + 1) + B + 10 := by + rw [encFrm, pair_length, pair_length, pair_length, pair_length, pair_length, hs, hb] + omega + +theorem encStk_length_le : ∀ (fs : List Frm) (B : ℕ), + (∀ g ∈ fs, (encFrm g).length ≤ B) → (encStk fs).length ≤ fs.length * (2 * B + 2) + | [], _, _ => by simp + | f :: fs, B, h => by + have hf : (encFrm f).length ≤ B := h f List.mem_cons_self + have hrest := encStk_length_le fs B fun g hg => h g (List.mem_cons_of_mem _ hg) + rw [encStk_cons, pair_length, List.length_cons, + show (fs.length + 1) * (2 * B + 2) = fs.length * (2 * B + 2) + (2 * B + 2) from by ring] + omega + +theorem StkDepth.mem_le {D : ℕ} : ∀ {stk : List Frm}, StkDepth D stk → + ∀ f ∈ stk, f.lvl.length + 1 ≤ D + | [], _ => by simp + | g :: gs, h => by + intro f hf + rcases List.mem_cons.mp hf with rfl | hf + · have := h.1 + omega + · exact StkDepth.mem_le h.2 f hf + +theorem SizeOk.mem {P : Params} : ∀ {stk : List Frm}, SizeOk P stk → + ∀ f ∈ stk, f.v.length ≤ P.m ∧ f.a.length ≤ msgW P + | [], _ => by simp + | g :: gs, h => by + intro f hf + rcases List.mem_cons.mp hf with rfl | hf + · exact ⟨h.1, h.2.1⟩ + · exact SizeOk.mem h.2.2 f hf + +theorem SizeOk.tail {P : Params} {g : Frm} {gs : List Frm} (h : SizeOk P (g :: gs)) : + SizeOk P gs := h.2.2 + +theorem body_bound_mem (P : Params) (D : ℕ) : ∀ stk : List Frm, BodyOk stk → SizeOk P stk → + StkDepth D stk → ∀ g ∈ stk, g.body.length ≤ D * (8 * msgW P + 4) + | [], _, _, _ => by simp + | f :: fs, hb, hs, hd => by + intro g hg + rcases List.mem_cons.mp hg with rfl | hg + · rw [hb.1] + refine le_trans (body_length_le P fs hs.tail) ?_ + have := hd.1 + exact Nat.mul_le_mul_right _ (by omega) + · exact body_bound_mem P D fs hb.2 hs.tail hd.2 g hg + +/-- The width the encoded state stays inside. -/ +def stateBound (P : Params) (D : ℕ) : ℕ := + 2 * (P.t + 1) + + D * (2 * (2 * D + 2 * P.m + 2 * msgW P + 4 * (P.t + 1) + + D * (8 * msgW P + 4) + 10) + 2) + 10 + +theorem stateBound_le (P : Params) (D M : ℕ) (hM : msgW P ≤ M) : + stateBound P D + ≤ 2 * (P.t + 1) + D * (2 * (2 * D + 2 * P.m + 2 * M + 4 * (P.t + 1) + + D * (8 * M + 4) + 10) + 2) + 10 := by + rw [stateBound] + gcongr + +/-- **An encoded state is polynomially long.** -/ +theorem encSst_length_le (P : Params) (D : ℕ) (s : Sst) (h : EncOk P D s) + (hsz : SizeOk P s.stk) : (encSst s).length ≤ stateBound P D := by + have hret : (encRet s.ret).length ≤ P.t + 1 := by + cases hr : s.ret with + | none => simp + | some w => + rw [encRet_some] + exact le_of_eq (h.retLen w hr) + have hframe : ∀ g ∈ s.stk, (encFrm g).length + ≤ 2 * D + 2 * P.m + 2 * msgW P + 4 * (P.t + 1) + D * (8 * msgW P + 4) + 10 := by + intro g hg + obtain ⟨hv, ha⟩ := SizeOk.mem hsz g hg + obtain ⟨hs, hb⟩ := h.frmLen g hg + exact encFrm_length_le P D _ g (StkDepth.mem_le h.depthOk g hg) hv ha hs hb + (body_bound_mem P D s.stk h.bodyOk hsz h.depthOk g hg) + have hstk := encStk_length_le s.stk _ hframe + have hdepth : s.stk.length ≤ D := StkDepth.length_le h.depthOk + have hmul := Nat.mul_le_mul_right + (2 * (2 * D + 2 * P.m + 2 * msgW P + 4 * (P.t + 1) + D * (8 * msgW P + 4) + 10) + 2) hdepth + have hnil : ([] : List Bool).length = 0 := rfl + rw [encSst, pair_length, pair_length, pair_length, stateBound] + simp only [List.length_cons] + omega + +end IPM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPGameTree.lean b/Complexitylib/Classes/Containments/Internal/IPGameTree.lean new file mode 100644 index 00000000..770c73e8 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPGameTree.lean @@ -0,0 +1,683 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.IPSubsetPSPACE +public import Complexitylib.Classes.Containments.Internal.WitnessEnum +public import Complexitylib.Classes.Containments.Internal.TranscriptEnc + +/-! +# The game tree of an interactive protocol + +⚠️ Unreviewed by Bolton + +The value of a protocol on an input is the acceptance probability against an *optimal* prover — +a maximum over strategies, which are functions on transcripts. This file replaces that maximum +by a finite recursion over the transcript tree, which is the object a polynomial-space machine +walks. + +The tree is indexed by the transcript so far. At a node the coins still in play are those +*consistent* with the recorded verifier messages (`Complexity.Protocol.consFinset`); a round +splits them by the verifier's next message and the prover picks, for each such message, the reply +maximizing the count below. Everything is counted rather than averaged: `Complexity.Protocol.gval` +is the number of coin strings that end up accepting, so the value is that count over `2 ^ coins`. + +## Main definitions + +- `Complexity.Protocol.runFrom` — the interaction continued from a partial transcript +- `Complexity.Protocol.consFinset` — the coins consistent with a transcript +- `Complexity.Protocol.sval` — the accepting count of a fixed strategy, as a tree recursion +- `Complexity.Protocol.gval` — the same with the prover playing optimally + +## Main results + +- `Complexity.Protocol.transcript_eq_runFrom` — the two ways of running agree +- `Complexity.Protocol.consFinset_append` — a round filters the coins by the verifier's message +- `Complexity.Protocol.view_eq` — the verifier's view, with the transcript encoding unfolded +- `Complexity.Protocol.gval_succ_strsLe` — the sum ranges over every short string +- `Complexity.Protocol.consistent_iff_replay` — consistency is a replay of the verifier +- `Complexity.Protocol.gvalR_zero`, `Complexity.Protocol.gvalR_succ` — the recursion a stack + machine walks +-/ + +@[expose] public section + +namespace Complexity + +namespace Protocol + +variable (prot : Protocol) (x : List Bool) + +/-- **The verifier's view, unfolded.** The transcript reaches the verifier through the +concatenation `Complexity.encBody`, so extending the transcript only ever appends to it. -/ +theorem view_eq (r : List Bool) (τ : Transcript) : + view x r τ = pair (pair x r) (false :: (encBody τ ++ [true])) := by + rw [view, protocolView, bitstringEncode_transcript] + +/-! ## Running from a partial transcript -/ + +/-- The interaction continued for `n` more rounds from the transcript `τ`. -/ +def runFrom (S : ProverStrategy) (r : List Bool) : ℕ → Transcript → Transcript + | 0, τ => τ + | n + 1, τ => + runFrom S r n (τ ++ [prot.vmsg (view x r τ), S (τ ++ [prot.vmsg (view x r τ)])]) + +@[simp] theorem runFrom_zero (S : ProverStrategy) (r : List Bool) (τ : Transcript) : + prot.runFrom x S r 0 τ = τ := rfl + +theorem runFrom_succ (S : ProverStrategy) (r : List Bool) (n : ℕ) (τ : Transcript) : + prot.runFrom x S r (n + 1) τ + = prot.runFrom x S r n + (τ ++ [prot.vmsg (view x r τ), S (τ ++ [prot.vmsg (view x r τ)])]) := rfl + +/-- The continuation appends its last round at the end, exactly as +`Complexity.Protocol.transcript` does. -/ +theorem runFrom_succ' (S : ProverStrategy) (r : List Bool) : + ∀ (n : ℕ) (τ : Transcript), + prot.runFrom x S r (n + 1) τ + = prot.runFrom x S r n τ + ++ [prot.vmsg (view x r (prot.runFrom x S r n τ)), + S (prot.runFrom x S r n τ ++ [prot.vmsg (view x r (prot.runFrom x S r n τ))])] + | 0, τ => rfl + | n + 1, τ => by + rw [runFrom_succ prot x S r (n + 1) τ, runFrom_succ' S r n, runFrom_succ prot x S r n τ] + +/-- **The two ways of running agree.** -/ +theorem transcript_eq_runFrom (S : ProverStrategy) (r : List Bool) : + ∀ n, prot.transcript S x r n = prot.runFrom x S r n [] + | 0 => rfl + | n + 1 => by + rw [transcript, runFrom_succ' prot x S r n [], transcript_eq_runFrom S r n] + +/-! ## The coins still in play -/ + +/-- A coin string is consistent with a transcript when every verifier message recorded in it is +the one the verifier would have sent. -/ +def Consistent (r : List Bool) (τ : Transcript) : Prop := + ∀ j, 2 * j < τ.length → τ[2 * j]! = prot.vmsg (view x r (τ.take (2 * j))) + +theorem consistent_nil (r : List Bool) : prot.Consistent x r [] := by + intro j hj + simp at hj + +/-- Extending a transcript by one round adds exactly one condition: the verifier's message. -/ +theorem consistent_append (r : List Bool) (τ : Transcript) (i : ℕ) (hτ : τ.length = 2 * i) + (v a : List Bool) : + prot.Consistent x r (τ ++ [v, a]) ↔ + prot.Consistent x r τ ∧ v = prot.vmsg (view x r τ) := by + have hlen : (τ ++ [v, a]).length = 2 * i + 2 := by + rw [List.length_append, hτ] + simp + constructor + · intro h + refine ⟨fun j hj => ?_, ?_⟩ + · have hj2 : 2 * j < τ.length := hj + have h1 : (τ ++ [v, a])[2 * j]! = τ[2 * j]! := by + rw [getElem!_pos _ _ (by omega), getElem!_pos _ _ (by omega), + List.getElem_append_left (by omega)] + have h2 : (τ ++ [v, a]).take (2 * j) = τ.take (2 * j) := + List.take_append_of_le_length (by omega) + have := h j (by omega) + rw [h1, h2] at this + exact this + · have := h i (by omega) + rw [getElem!_pos _ _ (by omega), List.getElem_append_right (by omega), + List.take_append_of_le_length (by omega), List.take_of_length_le (by omega)] at this + simpa [hτ] using this + · rintro ⟨h1, h2⟩ j hj + rw [hlen] at hj + rcases Nat.lt_or_ge (2 * j) τ.length with hlt | hge + · rw [getElem!_pos _ _ (by omega), List.getElem_append_left (by omega), + List.take_append_of_le_length (by omega), ← getElem!_pos _ _ (by omega)] + exact h1 j hlt + · have hji : j = i := by omega + subst hji + rw [getElem!_pos _ _ (by omega), List.getElem_append_right (by omega), + List.take_append_of_le_length (by omega), List.take_of_length_le (by omega)] + simpa [hτ] using h2 + +open Classical in +/-- The coins consistent with a transcript. -/ +noncomputable def consFinset (t : ℕ) (τ : Transcript) : Finset (Fin t → Bool) := + Finset.univ.filter fun r => prot.Consistent x (BitString.toList r) τ + +theorem consFinset_nil (t : ℕ) : prot.consFinset x t [] = Finset.univ := by + classical + rw [consFinset] + exact Finset.filter_true_of_mem fun r _ => prot.consistent_nil x _ + +open Classical in +/-- **A round filters the coins by the verifier's message.** The reply the prover chooses plays +no part: the coins in play below a node depend only on the verifier messages above it. -/ +theorem consFinset_append (t : ℕ) (τ : Transcript) (i : ℕ) (hτ : τ.length = 2 * i) + (v a : List Bool) : + prot.consFinset x t (τ ++ [v, a]) + = (prot.consFinset x t τ).filter + fun r => prot.vmsg (view x (BitString.toList r) τ) = v := by + classical + rw [consFinset, consFinset, Finset.filter_filter] + refine Finset.filter_congr fun r _ => ?_ + rw [prot.consistent_append x _ τ i hτ v a] + exact ⟨fun h => ⟨h.1, h.2.symm⟩, fun h => ⟨h.1, h.2.symm⟩⟩ + +/-! ## The tree recursion -/ + +open Classical in +/-- The verifier messages still possible at a node. -/ +noncomputable def vset (t : ℕ) (τ : Transcript) : Finset (List Bool) := + (prot.consFinset x t τ).image fun r => prot.vmsg (view x (BitString.toList r) τ) + +open Classical in +/-- The coins consistent with `τ` that accept when the prover plays `S` for the remaining `n` +rounds, as a recursion down the tree. -/ +noncomputable def sval (t : ℕ) (S : ProverStrategy) : ℕ → Transcript → ℕ + | 0, τ => ((prot.consFinset x t τ).filter fun r => + view x (BitString.toList r) τ ∈ prot.verdict).card + | n + 1, τ => ∑ v ∈ vset prot x t τ, sval t S n (τ ++ [v, S (τ ++ [v])]) + +open Classical in +/-- The same count with the prover playing optimally: at each node it picks, for every possible +verifier message, the reply maximizing the count below. -/ +noncomputable def gval (t m : ℕ) : ℕ → Transcript → ℕ + | 0, τ => ((prot.consFinset x t τ).filter fun r => + view x (BitString.toList r) τ ∈ prot.verdict).card + | n + 1, τ => + ∑ v ∈ vset prot x t τ, (strsLe m).sup fun a => gval t m n (τ ++ [v, a]) + +open Classical in +theorem sval_succ (t : ℕ) (S : ProverStrategy) (n : ℕ) (τ : Transcript) : + prot.sval x t S (n + 1) τ + = ∑ v ∈ prot.vset x t τ, prot.sval x t S n (τ ++ [v, S (τ ++ [v])]) := by + rw [sval] + +open Classical in +theorem gval_succ (t m n : ℕ) (τ : Transcript) : + prot.gval x t m (n + 1) τ + = ∑ v ∈ prot.vset x t τ, (strsLe m).sup fun a => prot.gval x t m n (τ ++ [v, a]) := by + rw [gval] + +open Classical in +/-- **What the recursion counts.** -/ +theorem sval_eq_card (t : ℕ) (S : ProverStrategy) : + ∀ (n i : ℕ) (τ : Transcript), τ.length = 2 * i → + prot.sval x t S n τ + = ((prot.consFinset x t τ).filter fun r => + view x (BitString.toList r) (prot.runFrom x S (BitString.toList r) n τ) + ∈ prot.verdict).card := by + classical + intro n + induction n with + | zero => intro i τ _; rfl + | succ n ih => + intro i τ hτ + rw [sval_succ] + have hfib := Finset.card_eq_sum_card_fiberwise + (f := fun r : Fin t → Bool => prot.vmsg (view x (BitString.toList r) τ)) + (s := (prot.consFinset x t τ).filter fun r => + view x (BitString.toList r) (prot.runFrom x S (BitString.toList r) (n + 1) τ) + ∈ prot.verdict) + (t := prot.vset x t τ) + (fun r hr => by + rw [vset] + exact Finset.mem_image_of_mem _ (Finset.mem_filter.mp hr).1) + rw [hfib] + refine Finset.sum_congr rfl fun v _ => ?_ + rw [ih (i + 1) (τ ++ [v, S (τ ++ [v])]) (by simp [hτ]; omega), + prot.consFinset_append x t τ i hτ v (S (τ ++ [v])), Finset.filter_filter, + Finset.filter_filter] + refine congrArg Finset.card (Finset.filter_congr fun r _ => ?_) + constructor + · rintro ⟨h1, h2⟩ + refine ⟨?_, h1⟩ + rw [runFrom_succ, h1] + exact h2 + · rintro ⟨h2, h1⟩ + have h1' : prot.vmsg (view x (BitString.toList r) τ) = v := h1 + refine ⟨h1', ?_⟩ + rw [runFrom_succ, h1'] at h2 + exact h2 + +open Classical in +/-- The count at the root is the acceptance probability's numerator. -/ +theorem sval_root (t : ℕ) (S : ProverStrategy) : + prot.sval x t S (prot.rounds x.length) [] + = (Finset.univ.filter fun r : Fin t → Bool => + prot.Accepts S x (BitString.toList r)).card := by + classical + rw [sval_eq_card prot x t S _ 0 [] rfl, consFinset_nil] + refine congrArg Finset.card (Finset.filter_congr fun r _ => ?_) + rw [Accepts, transcript_eq_runFrom] + +/-! ## The optimum is attained -/ + +open Classical in +/-- **A bounded strategy cannot beat the optimum.** -/ +theorem sval_le_gval (t m : ℕ) {S : ProverStrategy} (hS : S.Bounded m) : + ∀ (n : ℕ) (τ : Transcript), prot.sval x t S n τ ≤ prot.gval x t m n τ := by + intro n + induction n with + | zero => intro τ; exact le_rfl + | succ n ih => + intro τ + rw [sval_succ, gval_succ] + refine Finset.sum_le_sum fun v _ => ?_ + exact le_trans (ih _) + (Finset.le_sup (f := fun a => prot.gval x t m n (τ ++ [v, a])) + (mem_strsLe.mpr (hS (τ ++ [v])))) + +open Classical in +/-- A reply attaining the maximum at a node whose depth says `R` rounds are planned. -/ +noncomputable def optReply (t m R : ℕ) (σ : Transcript) : List Bool := + Classical.choose (Finset.exists_mem_eq_sup (strsLe m) (strsLe_nonempty m) + (fun a => prot.gval x t m (R - σ.length / 2 - 1) (σ ++ [a]))) + +open Classical in +theorem optReply_mem (t m R : ℕ) (σ : Transcript) : prot.optReply x t m R σ ∈ strsLe m := + (Classical.choose_spec (Finset.exists_mem_eq_sup (strsLe m) (strsLe_nonempty m) + (fun a => prot.gval x t m (R - σ.length / 2 - 1) (σ ++ [a])))).1 + +open Classical in +theorem optReply_sup (t m R : ℕ) (σ : Transcript) : + ((strsLe m).sup fun a => prot.gval x t m (R - σ.length / 2 - 1) (σ ++ [a])) + = prot.gval x t m (R - σ.length / 2 - 1) (σ ++ [prot.optReply x t m R σ]) := + (Classical.choose_spec (Finset.exists_mem_eq_sup (strsLe m) (strsLe_nonempty m) + (fun a => prot.gval x t m (R - σ.length / 2 - 1) (σ ++ [a])))).2 + +/-- The strategy that always plays a maximizing reply. -/ +noncomputable def optStrategy (t m R : ℕ) : ProverStrategy := prot.optReply x t m R + +theorem optStrategy_bounded (t m R : ℕ) : (prot.optStrategy x t m R).Bounded m := fun σ => + mem_strsLe.mp (prot.optReply_mem x t m R σ) + +open Classical in +/-- **The optimum is attained.** -/ +theorem sval_optStrategy (t m R : ℕ) : + ∀ (n i : ℕ) (τ : Transcript), n + i = R → τ.length = 2 * i → + prot.sval x t (prot.optStrategy x t m R) n τ = prot.gval x t m n τ := by + intro n + induction n with + | zero => intro i τ _ _; rfl + | succ n ih => + intro i τ hni hτ + rw [sval_succ, gval_succ] + refine Finset.sum_congr rfl fun v _ => ?_ + have hσ : (τ ++ [v]).length / 2 = i := by + rw [List.length_append, hτ] + simp + omega + have hidx : R - (τ ++ [v]).length / 2 - 1 = n := by + rw [hσ] + omega + have hopt : prot.optStrategy x t m R (τ ++ [v]) = prot.optReply x t m R (τ ++ [v]) := rfl + rw [ih (i + 1) (τ ++ [v, prot.optStrategy x t m R (τ ++ [v])]) (by omega) + (by simp [hτ]; omega), hopt, ← hidx] + have hsup := optReply_sup prot x t m R (τ ++ [v]) + simp only [List.append_assoc, List.cons_append, List.nil_append] at hsup + exact hsup.symm + +/-! ## The value decides the language -/ + +open Classical in +theorem acceptEvent_eq_filter (S : ProverStrategy) : + prot.acceptEvent S x + = Finset.univ.filter fun r : Fin (prot.coins x.length) → Bool => + prot.Accepts S x (BitString.toList r) := by + classical + rw [acceptEvent] + +open Classical in +/-- The optimum is the largest accepting count a bounded strategy achieves. -/ +theorem card_acceptEvent_le_gval (S : ProverStrategy) (hS : S.Bounded (prot.msgLen x.length)) : + (prot.acceptEvent S x).card + ≤ prot.gval x (prot.coins x.length) (prot.msgLen x.length) (prot.rounds x.length) [] := by + classical + rw [acceptEvent_eq_filter, ← sval_root] + exact sval_le_gval prot x _ _ hS _ [] + +open Classical in +/-- And it is achieved: the maximizing strategy is bounded and attains it. -/ +theorem gval_eq_card_acceptEvent : + prot.gval x (prot.coins x.length) (prot.msgLen x.length) (prot.rounds x.length) [] + = (prot.acceptEvent + (prot.optStrategy x (prot.coins x.length) (prot.msgLen x.length) + (prot.rounds x.length)) x).card := by + classical + rw [acceptEvent_eq_filter, ← sval_root] + exact (sval_optStrategy prot x _ _ _ _ 0 [] (by omega) rfl).symm + +open Classical in +/-- **The tree value decides the language.** Completeness puts the optimum above two thirds of +the coin space and soundness below one third, so a comparison against a half separates them. -/ +theorem mem_iff_gval {L : Language} + (hcomp : ∀ y ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen y.length) ∧ + 2 / 3 ≤ eventProb (prot.acceptEvent S y)) + (hsound : ∀ y ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen y.length) → + eventProb (prot.acceptEvent S y) ≤ 1 / 3) : + x ∈ L ↔ 2 ^ prot.coins x.length + < 2 * prot.gval x (prot.coins x.length) (prot.msgLen x.length) + (prot.rounds x.length) [] := by + classical + have hpos : 0 < 2 ^ prot.coins x.length := Nat.two_pow_pos _ + constructor + · intro hx + obtain ⟨S, hSb, hSp⟩ := hcomp x hx + have hle := card_acceptEvent_le_gval prot x S hSb + rw [eventProb, div_le_div_iff₀ (by norm_num) (by positivity)] at hSp + have hSp' : 2 * 2 ^ prot.coins x.length ≤ (prot.acceptEvent S x).card * 3 := by + exact_mod_cast hSp + omega + · intro hlt + by_contra hx + have hSb := prot.optStrategy_bounded x (prot.coins x.length) (prot.msgLen x.length) + (prot.rounds x.length) + have hSp := hsound x hx _ hSb + rw [eventProb, div_le_div_iff₀ (by positivity) (by norm_num)] at hSp + have hSp' : (prot.acceptEvent (prot.optStrategy x (prot.coins x.length) + (prot.msgLen x.length) (prot.rounds x.length)) x).card * 3 + ≤ 1 * 2 ^ prot.coins x.length := by exact_mod_cast hSp + rw [gval_eq_card_acceptEvent] at hlt + omega + +/-! ## Every message in the tree is short -/ + +open Classical in +/-- A verifier message the tree branches on respects the length bound. -/ +theorem vset_length (t : ℕ) (τ : Transcript) {v : List Bool} (hv : v ∈ prot.vset x t τ) : + v.length ≤ prot.msgLen x.length := by + classical + rw [vset, Finset.mem_image] at hv + obtain ⟨r, _, rfl⟩ := hv + exact prot.vmsg_len x (BitString.toList r) τ + +/-- Hence every message on a path down the tree does. -/ +theorem runFrom_length (S : ProverStrategy) (hS : S.Bounded (prot.msgLen x.length)) + (r : List Bool) : + ∀ (n : ℕ) (τ : Transcript), (∀ u ∈ τ, u.length ≤ prot.msgLen x.length) → + ∀ u ∈ prot.runFrom x S r n τ, u.length ≤ prot.msgLen x.length := by + intro n + induction n with + | zero => intro τ hτ; exact hτ + | succ n ih => + intro τ hτ + refine ih _ fun u hu => ?_ + rcases List.mem_append.mp hu with hu | hu + · exact hτ u hu + · rcases List.mem_cons.mp hu with rfl | hu + · exact prot.vmsg_len x r τ + · rcases List.mem_cons.mp hu with rfl | hu + · exact hS _ + · simp at hu + +/-- And the transcript never holds more than two messages per round. -/ +theorem runFrom_card (S : ProverStrategy) (r : List Bool) : + ∀ (n : ℕ) (τ : Transcript), (prot.runFrom x S r n τ).length = τ.length + 2 * n := by + intro n + induction n with + | zero => intro τ; simp + | succ n ih => + intro τ + rw [runFrom_succ, ih] + simp + omega + +/-! ## The tree in the form a machine walks it -/ + +open Classical in +/-- A node no coin string reaches contributes nothing. -/ +theorem gval_eq_zero (t m : ℕ) (n : ℕ) (σ : Transcript) + (h : prot.consFinset x t σ = ∅) : prot.gval x t m n σ = 0 := by + classical + cases n with + | zero => + rw [gval, h] + simp + | succ n => + rw [gval_succ, vset, h] + simp + +open Classical in +/-- **The sum may range over every short string.** A verifier message no coin string would send +splits off an empty set of coins, so its whole subtree is zero; and `Protocol.vmsg_len` keeps the +messages that *are* sent inside `Complexity.strsLe`. The recursion is then a walk over a fixed +finite index set, which is what a machine can enumerate. -/ +theorem gval_succ_strsLe (t : ℕ) (n i : ℕ) (τ : Transcript) (hτ : τ.length = 2 * i) : + prot.gval x t (prot.msgLen x.length) (n + 1) τ + = ∑ v ∈ strsLe (prot.msgLen x.length), + (strsLe (prot.msgLen x.length)).sup fun a => + prot.gval x t (prot.msgLen x.length) n (τ ++ [v, a]) := by + classical + rw [gval_succ] + refine Finset.sum_subset (fun v hv => mem_strsLe.mpr (prot.vset_length x t τ hv)) ?_ + intro v _ hv + have hempty : ∀ a : List Bool, prot.consFinset x t (τ ++ [v, a]) = ∅ := by + intro a + rw [prot.consFinset_append x t τ i hτ v a] + refine Finset.filter_eq_empty_iff.mpr fun r hr hc => hv ?_ + rw [vset] + exact Finset.mem_image.mpr ⟨r, hr, hc⟩ + refine Nat.le_zero.mp (Finset.sup_le fun a _ => ?_) + exact Nat.le_of_eq (gval_eq_zero prot x t _ n (τ ++ [v, a]) (hempty a)) + +open Classical in +/-- **The leaf count, over bitstrings.** The coin space is exactly the strings of the coin +length, so the count a machine has to make at a leaf is a scan over `Complexity.strsOfLen`. -/ +theorem gval_zero_strsOfLen (t m : ℕ) (τ : Transcript) : + prot.gval x t m 0 τ + = ((strsOfLen t).filter fun s => + prot.Consistent x s τ ∧ view x s τ ∈ prot.verdict).card := by + classical + rw [gval, consFinset, Finset.filter_filter] + refine Finset.card_bij (fun r _ => BitString.toList r) ?_ ?_ ?_ + · intro r hr + rw [Finset.mem_filter] at hr ⊢ + exact ⟨mem_strsOfLen.mpr (BitString.length_toList r), hr.2⟩ + · intro r _ r' _ h + exact BitString.toList_inj.mp h + · intro s hs + rw [Finset.mem_filter] at hs + have hlen : s.length = t := mem_strsOfLen.mp hs.1 + refine ⟨BitString.ofList s hlen, ?_, BitString.toList_ofList s hlen⟩ + rw [Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [BitString.toList_ofList] + exact hs.2 + +/-! ## Replaying the verifier -/ + +/-- Walk the rounds, checking that every message the verifier is recorded as having sent is the +one it would have sent. The body of the transcript's encoding is carried along, so nothing is +re-encoded. -/ +def replay (prot : Protocol) (x s : List Bool) : + List (List Bool × List Bool) → List Bool → Bool + | [], _ => true + | p :: ps, body => + decide (p.1 = prot.vmsg (pair (pair x s) (false :: (body ++ [true])))) && + replay prot x s ps (body ++ encMsg p.1 ++ encMsg p.2) + +@[simp] theorem replay_nil (s body : List Bool) : prot.replay x s [] body = true := rfl + +theorem replay_cons (s : List Bool) (p : List Bool × List Bool) + (ps : List (List Bool × List Bool)) (body : List Bool) : + prot.replay x s (p :: ps) body + = (decide (p.1 = prot.vmsg (pair (pair x s) (false :: (body ++ [true])))) && + prot.replay x s ps (body ++ encMsg p.1 ++ encMsg p.2)) := rfl + +/-- **Consistency is a replay.** Walking the rounds and re-deriving the verifier's messages +decides whether a coin string could have produced the transcript. -/ +theorem consistent_append_iff_replay (s : List Bool) : + ∀ (ps : List (List Bool × List Bool)) (τ : Transcript) (i : ℕ), τ.length = 2 * i → + (prot.Consistent x s (τ ++ flatRounds ps) ↔ + prot.Consistent x s τ ∧ prot.replay x s ps (encBody τ) = true) := by + intro ps + induction ps with + | nil => + intro τ i _ + simp + | cons p ps ih => + intro τ i hτ + obtain ⟨v, a⟩ := p + have hsplit : τ ++ flatRounds ((v, a) :: ps) = (τ ++ [v, a]) ++ flatRounds ps := by + rw [flatRounds_cons] + simp + have hτ' : (τ ++ [v, a]).length = 2 * (i + 1) := by + rw [List.length_append, hτ] + simp + omega + rw [hsplit, ih (τ ++ [v, a]) (i + 1) hτ', + prot.consistent_append x s τ i hτ v a, replay_cons, encBody_append_two, view_eq] + constructor + · rintro ⟨⟨h1, h2⟩, h3⟩ + refine ⟨h1, ?_⟩ + rw [Bool.and_eq_true, decide_eq_true_iff] + refine ⟨h2, ?_⟩ + simpa [List.append_assoc] using h3 + · rintro ⟨h1, h2⟩ + rw [Bool.and_eq_true, decide_eq_true_iff] at h2 + refine ⟨⟨h1, h2.1⟩, ?_⟩ + simpa [List.append_assoc] using h2.2 + +/-- **Consistency at the root.** -/ +theorem consistent_iff_replay (s : List Bool) (ps : List (List Bool × List Bool)) : + prot.Consistent x s (flatRounds ps) ↔ prot.replay x s ps [] = true := by + have h := prot.consistent_append_iff_replay x s ps [] 0 rfl + rw [List.nil_append, encBody_nil] at h + rw [h] + simp [prot.consistent_nil x s] + +/-! ## The tree indexed by rounds -/ + +open Classical in +/-- **The tree value, indexed by the rounds already played.** This is the recursion a stack +machine walks: one frame per round, a sum over the verifier's possible messages and a maximum +over the prover's replies, bottoming out in a count over the coin strings. -/ +noncomputable def gvalR (t n : ℕ) (ps : List (List Bool × List Bool)) : ℕ := + prot.gval x t (prot.msgLen x.length) n (flatRounds ps) + +open Classical in +theorem gvalR_zero (t : ℕ) (ps : List (List Bool × List Bool)) : + prot.gvalR x t 0 ps + = ((strsOfLen t).filter fun s => + prot.replay x s ps [] = true ∧ + pair (pair x s) (false :: (encBodyR ps ++ [true])) ∈ prot.verdict).card := by + classical + rw [gvalR, gval_zero_strsOfLen] + refine congrArg Finset.card (Finset.filter_congr fun s _ => ?_) + rw [prot.consistent_iff_replay x s ps, view_eq, encBodyR] + +open Classical in +theorem gvalR_succ (t n : ℕ) (ps : List (List Bool × List Bool)) : + prot.gvalR x t (n + 1) ps + = ∑ v ∈ strsLe (prot.msgLen x.length), + (strsLe (prot.msgLen x.length)).sup fun a => + prot.gvalR x t n (ps ++ [(v, a)]) := by + classical + rw [gvalR, gval_succ_strsLe prot x t n ps.length (flatRounds ps) (by simp)] + refine Finset.sum_congr rfl fun v _ => ?_ + refine Finset.sup_congr rfl fun a _ => ?_ + rw [gvalR, flatRounds_append] + +theorem gvalR_root (t n : ℕ) : prot.gvalR x t n [] = prot.gval x t (prot.msgLen x.length) n [] := + rfl + +/-! ## The recursion against the counters -/ + +open Classical in +/-- **The branching, as two counter loops.** `Complexity.nextStr` visits every message the +verifier or the prover may send exactly once, so the sum and the maximum are ordinary loops. -/ +theorem gvalR_succ_enum (t n : ℕ) (ps : List (List Bool × List Bool)) : + prot.gvalR x t (n + 1) ps + = ∑ i ∈ Finset.range (2 ^ (prot.msgLen x.length + 1) - 1), + (Finset.range (2 ^ (prot.msgLen x.length + 1) - 1)).sup fun j => + prot.gvalR x t n (ps ++ [(nextStr^[i] [], nextStr^[j] [])]) := by + classical + rw [gvalR_succ, strsLe_eq_image (prot.msgLen x.length), + Finset.sum_image fun i hi j hj h => + nextStr_injOn (prot.msgLen x.length) (Finset.mem_coe.mpr hi) (Finset.mem_coe.mpr hj) h] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Finset.sup_image] + rfl + +open Classical in +/-- **The leaf, as a counter loop.** -/ +theorem gvalR_zero_enum (t : ℕ) (ps : List (List Bool × List Bool)) : + prot.gvalR x t 0 ps + = ((Finset.range (2 ^ t)).filter fun i => + prot.replay x (bumpBits^[i] (List.replicate t false)) ps [] = true ∧ + pair (pair x (bumpBits^[i] (List.replicate t false))) + (false :: (encBodyR ps ++ [true])) ∈ prot.verdict).card := by + classical + rw [gvalR_zero, strsOfLen_eq_image, Finset.filter_image, + Finset.card_image_of_injOn (fun i hi j hj h => + bumpBits_injOn t (Finset.mem_coe.mpr (Finset.mem_of_mem_filter i hi)) + (Finset.mem_coe.mpr (Finset.mem_of_mem_filter j hj)) h)] + +/-! ## The value never exceeds the coin space -/ + +open Classical in +/-- **The tree value never exceeds the number of coins still in play.** The verifier's next +message partitions those coins, so summing over the messages cannot double-count. -/ +theorem gval_le_card (t : ℕ) : + ∀ (n i : ℕ) (τ : Transcript), τ.length = 2 * i → + prot.gval x t (prot.msgLen x.length) n τ ≤ (prot.consFinset x t τ).card := by + classical + intro n + induction n with + | zero => + intro i τ _ + rw [gval] + exact Finset.card_filter_le _ _ + | succ n ih => + intro i τ hτ + rw [gval_succ] + have hfib := Finset.card_eq_sum_card_fiberwise + (f := fun r : Fin t → Bool => prot.vmsg (view x (BitString.toList r) τ)) + (s := prot.consFinset x t τ) (t := prot.vset x t τ) + (fun r hr => by + rw [vset] + exact Finset.mem_image_of_mem _ hr) + rw [hfib] + refine Finset.sum_le_sum fun v _ => ?_ + refine Finset.sup_le fun a _ => ?_ + have hle := ih (i + 1) (τ ++ [v, a]) (by simp [hτ]; omega) + rwa [prot.consFinset_append x t τ i hτ v a] at hle + +open Classical in +theorem gval_le_two_pow (t n i : ℕ) (τ : Transcript) (hτ : τ.length = 2 * i) : + prot.gval x t (prot.msgLen x.length) n τ ≤ 2 ^ t := by + classical + refine le_trans (gval_le_card prot x t n i τ hτ) ?_ + rw [consFinset] + refine le_trans (Finset.card_filter_le _ _) ?_ + rw [Finset.card_univ, card_finArrowBool] + +theorem gvalR_le_two_pow (t n : ℕ) (ps : List (List Bool × List Bool)) : + prot.gvalR x t n ps ≤ 2 ^ t := + gval_le_two_pow prot x t n ps.length (flatRounds ps) (by simp) + +end Protocol + +/-! ## The containment, reduced to evaluating the tree -/ + +open Classical in +/-- **`IP ⊆ PSPACE`, reduced to one computation.** Membership in a language of `IP` is a +comparison of the game-tree value against half the coin space, so a polynomial-space evaluation +of that value settles the containment. -/ +theorem IP_subset_PSPACE_of_gval + (h : ∀ (prot : Protocol) (rp cp mp : Polynomial ℕ), (∀ n, prot.rounds n = rp.eval n) → + (∀ n, prot.coins n = cp.eval n) → (∀ n, prot.msgLen n = mp.eval n) → + {x : List Bool | 2 ^ prot.coins x.length + < 2 * prot.gval x (prot.coins x.length) (prot.msgLen x.length) + (prot.rounds x.length) []} ∈ PSPACE) : + IP ⊆ PSPACE := by + intro L hL + obtain ⟨prot, rp, cp, mp, hr, hc, hm, hcomp, hsound⟩ := hL + have hset : L = {x : List Bool | 2 ^ prot.coins x.length + < 2 * prot.gval x (prot.coins x.length) (prot.msgLen x.length) + (prot.rounds x.length) []} := + Set.ext fun x => Protocol.mem_iff_gval prot x hcomp hsound + rw [hset] + exact h prot rp cp mp hr hc hm + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPLeaf.lean b/Complexitylib/Classes/Containments/Internal/IPLeaf.lean new file mode 100644 index 00000000..284f1183 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPLeaf.lean @@ -0,0 +1,411 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.IPWalk +public import Complexitylib.Classes.Containments.Internal.PVerdict + +/-! +# The leaf test + +⚠️ Unreviewed by Bolton + +At a leaf the walk asks one question of each coin string: *would the verifier have sent every +message the transcript records, and does it accept?* The first half is +`Complexity.Protocol.replay`, which walks the rounds in play order carrying the encoding body +with it — the wrong direction for a stack, whose top frame is the *last* round. + +Carrying each frame's body inside the frame removes the problem: the check a round contributes +depends only on that round's verifier message and its own body, so the conjunction may be taken in +any order. That is what `Complexity.stkCheckB` does, and it is what a scan over the encoded stack +can compute. + +## Main definitions + +- `Complexity.stkCheckB` — the per-frame form of the consistency test + +## Main results + +- `Complexity.Protocol.replay_append` — a round appended checks its own message last +- `Complexity.replay_eq_stkCheckB` — the two forms agree +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +namespace Protocol + +/-- **A round appended checks its own message last**, against the body of everything before it. -/ +theorem replay_append (prot : Protocol) (x s : List Bool) : + ∀ (ps : List (List Bool × List Bool)) (p : List Bool × List Bool) (body : List Bool), + prot.replay x s (ps ++ [p]) body + = (prot.replay x s ps body && + decide (p.1 = prot.vmsg (pair (pair x s) + (false :: (body ++ encBodyR ps) ++ [true])))) := by + intro ps + induction ps with + | nil => + intro p body + rw [List.nil_append, replay_cons, replay_nil, encBodyR_nil, List.append_nil] + simp + | cons q ps ih => + intro p body + rw [List.cons_append, replay_cons, ih p (body ++ encMsg q.1 ++ encMsg q.2), replay_cons] + have hbody : body ++ encBodyR (q :: ps) + = body ++ encMsg q.1 ++ encMsg q.2 ++ encBodyR ps := by + rw [encBodyR, encBodyR, flatRounds_cons, encBody, encBody] + simp [List.append_assoc] + rw [hbody, Bool.and_assoc] + +end Protocol + +/-- The consistency test as a conjunction over the frames, each checking its own recorded +message against its own body. -/ +def stkCheckB (vf : List Bool → List Bool) (x s : List Bool) : List IPM.Frm → Bool + | [] => true + | g :: gs => + decide (g.v = vf (pair (pair x s) (false :: g.body ++ [true]))) && stkCheckB vf x s gs + +@[simp] theorem stkCheckB_nil (vf : List Bool → List Bool) (x s : List Bool) : + stkCheckB vf x s [] = true := rfl + +theorem stkCheckB_cons (vf : List Bool → List Bool) (x s : List Bool) (g : IPM.Frm) + (gs : List IPM.Frm) : + stkCheckB vf x s (g :: gs) + = (decide (g.v = vf (pair (pair x s) (false :: g.body ++ [true]))) && + stkCheckB vf x s gs) := rfl + +/-- **The two forms of the consistency test agree.** -/ +theorem replay_eq_stkCheckB (prot : Protocol) (x s : List Bool) : + ∀ fs : List IPM.Frm, IPM.BodyOk fs → + prot.replay x s (IPM.roundsOf fs) [] = stkCheckB prot.vmsg x s fs := by + intro fs + induction fs with + | nil => intro _; rfl + | cons g gs ih => + intro hb + rw [IPM.roundsOf_cons, prot.replay_append x s (IPM.roundsOf gs) (g.v, g.a) [], + ih hb.2, stkCheckB_cons, List.nil_append, ← hb.1, Bool.and_comm] + +/-! ## Flags as decisions -/ + +theorem eqFlag_eq_decide (a b : List Bool) : eqFlag a b = [decide (a = b)] := by + by_cases h : a = b + · rw [(eqFlag_eq_true_iff a b).mpr h, h] + simp + · rcases eqFlag_flag a b with hh | hh + · exact absurd ((eqFlag_eq_true_iff a b).mp hh) h + · rw [hh] + simp [h] + +@[simp] theorem andBit_cons (b c : Bool) : andBit [b] [c] = [b && c] := by + cases b <;> cases c <;> rfl + +theorem andBit_length_eq (u v : List Bool) : (andBit u v).length = 1 := by + rcases andBit_flag u v with h | h <;> rw [h] <;> rfl + +/-! ## The scan over the stack -/ + +/-- The check one frame contributes, on the tape. -/ +def chkOneP (vf : List Bool → List Bool) (xu y : List Bool) : List Bool := + eqFlag (IPM.fV y) (vf (pair xu (false :: IPM.fBody y ++ [true]))) + +theorem chkOneP_enc (vf : List Bool → List Bool) (xu : List Bool) (g : IPM.Frm) : + chkOneP vf xu (IPM.encFrm g) + = [decide (g.v = vf (pair xu (false :: g.body ++ [true])))] := by + rw [chkOneP, IPM.fV_enc, IPM.fBody_enc, eqFlag_eq_decide] + +/-- One step of the scan: fold the next frame's check into the running flag. -/ +def chkStep (vf : List Bool → List Bool) : + List Bool × List Bool × List Bool → List Bool × List Bool × List Bool := + fun s => + (s.1, + selectHead (emptyFlag s.2.2) s.2.1 (andBit s.2.1 (chkOneP vf s.1 (fstBlock s.2.2))), + selectHead (emptyFlag s.2.2) s.2.2 (sndBlock s.2.2)) + +@[simp] theorem chkStep_nil (vf : List Bool → List Bool) (xu acc : List Bool) : + chkStep vf (xu, acc, []) = (xu, acc, []) := by + rw [chkStep] + simp + +theorem chkStep_cons (vf : List Bool → List Bool) (xu acc : List Bool) (g : IPM.Frm) + (gs : List IPM.Frm) : + chkStep vf (xu, acc, IPM.encStk (g :: gs)) + = (xu, andBit acc (chkOneP vf xu (IPM.encFrm g)), IPM.encStk gs) := by + rw [chkStep, IPM.encStk_cons] + simp only [emptyFlag_pair, selectHead_cons_false, fstBlock_pair, sndBlock_pair] + +/-- The running flag after folding in a list of frames. -/ +def chkFold (vf : List Bool → List Bool) (xu : List Bool) : + List Bool → List IPM.Frm → List Bool + | acc, [] => acc + | acc, g :: gs => chkFold vf xu (andBit acc (chkOneP vf xu (IPM.encFrm g))) gs + +theorem chkFold_flag (vf : List Bool → List Bool) (x u : List Bool) : + ∀ (fs : List IPM.Frm) (b : Bool), + chkFold vf (pair x u) [b] fs = [b && stkCheckB vf x u fs] := by + intro fs + induction fs with + | nil => intro b; simp [chkFold] + | cons g gs ih => + intro b + rw [chkFold, chkOneP_enc, andBit_cons, ih, stkCheckB_cons, Bool.and_assoc] + +/-- **The scan folds every frame in.** -/ +theorem chkStep_iterate (vf : List Bool → List Bool) (xu : List Bool) : + ∀ (fs : List IPM.Frm) (acc : List Bool) (n : ℕ), fs.length ≤ n → + (chkStep vf)^[n] (xu, acc, IPM.encStk fs) = (xu, chkFold vf xu acc fs, []) := by + intro fs + induction fs with + | nil => + intro acc n _ + have : ∀ m : ℕ, (chkStep vf)^[m] (xu, acc, ([] : List Bool)) = (xu, acc, []) := by + intro m + induction m with + | zero => rfl + | succ m ih => rw [Function.iterate_succ_apply, chkStep_nil, ih] + rw [IPM.encStk_nil, this] + rfl + | cons g gs ih => + intro acc n hn + obtain ⟨m, rfl⟩ : ∃ m, n = m + 1 := ⟨n - 1, by simp at hn; omega⟩ + rw [Function.iterate_succ_apply, chkStep_cons, ih _ m (by simp at hn; omega), chkFold] + +/-! ## The packed scan -/ + +theorem sndBlock_length_le (z : List Bool) : (sndBlock z).length ≤ z.length := by + rcases hu : unpair? z with _ | ⟨p, q⟩ + · rw [show sndBlock z = [] from by rw [sndBlock, hu]] + simp + · have hz : z = pair p q := unpair?_eq_some_iff.mp hu + rw [show sndBlock z = q from by rw [sndBlock, hu], hz, pair_length] + omega + +/-- The packed scan state: the verifier's fixed arguments, the running flag, and the chain of +frames still to check. -/ +def chkPack (xu acc S : List Bool) : List Bool := pair xu (pair acc S) + +@[simp] theorem chkPack_length (xu acc S : List Bool) : + (chkPack xu acc S).length = 2 * xu.length + 2 * acc.length + S.length + 4 := by + rw [chkPack, pair_length, pair_length] + omega + +/-- One step of the packed scan. -/ +def chkStepP (vf : List Bool → List Bool) (z : List Bool) : List Bool := + pair (fstBlock z) + (pair + (selectHead (emptyFlag (sndBlock (sndBlock z))) (fstBlock (sndBlock z)) + (andBit (fstBlock (sndBlock z)) + (chkOneP vf (fstBlock z) (fstBlock (sndBlock (sndBlock z)))))) + (selectHead (emptyFlag (sndBlock (sndBlock z))) (sndBlock (sndBlock z)) + (sndBlock (sndBlock (sndBlock z))))) + +theorem chkStepP_pack (vf : List Bool → List Bool) (xu acc S : List Bool) : + chkStepP vf (chkPack xu acc S) + = chkPack (chkStep vf (xu, acc, S)).1 (chkStep vf (xu, acc, S)).2.1 + (chkStep vf (xu, acc, S)).2.2 := by + rw [chkStepP, chkPack, chkStep, chkPack] + simp only [fstBlock_pair, sndBlock_pair] + +theorem chkStepP_iterate (vf : List Bool → List Bool) + (s : List Bool × List Bool × List Bool) (n : ℕ) : + (chkStepP vf)^[n] (chkPack s.1 s.2.1 s.2.2) + = chkPack ((chkStep vf)^[n] s).1 ((chkStep vf)^[n] s).2.1 ((chkStep vf)^[n] s).2.2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, chkStepP_pack, ih (chkStep vf s), + Function.iterate_succ_apply] + +theorem chkStepP_iterate_args (vf : List Bool → List Bool) (xu acc S : List Bool) (n : ℕ) : + (chkStepP vf)^[n] (chkPack xu acc S) + = chkPack ((chkStep vf)^[n] (xu, acc, S)).1 ((chkStep vf)^[n] (xu, acc, S)).2.1 + ((chkStep vf)^[n] (xu, acc, S)).2.2 := + chkStepP_iterate vf (xu, acc, S) n + +theorem chkStep_iterate_length (vf : List Bool → List Bool) (xu acc S : List Bool) (n : ℕ) : + ((chkStep vf)^[n] (xu, acc, S)).1 = xu ∧ + ((chkStep vf)^[n] (xu, acc, S)).2.1.length ≤ max acc.length 1 ∧ + ((chkStep vf)^[n] (xu, acc, S)).2.2.length ≤ S.length := by + induction n generalizing acc S with + | zero => exact ⟨rfl, le_max_left _ _, le_rfl⟩ + | succ n ih => + rw [Function.iterate_succ_apply] + have hacc : (selectHead (emptyFlag S) acc + (andBit acc (chkOneP vf xu (fstBlock S)))).length ≤ max acc.length 1 := by + rw [selectHead] + split + · exact le_max_left _ _ + · split + · rw [andBit_length_eq] + exact le_max_right _ _ + · simp + have hS : (selectHead (emptyFlag S) S (sndBlock S)).length ≤ S.length := by + rw [selectHead] + split + · exact le_rfl + · split + · exact sndBlock_length_le S + · simp + obtain ⟨h1, h2, h3⟩ := ih (selectHead (emptyFlag S) acc + (andBit acc (chkOneP vf xu (fstBlock S)))) + (selectHead (emptyFlag S) S (sndBlock S)) + refine ⟨h1, le_trans h2 ?_, le_trans h3 hS⟩ + have hchain := max_le_max_right (α := ℕ) 1 hacc + omega + +/-! ## The leaf test -/ + +/-- The consistency flag, computed by running the scan against a ruler. -/ +def chkFlag (vf : List Bool → List Bool) (rr xu S : List Bool) : List Bool := + fstBlock (sndBlock ((chkStepP vf)^[rr.length] (chkPack xu [true] S))) + +theorem chkFlag_eq (vf : List Bool → List Bool) (rr : List Bool) (x u : List Bool) + (fs : List IPM.Frm) (h : fs.length ≤ rr.length) : + chkFlag vf rr (pair x u) (IPM.encStk fs) = [stkCheckB vf x u fs] := by + rw [chkFlag, chkStepP_iterate_args, chkStep_iterate vf _ fs [true] rr.length h, chkPack] + simp only [sndBlock_pair, fstBlock_pair] + rw [chkFold_flag vf x u fs true, Bool.true_and] + +/-- **The leaf test on the tape**: the transcript replays, and the verifier accepts. -/ +def okFn (vf vd : List Bool → List Bool) (rr x S u : List Bool) : List Bool := + andBit (chkFlag vf rr (pair x u) (sndBlock S)) + (vd (pair (pair x u) (false :: IPM.fBody (fstBlock S) ++ [true]))) + +open Classical in +/-- **The leaf test computes what the walk asks for.** -/ +theorem okFn_eq (prot : Protocol) (vd : List Bool → List Bool) + (hvd : ∀ z, vd z = [decide (z ∈ prot.verdict)]) + (rr x u : List Bool) (f : IPM.Frm) (fs : List IPM.Frm) + (hb : IPM.BodyOk (f :: fs)) (hlen : fs.length ≤ rr.length) : + okFn prot.vmsg vd rr x (IPM.encStk (f :: fs)) u + = [(prot.walkParams x).ok (IPM.roundsOf fs) u] := by + classical + rw [okFn, IPM.encStk_cons, sndBlock_pair, fstBlock_pair, + chkFlag_eq prot.vmsg rr x u fs hlen, IPM.fBody_enc, hvd, andBit_cons, hb.1, + ← replay_eq_stkCheckB prot x u fs hb.2] + show _ = [decide (prot.replay x u (IPM.roundsOf fs) [] = true ∧ + pair (pair x u) (false :: encBodyR (IPM.roundsOf fs) ++ [true]) ∈ prot.verdict)] + simp only [Bool.decide_and, Bool.decide_eq_true] + +/-! ## The leaf test is polynomial-time -/ + +theorem chkOnePFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) + {XU Y : List Bool → List Bool} (hxu : XU ∈ FP) (hy : Y ∈ FP) : + (fun z => chkOneP vf (XU z) (Y z)) ∈ FP := by + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hV : (fun z => IPM.fV (Y z)) ∈ FP := hfst (hsnd hy) + have hBody : (fun z => IPM.fBody (Y z)) ∈ FP := hsnd (hsnd (hsnd (hsnd (hsnd hy)))) + have hcons : (fun z => false :: (IPM.fBody (Y z) ++ [true])) ∈ FP := by + have hcat := Cobham.appendFn_mem_FP hBody (constFn_mem_FP [true]) + have := mem_FP_comp hcat (Cobham.cons_mem_FP false) + simpa [Function.comp] using this + have harg : (fun z => vf (pair (XU z) (false :: (IPM.fBody (Y z) ++ [true])))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP hxu hcons) hvf + simpa [Function.comp] using this + exact eqFlagFn_mem_FP hV harg + +theorem chkStepPFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) : chkStepP vf ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hxu := hfst hid + have hw := hsnd hid + have hacc := hfst hw + have hS := hsnd hw + have hflag := emptyFlagFn_mem_FP hS + exact Cobham.pairFn_mem_FP hxu + (Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP hflag hacc + (andBitFn_mem_FP hacc (chkOnePFn_mem_FP hvf hxu (hfst hS)))) + (Cobham.selectHeadFn_mem_FP hflag hS (hsnd hS))) + +theorem chkFlagFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) + {R XU S : List Bool → List Bool} (hR : R ∈ FP) (hxu : XU ∈ FP) (hS : S ∈ FP) : + (fun z => chkFlag vf (R z) (XU z) (S z)) ∈ FP := by + have hinit : (fun z => chkPack (XU z) [true] (S z)) ∈ FP := + Cobham.pairFn_mem_FP hxu (Cobham.pairFn_mem_FP (constFn_mem_FP [true]) hS) + have hwidth : (fun z => chkPack (XU z) [false] (S z)) ∈ FP := + Cobham.pairFn_mem_FP hxu (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) hS) + have hbound : ∀ z, ∀ n ≤ (R z).length, + ((chkStepP vf)^[n] (chkPack (XU z) [true] (S z))).length + ≤ (chkPack (XU z) [false] (S z)).length := by + intro z n _ + rw [chkStepP_iterate_args, chkPack_length, chkPack_length] + obtain ⟨h1, h2, h3⟩ := chkStep_iterate_length vf (XU z) [true] (S z) n + rw [h1] + simp only [List.length_cons, List.length_nil] at h2 ⊢ + omega + have h := Cobham.iterate_mem_FP (chkStepPFn_mem_FP hvf) hinit hR hwidth hbound + have h1 := mem_FP_comp h Cobham.sndBlock_mem_FP + have h2 := mem_FP_comp h1 Cobham.fstBlock_mem_FP + simpa [Function.comp, chkFlag] using h2 + +theorem okFnFn_mem_FP {vf vd : List Bool → List Bool} (hvf : vf ∈ FP) (hvd : vd ∈ FP) + {R X S U : List Bool → List Bool} (hR : R ∈ FP) (hX : X ∈ FP) (hS : S ∈ FP) + (hU : U ∈ FP) : (fun z => okFn vf vd (R z) (X z) (S z) (U z)) ∈ FP := by + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hxu : (fun z => pair (X z) (U z)) ∈ FP := Cobham.pairFn_mem_FP hX hU + have hBody : (fun z => IPM.fBody (fstBlock (S z))) ∈ FP := + hsnd (hsnd (hsnd (hsnd (hsnd (hfst hS))))) + have hcons : (fun z => false :: (IPM.fBody (fstBlock (S z)) ++ [true])) ∈ FP := by + have hcat := Cobham.appendFn_mem_FP hBody (constFn_mem_FP [true]) + have := mem_FP_comp hcat (Cobham.cons_mem_FP false) + simpa [Function.comp] using this + have hverd : (fun z => vd (pair (pair (X z) (U z)) + (false :: (IPM.fBody (fstBlock (S z)) ++ [true])))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP hxu hcons) hvd + simpa [Function.comp] using this + exact andBitFn_mem_FP (chkFlagFn_mem_FP hvf hR hxu (hsnd hS)) hverd + +/-! ## The leaf test discharges the walk's hypothesis -/ + +open Classical in +/-- The verifier's verdict as a one-bit flag. -/ +theorem exists_verdictFlag (prot : Protocol) : + ∃ vd : List Bool → List Bool, vd ∈ FP ∧ ∀ z, vd z = [decide (z ∈ prot.verdict)] := by + classical + obtain ⟨g, hg, hgL⟩ := exists_decisionFn_of_mem_P prot.verdict_mem + refine ⟨fun z => [g z], hg, fun z => ?_⟩ + simp [hgL z] + +open Classical in +/-- **The leaf test is exactly what the walk asks for**, for every stack the walk can reach. -/ +theorem okFn_hokf (prot : Protocol) (vd : List Bool → List Bool) + (hvd : ∀ z, vd z = [decide (z ∈ prot.verdict)]) (rr x : List Bool) (D : ℕ) + (hD : D ≤ rr.length + 1) : + ∀ (f : IPM.Frm) (fs : List IPM.Frm), IPM.BodyOk (f :: fs) → (f :: fs).length ≤ D → + ∀ u : List Bool, + okFn prot.vmsg vd rr x (IPM.encStk (f :: fs)) u + = [(prot.walkParams x).ok (IPM.roundsOf fs) u] := by + intro f fs hb hlen u + refine okFn_eq prot vd hvd rr x u f fs hb ?_ + simp only [List.length_cons] at hlen + omega + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPSem.lean b/Complexitylib/Classes/Containments/Internal/IPSem.lean new file mode 100644 index 00000000..5d1e60aa --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPSem.lean @@ -0,0 +1,970 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.TranscriptEnc + +/-! +# The walk of an interactive protocol's game tree + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.IPGameTree` reduces membership in a language of `IP` +to a recursion written as two counter loops: + +``` +gvalR 0 ps = #{coin strings that make the verifier accept below `ps`} +gvalR (n + 1) ps = ∑ over the verifier's messages, of the maximum over the prover's replies +``` + +This file is the machine that walks it, on an inductive state — the same discipline Savitch's +theorem uses in `Complexitylib.Classes.Containments.Internal.SavitchSem`. A stack holds one frame +per round, carrying the two message counters and the running sum and maximum; the bottom frame is +a leaf, carrying the coin counter and its tally. + +Everything the walk needs from the protocol is packed into `Complexity.IPM.Params`: the message +bound, the coin width, and the single test *does this coin string make the verifier accept, below +these rounds*. + +## Main definitions + +- `Complexity.IPM.Frm`, `Complexity.IPM.Sst` — a frame and the machine's state +- `Complexity.IPM.roundsOf` — the rounds a stack records +- `Complexity.IPM.step` — one step of the walk + +## Main results + +- the `step_*` lemmas — one for each shape the step can take +-/ + +@[expose] public section + +namespace Complexity + +namespace IPM + +/-! ## The data the walk needs -/ + +/-- What the walk needs to know about the protocol. -/ +structure Params where + /-- The bound on either side's message length. -/ + m : ℕ + /-- The number of coins, so the width of a coin string. -/ + t : ℕ + /-- Does this coin string make the verifier accept, below these rounds? -/ + ok : List (List Bool × List Bool) → List Bool → Bool + +/-- The zero of the width a count is held in: one bit more than the coin width, so that a count +of up to `2 ^ t` fits. -/ +def zeroCount (P : Params) : List Bool := List.replicate (P.t + 1) false + +/-- The first coin string. -/ +def zeroCoin (P : Params) : List Bool := List.replicate P.t false + +/-! ## The state -/ + +/-- A frame of the walk: the rounds still to play, the two message counters, and the running sum +and maximum. At a leaf `a` is the coin string and `sum` its tally. -/ +structure Frm where + /-- The rounds still to play, in unary. -/ + lvl : List Bool + /-- The verifier message currently being summed over. -/ + v : List Bool + /-- The prover reply currently being maximized over; the coin string at a leaf. -/ + a : List Bool + /-- The running sum; the running tally at a leaf. -/ + sum : List Bool + /-- The running maximum; unused at a leaf. -/ + best : List Bool + /-- The body of the encoding of the rounds below this frame. Carrying it is what makes the + leaf's consistency test a per-frame check rather than a walk back down the stack. -/ + body : List Bool + +/-- The machine's state. -/ +structure Sst where + /-- The bit the space-bounded iteration watches. -/ + done : Bool + /-- The answer, once it is known. -/ + ansBit : Bool + /-- The value a finished subtree is returning. -/ + ret : Option (List Bool) + /-- The stack, top frame first. -/ + stk : List Frm + +/-- The rounds a stack records: the message pair of every frame below the top, in the order they +were played. -/ +def roundsOf (fs : List Frm) : List (List Bool × List Bool) := + (fs.map fun g => (g.v, g.a)).reverse + +@[simp] theorem roundsOf_nil : roundsOf [] = [] := rfl + +@[simp] theorem roundsOf_cons (g : Frm) (fs : List Frm) : + roundsOf (g :: fs) = roundsOf fs ++ [(g.v, g.a)] := by + rw [roundsOf, roundsOf, List.map_cons, List.reverse_cons] + +@[simp] theorem roundsOf_length (fs : List Frm) : (roundsOf fs).length = fs.length := by + rw [roundsOf, List.length_reverse, List.length_map] + +/-- The frame a node starts from: both counters at the first message, both accumulators zero, and +the body of the rounds above it. At a leaf the coin counter starts at the first coin string +instead. -/ +def freshFrm (P : Params) (body lvl : List Bool) : Frm := + { lvl := lvl + v := [] + a := if lvl = [] then zeroCoin P else [] + sum := zeroCount P + best := zeroCount P + body := body } + +/-- The frame a branch pushes: a fresh node for the pair it is currently trying, carrying the +body of the transcript that leads to it. -/ +def childFrm (P : Params) (f : Frm) : Frm := + freshFrm P (f.body ++ encMsg f.v ++ encMsg f.a) (f.lvl.drop 1) + +@[simp] theorem childFrm_lvl (P : Params) (f : Frm) : (childFrm P f).lvl = f.lvl.drop 1 := rfl + +/-! ## One step -/ + +/-- The verdict the walk finishes with: the count `r` exceeds half the coin space. -/ +def cmpBit (P : Params) (r : List Bool) : Bool := + ltBitsLE false (twoPowBits P.t) (false :: r) + +/-- One step of the walk. -/ +def step (P : Params) (s : Sst) : Sst := + if s.done then ⟨s.ansBit, s.ansBit, s.ret, s.stk⟩ + else + match s.stk, s.ret with + | [], r => ⟨true, cmpBit P (r.getD []), r, []⟩ + | f :: fs, none => + if f.lvl = [] then + if bumpOver f.a then + ⟨false, s.ansBit, + some (if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum), fs⟩ + else + ⟨false, s.ansBit, none, + { f with + a := bumpBits f.a, + sum := if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum } :: fs⟩ + else + ⟨false, s.ansBit, none, + childFrm P f :: f :: fs⟩ + | f :: fs, some r => + if (nextStr f.a).length ≤ P.m then + ⟨false, s.ansBit, none, + { f with a := nextStr f.a, best := maxBits f.best r } :: fs⟩ + else + if (nextStr f.v).length ≤ P.m then + ⟨false, s.ansBit, none, + { f with + v := nextStr f.v, + a := [], + sum := addBits f.sum (maxBits f.best r), + best := zeroCount P } :: fs⟩ + else ⟨false, s.ansBit, some (addBits f.sum (maxBits f.best r)), fs⟩ + +variable (P : Params) + +@[simp] theorem step_of_done (a : Bool) (r : Option (List Bool)) (stk : List Frm) : + step P ⟨true, a, r, stk⟩ = ⟨a, a, r, stk⟩ := rfl + +@[simp] theorem step_of_empty (a : Bool) (r : Option (List Bool)) : + step P ⟨false, a, r, []⟩ = ⟨true, cmpBit P (r.getD []), r, []⟩ := rfl + +theorem step_leaf_last (a : Bool) (f : Frm) (fs : List Frm) (hl : f.lvl = []) + (hov : bumpOver f.a = true) : + step P ⟨false, a, none, f :: fs⟩ + = ⟨false, a, some (if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum), fs⟩ := by + simp [step, hl, hov] + +theorem step_leaf_next (a : Bool) (f : Frm) (fs : List Frm) (hl : f.lvl = []) + (hov : bumpOver f.a = false) : + step P ⟨false, a, none, f :: fs⟩ + = ⟨false, a, none, + { f with + a := bumpBits f.a, + sum := if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum } :: fs⟩ := by + simp [step, hl, hov] + +theorem step_push (a : Bool) (f : Frm) (fs : List Frm) (hl : f.lvl ≠ []) : + step P ⟨false, a, none, f :: fs⟩ + = ⟨false, a, none, + childFrm P f :: f :: fs⟩ := by + simp [step, hl] + +theorem step_ret_more_a (a : Bool) (f : Frm) (fs : List Frm) (r : List Bool) + (ha : (nextStr f.a).length ≤ P.m) : + step P ⟨false, a, some r, f :: fs⟩ + = ⟨false, a, none, { f with a := nextStr f.a, best := maxBits f.best r } :: fs⟩ := by + simp [step, ha] + +theorem step_ret_more_v (a : Bool) (f : Frm) (fs : List Frm) (r : List Bool) + (ha : ¬ (nextStr f.a).length ≤ P.m) (hv : (nextStr f.v).length ≤ P.m) : + step P ⟨false, a, some r, f :: fs⟩ + = ⟨false, a, none, + { f with + v := nextStr f.v, + a := [], + sum := addBits f.sum (maxBits f.best r), + best := zeroCount P } :: fs⟩ := by + simp [step, ha, hv] + +theorem step_ret_pop (a : Bool) (f : Frm) (fs : List Frm) (r : List Bool) + (ha : ¬ (nextStr f.a).length ≤ P.m) (hv : ¬ (nextStr f.v).length ≤ P.m) : + step P ⟨false, a, some r, f :: fs⟩ + = ⟨false, a, some (addBits f.sum (maxBits f.best r)), fs⟩ := by + simp [step, ha, hv] + +/-! ## The invariant the encoding needs -/ + +/-- Nothing is returning only while the stack is nonempty. -/ +def StkOk (s : Sst) : Prop := s.stk = [] → s.ret ≠ none + +theorem step_stkOk {s : Sst} (h : StkOk s) : StkOk (step P s) := by + obtain ⟨d, a, r, stk⟩ := s + cases d + · cases stk with + | nil => + obtain ⟨b, rfl⟩ : ∃ b, r = some b := by + cases r with + | none => exact absurd rfl (h rfl) + | some b => exact ⟨b, rfl⟩ + rw [step_of_empty] + intro _ + simp + | cons f fs => + cases r with + | none => + by_cases hl : f.lvl = [] + · by_cases hov : bumpOver f.a = true + · rw [step_leaf_last P a f fs hl hov] + intro _ + simp + · rw [step_leaf_next P a f fs hl (by simpa using hov)] + intro hc + simp at hc + · rw [step_push P a f fs hl] + intro hc + simp at hc + | some r => + by_cases ha : (nextStr f.a).length ≤ P.m + · rw [step_ret_more_a P a f fs r ha] + intro hc + simp at hc + · by_cases hv : (nextStr f.v).length ≤ P.m + · rw [step_ret_more_v P a f fs r ha hv] + intro hc + simp at hc + · rw [step_ret_pop P a f fs r ha hv] + intro _ + simp + · rw [step_of_done] + exact h + +theorem iterate_stkOk : ∀ (j : ℕ) (s : Sst), StkOk s → StkOk ((step P)^[j] s) := by + intro j + induction j with + | zero => intro s h; exact h + | succ j ih => + intro s h + rw [Function.iterate_succ_apply] + exact ih _ (step_stkOk P h) + +/-! ## What the walk is computing -/ + +/-- How many messages either side may send. -/ +def msgCount (P : Params) : ℕ := 2 ^ (P.m + 1) - 1 + +/-- The `i`-th message in the enumeration. -/ +def msgOf (i : ℕ) : List Bool := nextStr^[i] [] + +/-- The `k`-th coin string. -/ +def coinOf (P : Params) (k : ℕ) : List Bool := bumpBits^[k] (zeroCoin P) + +/-- **What a node of the tree is worth**: a count at a leaf, and a sum of maxima above. -/ +def treeVal (P : Params) : ℕ → List (List Bool × List Bool) → ℕ + | 0, ps => ((Finset.range (2 ^ P.t)).filter fun k => P.ok ps (coinOf P k)).card + | n + 1, ps => + ∑ i ∈ Finset.range (msgCount P), + (Finset.range (msgCount P)).sup fun j => treeVal P n (ps ++ [(msgOf i, msgOf j)]) + +/-- The best the prover can do at the verifier's `i`-th message, from its `ja`-th reply on. -/ +def tailCol (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i ja : ℕ) : ℕ := + (Finset.Ico ja (msgCount P)).sup fun j => treeVal P n (ps ++ [(msgOf i, msgOf j)]) + +/-- The best the prover can do at the verifier's `i`-th message. -/ +def col (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i : ℕ) : ℕ := + tailCol P n ps i 0 + +theorem treeVal_zero (P : Params) (ps : List (List Bool × List Bool)) : + treeVal P 0 ps = ((Finset.range (2 ^ P.t)).filter fun k => P.ok ps (coinOf P k)).card := rfl + +theorem treeVal_succ (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) : + treeVal P (n + 1) ps = ∑ i ∈ Finset.range (msgCount P), col P n ps i := by + rw [treeVal] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [col, tailCol, Finset.range_eq_Ico] + +/-! ## Splitting off one step of a loop -/ + +theorem Ico_eq_insert {a b : ℕ} (h : a < b) : + Finset.Ico a b = insert a (Finset.Ico (a + 1) b) := by + ext k + simp only [Finset.mem_Ico, Finset.mem_insert] + omega + +theorem tailCol_succ (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i ja : ℕ) + (h : ja < msgCount P) : + tailCol P n ps i ja + = max (treeVal P n (ps ++ [(msgOf i, msgOf ja)])) (tailCol P n ps i (ja + 1)) := by + classical + rw [tailCol, tailCol, Ico_eq_insert h, Finset.sup_insert] + +theorem tailCol_last (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i ja : ℕ) + (h : msgCount P ≤ ja + 1) (h' : ja < msgCount P) : + tailCol P n ps i ja = treeVal P n (ps ++ [(msgOf i, msgOf ja)]) := by + rw [tailCol_succ P n ps i ja h', tailCol, Finset.Ico_eq_empty (by omega)] + simp + +theorem tailCol_empty (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i ja : ℕ) + (h : msgCount P ≤ ja) : tailCol P n ps i ja = 0 := by + rw [tailCol, Finset.Ico_eq_empty (by omega)] + simp + +theorem sum_col_split (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i : ℕ) + (h : i < msgCount P) : + ∑ k ∈ Finset.Ico i (msgCount P), col P n ps k + = col P n ps i + ∑ k ∈ Finset.Ico (i + 1) (msgCount P), col P n ps k := by + classical + rw [Ico_eq_insert h, Finset.sum_insert (by simp)] + +theorem sum_col_empty (P : Params) (n : ℕ) (ps : List (List Bool × List Bool)) (i : ℕ) + (h : msgCount P ≤ i) : ∑ k ∈ Finset.Ico i (msgCount P), col P n ps k = 0 := by + rw [Finset.Ico_eq_empty (by omega)] + simp + +open Classical in +theorem leaf_split (P : Params) (ps : List (List Bool × List Bool)) (k : ℕ) (h : k < 2 ^ P.t) : + ((Finset.Ico k (2 ^ P.t)).filter fun l => P.ok ps (coinOf P l)).card + = (if P.ok ps (coinOf P k) then 1 else 0) + + ((Finset.Ico (k + 1) (2 ^ P.t)).filter fun l => P.ok ps (coinOf P l)).card := by + classical + rw [Ico_eq_insert h, Finset.filter_insert] + by_cases hk : P.ok ps (coinOf P k) + · rw [if_pos hk, if_pos hk, Finset.card_insert_of_notMem (by simp)] + omega + · rw [if_neg hk, if_neg hk] + omega + +open Classical in +theorem leaf_empty (P : Params) (ps : List (List Bool × List Bool)) (k : ℕ) (h : 2 ^ P.t ≤ k) : + ((Finset.Ico k (2 ^ P.t)).filter fun l => P.ok ps (coinOf P l)).card = 0 := by + rw [Finset.Ico_eq_empty (by omega)] + simp + +/-! ## What a frame is still worth -/ + +theorem msgOf_strIdx (w : List Bool) : msgOf (strIdx w) = w := + strIdx_injective (by rw [msgOf, strIdx_iterate]) + +@[simp] theorem strIdx_msgOf (i : ℕ) : strIdx (msgOf i) = i := strIdx_iterate i + +theorem coinOf_binValLE (P : Params) (s : List Bool) (hs : s.length = P.t) : + coinOf P (binValLE s) = s := by + have hlt : binValLE s < 2 ^ P.t := by + have := binValLE_lt s + rwa [hs] at this + rw [coinOf, zeroCoin, ← bitsOfLenLE_zero, bumpBits_iterate P.t _ hlt, ← hs, + bitsOfLenLE_binValLE] + +theorem msgCount_pos (P : Params) : 0 < msgCount P := by + have : 1 ≤ 2 ^ (P.m + 1) := Nat.one_le_two_pow + have h2 : 2 ^ 1 ≤ 2 ^ (P.m + 1) := Nat.pow_le_pow_right (by omega) (by omega) + rw [msgCount] + omega + +/-- **The value a frame will still contribute**: what it has banked, plus what its loops have +left to do. -/ +def frameVal (P : Params) (ps : List (List Bool × List Bool)) (f : Frm) : ℕ := + match f.lvl with + | [] => + binValLE f.sum + + ((Finset.Ico (binValLE f.a) (2 ^ P.t)).filter fun k => P.ok ps (coinOf P k)).card + | _ :: t' => + binValLE f.sum + + max (binValLE f.best) (tailCol P t'.length ps (strIdx f.v) (strIdx f.a)) + + ∑ k ∈ Finset.Ico (strIdx f.v + 1) (msgCount P), col P t'.length ps k + +theorem frameVal_leaf (P : Params) (ps : List (List Bool × List Bool)) {f : Frm} + (h : f.lvl = []) : + frameVal P ps f + = binValLE f.sum + + ((Finset.Ico (binValLE f.a) (2 ^ P.t)).filter fun k => P.ok ps (coinOf P k)).card := by + rw [frameVal, h] + +theorem frameVal_branch (P : Params) (ps : List (List Bool × List Bool)) {f : Frm} + {b : Bool} {t' : List Bool} (h : f.lvl = b :: t') : + frameVal P ps f + = binValLE f.sum + + max (binValLE f.best) (tailCol P t'.length ps (strIdx f.v) (strIdx f.a)) + + ∑ k ∈ Finset.Ico (strIdx f.v + 1) (msgCount P), col P t'.length ps k := by + rw [frameVal, h] + +/-- **A fresh frame is worth its whole subtree.** -/ +theorem frameVal_fresh (P : Params) (ps : List (List Bool × List Bool)) (body lvl : List Bool) : + frameVal P ps (freshFrm P body lvl) = treeVal P lvl.length ps := by + rcases lvl with _ | ⟨b, t'⟩ + · have hf : freshFrm P body ([] : List Bool) + = ⟨[], [], zeroCoin P, zeroCount P, zeroCount P, body⟩ := by simp [freshFrm] + rw [hf, frameVal_leaf P ps rfl] + simp only [List.length_nil] + rw [treeVal_zero] + simp only [zeroCount, zeroCoin, binValLE_replicate_false] + rw [Finset.range_eq_Ico] + simp + · have hf : freshFrm P body (b :: t') + = ⟨b :: t', [], [], zeroCount P, zeroCount P, body⟩ := by simp [freshFrm] + rw [hf, frameVal_branch P ps (b := b) (t' := t') rfl] + simp only [List.length_cons] + rw [treeVal_succ] + simp only [zeroCount, binValLE_replicate_false, strIdx_nil, Nat.zero_add, Nat.zero_max] + rw [show tailCol P t'.length ps 0 0 = col P t'.length ps 0 from rfl, + Finset.range_eq_Ico, sum_col_split P t'.length ps 0 (msgCount_pos P)] + +/-! ## Runs -/ + +/-- The done flag is down at every point of the first `T` steps from `s`. -/ +def DoneDown (P : Params) (s : Sst) (T : ℕ) : Prop := + ∀ j ≤ T, ((step P)^[j] s).done = false + +theorem doneDown_zero (P : Params) {s : Sst} (h : s.done = false) : DoneDown P s 0 := by + intro j hj + have : j = 0 := Nat.le_zero.mp hj + subst this + simpa using h + +theorem doneDown_add (P : Params) {s : Sst} {T₁ T₂ : ℕ} (h₁ : DoneDown P s T₁) + (h₂ : DoneDown P ((step P)^[T₁] s) T₂) : DoneDown P s (T₁ + T₂) := by + intro j hj + by_cases hle : j ≤ T₁ + · exact h₁ j hle + · have hj' : j = (j - T₁) + T₁ := by omega + rw [hj', Function.iterate_add_apply] + exact h₂ _ (by omega) + +theorem doneDown_succ (P : Params) {s : Sst} {T : ℕ} (h : DoneDown P s T) + (h' : ((step P)^[T + 1] s).done = false) : DoneDown P s (T + 1) := by + intro j hj + rcases Nat.lt_or_ge j (T + 1) with hlt | hge + · exact h j (by omega) + · have : j = T + 1 := by omega + subst this + exact h' + +/-- How many loop iterations a frame still has to make. -/ +def mu (P : Params) (f : Frm) : ℕ := + match f.lvl with + | [] => 2 ^ P.t - binValLE f.a + | _ :: _ => (msgCount P - 1 - strIdx f.v) * msgCount P + (msgCount P - strIdx f.a) + +/-- The steps a frame at level `n` costs. -/ +def runBound (P : Params) : ℕ → ℕ + | 0 => 2 ^ P.t + | n + 1 => msgCount P * msgCount P * (runBound P n + 2) + +theorem runBound_pos (P : Params) : ∀ n, 0 < runBound P n := by + intro n + induction n with + | zero => rw [runBound]; exact Nat.two_pow_pos _ + | succ n ih => + rw [runBound] + exact Nat.mul_pos (Nat.mul_pos (msgCount_pos P) (msgCount_pos P)) (by omega) + +/-- **The walk takes at most two to a polynomial steps.** -/ +theorem runBound_le (P : Params) : + ∀ n, runBound P n + 2 ≤ 2 ^ (P.t + 2 + (2 * P.m + 3) * n) := by + intro n + induction n with + | zero => + have h1 : (1 : ℕ) ≤ 2 ^ P.t := Nat.one_le_two_pow + have h2 : 2 ^ (P.t + 2) = 4 * 2 ^ P.t := by + rw [show P.t + 2 = 2 + P.t from by omega, pow_add] + ring + rw [runBound] + simp only [Nat.mul_zero, Nat.add_zero] + omega + | succ n ih => + have hM : msgCount P ≤ 2 ^ (P.m + 1) := by + rw [msgCount] + exact Nat.sub_le _ _ + have hMM : msgCount P * msgCount P + 1 ≤ 2 ^ (2 * P.m + 3) := by + have h1 : msgCount P * msgCount P ≤ 2 ^ (P.m + 1) * 2 ^ (P.m + 1) := + Nat.mul_le_mul hM hM + have h2 : 2 ^ (P.m + 1) * 2 ^ (P.m + 1) = 2 ^ (2 * P.m + 2) := by + rw [← pow_add] + ring_nf + have h3 : 2 ^ (2 * P.m + 3) = 2 * 2 ^ (2 * P.m + 2) := by + rw [show 2 * P.m + 3 = 1 + (2 * P.m + 2) from by omega, pow_add] + ring + have h4 : (1 : ℕ) ≤ 2 ^ (2 * P.m + 2) := Nat.one_le_two_pow + omega + have hc : 2 ≤ runBound P n + 2 := by omega + have hstep : runBound P (n + 1) + 2 + ≤ (msgCount P * msgCount P + 1) * (runBound P n + 2) := by + rw [runBound] + calc msgCount P * msgCount P * (runBound P n + 2) + 2 + ≤ msgCount P * msgCount P * (runBound P n + 2) + (runBound P n + 2) := by omega + _ = (msgCount P * msgCount P + 1) * (runBound P n + 2) := by ring + calc runBound P (n + 1) + 2 + ≤ (msgCount P * msgCount P + 1) * (runBound P n + 2) := hstep + _ ≤ 2 ^ (2 * P.m + 3) * 2 ^ (P.t + 2 + (2 * P.m + 3) * n) := Nat.mul_le_mul hMM ih + _ = 2 ^ (P.t + 2 + (2 * P.m + 3) * (n + 1)) := by + rw [← pow_add] + ring_nf + +/-- A frame is well formed when its registers have the right widths, its counters are inside the +enumeration, and what it still owes fits in the coin space. -/ +structure FrmOk (P : Params) (ps : List (List Bool × List Bool)) (f : Frm) : Prop where + /-- The running sum has the count width. -/ + sumLen : f.sum.length = P.t + 1 + /-- So does the running maximum. -/ + bestLen : f.best.length = P.t + 1 + /-- A leaf's coin counter has the coin width. -/ + coinLen : f.lvl = [] → f.a.length = P.t + /-- A branch's verifier counter is inside the enumeration. -/ + vIdx : f.lvl ≠ [] → strIdx f.v < msgCount P + /-- So is its prover counter. -/ + aIdx : f.lvl ≠ [] → strIdx f.a < msgCount P + /-- What the frame still owes fits in the coin space. -/ + bnd : frameVal P ps f ≤ 2 ^ P.t + +/-- The frame `f`, pushed on `fs`, is popped again carrying its value after exactly `T` steps, +and the done flag stays down for the whole of that run. -/ +def RunsTo (P : Params) (f : Frm) (fs : List Frm) (a : Bool) (T : ℕ) : Prop := + 0 < T ∧ DoneDown P ⟨false, a, none, f :: fs⟩ T ∧ + ∃ w : List Bool, w.length = P.t + 1 ∧ binValLE w = frameVal P (roundsOf fs) f ∧ + (step P)^[T] ⟨false, a, none, f :: fs⟩ = ⟨false, a, some w, fs⟩ + +/-- A run that begins by re-entering a frame of the same value. -/ +theorem runsTo_prepend (P : Params) {f g : Frm} {fs : List Frm} {a : Bool} {T₀ T₁ : ℕ} + (hd : DoneDown P ⟨false, a, none, f :: fs⟩ T₀) + (hs : (step P)^[T₀] ⟨false, a, none, f :: fs⟩ = ⟨false, a, none, g :: fs⟩) + (hr : RunsTo P g fs a T₁) + (hval : frameVal P (roundsOf fs) g = frameVal P (roundsOf fs) f) : + RunsTo P f fs a (T₁ + T₀) := by + obtain ⟨hpos, hdd, w, hwlen, hwval, hend⟩ := hr + refine ⟨by omega, ?_, w, hwlen, by rw [hwval, hval], ?_⟩ + · rw [Nat.add_comm] + exact doneDown_add P hd (by rw [hs]; exact hdd) + · rw [Function.iterate_add_apply, hs, hend] + +theorem mu_leaf (P : Params) {f : Frm} (h : f.lvl = []) : + mu P f = 2 ^ P.t - binValLE f.a := by rw [mu, h] + +theorem mu_branch (P : Params) {f : Frm} {b : Bool} {t' : List Bool} (h : f.lvl = b :: t') : + mu P f + = (msgCount P - 1 - strIdx f.v) * msgCount P + (msgCount P - strIdx f.a) := by rw [mu, h] + +/-- **A leaf runs its coin loop and pops with the tally.** -/ +theorem run_leaf (P : Params) : + ∀ (M : ℕ) (f : Frm), mu P f ≤ M → f.lvl = [] → ∀ (fs : List Frm), + FrmOk P (roundsOf fs) f → ∀ a : Bool, ∃ T ≤ mu P f, RunsTo P f fs a T := by + intro M + induction M with + | zero => + intro f hmu hl fs hok _ + exfalso + have hlt : binValLE f.a < 2 ^ P.t := by + have := binValLE_lt f.a + rwa [hok.coinLen hl] at this + rw [mu_leaf P hl] at hmu + omega + | succ M ih => + intro f hmu hl fs hok a + have hlen := hok.coinLen hl + have hlt : binValLE f.a < 2 ^ P.t := by + have := binValLE_lt f.a + rwa [hlen] at this + have hcoin : coinOf P (binValLE f.a) = f.a := coinOf_binValLE P f.a hlen + have hfv := frameVal_leaf P (roundsOf fs) hl + have hsplit := leaf_split P (roundsOf fs) (binValLE f.a) hlt + rw [hcoin] at hsplit + have hbnd := hok.bnd + -- bumping the tally never carries + have hsum : binValLE (if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum) + = binValLE f.sum + (if P.ok (roundsOf fs) f.a then 1 else 0) := by + by_cases hokb : P.ok (roundsOf fs) f.a + · rw [if_pos hokb, if_pos hokb] + have h1 : binValLE f.sum + 1 ≤ 2 ^ P.t := by + rw [hfv] at hbnd + rw [hsplit, if_pos hokb] at hbnd + omega + have h2 : binValLE f.sum + 1 < 2 ^ f.sum.length := by + rw [hok.sumLen, pow_succ] + have : 0 < 2 ^ P.t := Nat.two_pow_pos _ + omega + rw [binValLE_bumpBits_of_not_over _ (bumpOver_eq_false_of_lt h2)] + · rw [if_neg hokb, if_neg hokb] + omega + have hsumLen : (if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum).length + = P.t + 1 := by + by_cases hokb : P.ok (roundsOf fs) f.a + · rw [if_pos hokb, bumpBits_length, hok.sumLen] + · rw [if_neg hokb, hok.sumLen] + by_cases hov : bumpOver f.a = true + · -- the last coin string: pop with the tally + have hka : binValLE f.a = 2 ^ P.t - 1 := by + have := (bumpOver_iff f.a).mp hov + rwa [hlen] at this + have hstep := step_leaf_last P a f fs hl hov + refine ⟨1, by rw [mu_leaf P hl]; omega, Nat.one_pos, ?_, _, hsumLen, ?_, ?_⟩ + · exact doneDown_succ P (doneDown_zero P rfl) (by rw [Function.iterate_one, hstep]) + · rw [hfv, hsplit, hsum, leaf_empty P _ _ (by omega)] + omega + · rw [Function.iterate_one, hstep] + · -- move on to the next coin string + have hovf : bumpOver f.a = false := by simpa using hov + have hstep := step_leaf_next P a f fs hl hovf + set f' : Frm := + { f with + a := bumpBits f.a, + sum := if P.ok (roundsOf fs) f.a then bumpBits f.sum else f.sum } with hf' + have hl' : f'.lvl = [] := hl + have ha' : binValLE f'.a = binValLE f.a + 1 := by + rw [hf'] + exact binValLE_bumpBits_of_not_over _ hovf + have hval : frameVal P (roundsOf fs) f' = frameVal P (roundsOf fs) f := by + rw [frameVal_leaf P (roundsOf fs) hl', hfv, hsplit, ha', hsum] + omega + have hok' : FrmOk P (roundsOf fs) f' := + { sumLen := by rw [hf']; exact hsumLen + bestLen := by rw [hf']; exact hok.bestLen + coinLen := fun _ => by + show (bumpBits f.a).length = P.t + rw [bumpBits_length] + exact hlen + vIdx := fun hc => absurd hl' hc + aIdx := fun hc => absurd hl' hc + bnd := by rw [hval]; exact hbnd } + have hmu' : mu P f' = mu P f - 1 := by + rw [mu_leaf P hl', mu_leaf P hl, ha'] + omega + have hmupos : 1 ≤ mu P f := by + rw [mu_leaf P hl] + omega + obtain ⟨T', hT', hr'⟩ := ih f' (by omega) hl' fs hok' a + refine ⟨T' + 1, by omega, ?_⟩ + refine runsTo_prepend P ?_ ?_ hr' hval + · exact doneDown_succ P (doneDown_zero P rfl) (by rw [Function.iterate_one, hstep]) + · rw [Function.iterate_one, hstep] + +/-- Pushing a subtree, running it, and processing the value it returns. -/ +theorem child_phase (P : Params) {f : Frm} {fs : List Frm} {a : Bool} {Tc : ℕ} + {w : List Bool} {s : Sst} (hne : f.lvl ≠ []) + (hdd : DoneDown P ⟨false, a, none, childFrm P f :: f :: fs⟩ Tc) + (hend : (step P)^[Tc] ⟨false, a, none, childFrm P f :: f :: fs⟩ + = ⟨false, a, some w, f :: fs⟩) + (hstep : step P ⟨false, a, some w, f :: fs⟩ = s) + (hsdone : s.done = false) : + DoneDown P ⟨false, a, none, f :: fs⟩ (Tc + 1 + 1) ∧ + (step P)^[Tc + 1 + 1] ⟨false, a, none, f :: fs⟩ = s := by + have hpush : step P ⟨false, a, none, f :: fs⟩ + = ⟨false, a, none, childFrm P f :: f :: fs⟩ := step_push P a f fs hne + have h1 : (step P)^[Tc + 1] ⟨false, a, none, f :: fs⟩ = ⟨false, a, some w, f :: fs⟩ := by + rw [Function.iterate_succ_apply, hpush, hend] + have h2 : (step P)^[Tc + 1 + 1] ⟨false, a, none, f :: fs⟩ = s := by + rw [Function.iterate_succ_apply', h1, hstep] + refine ⟨?_, h2⟩ + have d1 : DoneDown P ⟨false, a, none, f :: fs⟩ 1 := + doneDown_succ P (doneDown_zero P rfl) (by rw [Function.iterate_one, hpush]) + have d2 : DoneDown P ⟨false, a, none, f :: fs⟩ (Tc + 1) := by + have := doneDown_add P d1 (by rw [Function.iterate_one, hpush]; exact hdd) + rwa [Nat.add_comm 1 Tc] at this + exact doneDown_succ P d2 (by rw [h2]; exact hsdone) + +/-- **A branch runs both of its loops and pops with the sum.** -/ +theorem run_branch (P : Params) (hval : ∀ (n : ℕ) (ps : List (List Bool × List Bool)), + treeVal P n ps ≤ 2 ^ P.t) (n : ℕ) + (ih : ∀ g : Frm, g.lvl.length = n → ∀ gs : List Frm, FrmOk P (roundsOf gs) g → + ∀ b : Bool, ∃ T ≤ runBound P n, RunsTo P g gs b T) : + ∀ (M : ℕ) (f : Frm), mu P f ≤ M → f.lvl.length = n + 1 → ∀ fs : List Frm, + FrmOk P (roundsOf fs) f → ∀ a : Bool, + ∃ T ≤ mu P f * (runBound P n + 2), RunsTo P f fs a T := by + intro M + induction M with + | zero => + intro f hmu hlen fs hok _ + exfalso + obtain ⟨b, t', hlv⟩ : ∃ b t', f.lvl = b :: t' := by + cases hc : f.lvl with + | nil => rw [hc] at hlen; simp at hlen + | cons b t' => exact ⟨b, t', rfl⟩ + have hne : f.lvl ≠ [] := by rw [hlv]; simp + have hja := hok.aIdx hne + rw [mu_branch P hlv] at hmu + omega + | succ M inner => + intro f hmu hlen fs hok a + obtain ⟨b, t', hlv⟩ : ∃ b t', f.lvl = b :: t' := by + cases hc : f.lvl with + | nil => rw [hc] at hlen; simp at hlen + | cons b t' => exact ⟨b, t', rfl⟩ + have hne : f.lvl ≠ [] := by rw [hlv]; simp + have htn : t'.length = n := by rw [hlv] at hlen; simpa using hlen + have hiv := hok.vIdx hne + have hja := hok.aIdx hne + set ps := roundsOf fs with hps + -- the child + have hchildlen : (childFrm P f).lvl.length = n := by + rw [childFrm_lvl, List.length_drop, hlen] + omega + have hrounds : roundsOf (f :: fs) = ps ++ [(f.v, f.a)] := roundsOf_cons f fs + have hchildok : FrmOk P (roundsOf (f :: fs)) (childFrm P f) := + { sumLen := by show (zeroCount P).length = P.t + 1; rw [zeroCount, List.length_replicate] + bestLen := by show (zeroCount P).length = P.t + 1; rw [zeroCount, List.length_replicate] + coinLen := fun hc => by + have hc' : f.lvl.drop 1 = [] := hc + show (if f.lvl.drop 1 = [] then zeroCoin P else []).length = P.t + rw [if_pos hc', zeroCoin, List.length_replicate] + vIdx := fun _ => by + show strIdx [] < msgCount P + rw [strIdx_nil] + exact msgCount_pos P + aIdx := fun hc => by + have hc' : ¬ (f.lvl.drop 1 = []) := hc + show strIdx (if f.lvl.drop 1 = [] then zeroCoin P else []) < msgCount P + rw [if_neg hc', strIdx_nil] + exact msgCount_pos P + bnd := by + rw [childFrm, frameVal_fresh] + exact hval _ _ } + obtain ⟨Tc, hTc, hcpos, hcdd, w, hwlen, hwval, hcend⟩ := + ih (childFrm P f) hchildlen (f :: fs) + hchildok a + rw [childFrm, frameVal_fresh] at hwval + have hdroplen : (f.lvl.drop 1).length = n := by + rw [List.length_drop, hlen] + omega + have hchildval : binValLE w + = treeVal P n (ps ++ [(msgOf (strIdx f.v), msgOf (strIdx f.a))]) := by + rw [hwval, hrounds, hdroplen, msgOf_strIdx, msgOf_strIdx] + -- the running value the frame owes + have hfv := frameVal_branch P ps (f := f) hlv + rw [htn] at hfv + have hmaxlen : (maxBits f.best w).length = P.t + 1 := by + rw [maxBits_length _ _ (by rw [hwlen, hok.bestLen]), hok.bestLen] + have hmaxval : binValLE (maxBits f.best w) = max (binValLE f.best) (binValLE w) := + binValLE_maxBits _ _ (by rw [hwlen, hok.bestLen]) + have hcond : ∀ u : List Bool, (nextStr u).length ≤ P.m ↔ strIdx u + 1 < msgCount P := by + intro u + rw [msgCount, ← strIdx_lt_iff P.m (nextStr u), strIdx_nextStr] + by_cases hA : strIdx f.a + 1 < msgCount P + · -- move on to the next reply + have hstep := step_ret_more_a P a f fs w ((hcond f.a).mpr hA) + set f' : Frm := { f with a := nextStr f.a, best := maxBits f.best w } with hf' + have hlv' : f'.lvl = b :: t' := hlv + have ha' : strIdx f'.a = strIdx f.a + 1 := strIdx_nextStr f.a + have hval' : frameVal P ps f' = frameVal P ps f := by + rw [frameVal_branch P ps (f := f') hlv', htn, hfv, ha'] + show binValLE f.sum + max (binValLE (maxBits f.best w)) _ + _ = _ + rw [hmaxval, tailCol_succ P n ps (strIdx f.v) (strIdx f.a) hja, ← hchildval, max_assoc] + have hok' : FrmOk P ps f' := + { sumLen := hok.sumLen + bestLen := hmaxlen + coinLen := fun hc => absurd (hlv'.symm.trans hc) (by simp) + vIdx := fun _ => hiv + aIdx := fun _ => by rw [ha']; omega + bnd := by rw [hval']; exact hok.bnd } + have hmu' : mu P f' = mu P f - 1 := by + rw [mu_branch P hlv', mu_branch P hlv] + show (msgCount P - 1 - strIdx f.v) * msgCount P + (msgCount P - strIdx (nextStr f.a)) = _ + rw [strIdx_nextStr] + omega + have hmupos : 1 ≤ mu P f := by + rw [mu_branch P hlv] + omega + obtain ⟨T', hT', hr'⟩ := inner f' (by omega) hlen fs hok' a + have hexp : mu P f * (runBound P n + 2) + = mu P f' * (runBound P n + 2) + (runBound P n + 2) := by + rw [hmu'] + obtain ⟨c, hc⟩ : ∃ c, mu P f = c + 1 := ⟨mu P f - 1, by omega⟩ + rw [hc, Nat.add_sub_cancel] + ring + obtain ⟨hd, hs⟩ := child_phase P hne hcdd hcend hstep rfl + exact ⟨T' + (Tc + 1 + 1), by omega, runsTo_prepend P hd hs hr' hval'⟩ + · have hja1 : msgCount P - strIdx f.a = 1 := by omega + have htail : tailCol P n ps (strIdx f.v) (strIdx f.a) + = treeVal P n (ps ++ [(msgOf (strIdx f.v), msgOf (strIdx f.a))]) := + tailCol_last P n ps _ _ (by omega) hja + have hbnd2 : binValLE f.sum + max (binValLE f.best) (binValLE w) ≤ 2 ^ P.t := by + have := hok.bnd + rw [hfv, htail, ← hchildval] at this + omega + have hsumlen : (maxBits f.best w).length = f.sum.length := by + rw [hmaxlen, hok.sumLen] + have hsumval : binValLE (addBits f.sum (maxBits f.best w)) + = binValLE f.sum + max (binValLE f.best) (binValLE w) := by + rw [binValLE_addBits _ _ hsumlen ?_, hmaxval] + rw [hmaxval, hok.sumLen, pow_succ] + have hp : 0 < 2 ^ P.t := Nat.two_pow_pos _ + omega + have hsumlen' : (addBits f.sum (maxBits f.best w)).length = P.t + 1 := by + rw [addBits_length _ _ hsumlen, hok.sumLen] + by_cases hB : strIdx f.v + 1 < msgCount P + · -- move on to the next verifier message + have hstep := step_ret_more_v P a f fs w + (fun hc => hA ((hcond f.a).mp hc)) ((hcond f.v).mpr hB) + set f'' : Frm := + { f with + v := nextStr f.v, + a := [], + sum := addBits f.sum (maxBits f.best w), + best := zeroCount P } with hf'' + have hlv'' : f''.lvl = b :: t' := hlv + have hval'' : frameVal P ps f'' = frameVal P ps f := by + rw [frameVal_branch P ps (f := f'') hlv'', htn, hfv, htail, ← hchildval] + show binValLE (addBits f.sum (maxBits f.best w)) + + max (binValLE (zeroCount P)) (tailCol P n ps (strIdx (nextStr f.v)) + (strIdx ([] : List Bool))) + + ∑ k ∈ Finset.Ico (strIdx (nextStr f.v) + 1) (msgCount P), col P n ps k = _ + rw [hsumval, zeroCount, binValLE_replicate_false, strIdx_nextStr, strIdx_nil, + Nat.zero_max, show tailCol P n ps (strIdx f.v + 1) 0 = col P n ps (strIdx f.v + 1) + from rfl, sum_col_split P n ps (strIdx f.v + 1) hB] + omega + have hok'' : FrmOk P ps f'' := + { sumLen := hsumlen' + bestLen := by + show (zeroCount P).length = P.t + 1 + rw [zeroCount, List.length_replicate] + coinLen := fun hc => absurd (hlv''.symm.trans hc) (by simp) + vIdx := fun _ => by + show strIdx (nextStr f.v) < msgCount P + rw [strIdx_nextStr] + omega + aIdx := fun _ => by + show strIdx ([] : List Bool) < msgCount P + rw [strIdx_nil] + exact msgCount_pos P + bnd := by rw [hval'']; exact hok.bnd } + have hmu'' : mu P f'' = mu P f - 1 := by + rw [mu_branch P hlv'', mu_branch P hlv] + show (msgCount P - 1 - strIdx (nextStr f.v)) * msgCount P + + (msgCount P - strIdx ([] : List Bool)) = _ + rw [strIdx_nextStr, strIdx_nil, hja1] + have hd : msgCount P - 1 - (strIdx f.v + 1) + 1 = msgCount P - 1 - strIdx f.v := by omega + calc (msgCount P - 1 - (strIdx f.v + 1)) * msgCount P + (msgCount P - 0) + = ((msgCount P - 1 - (strIdx f.v + 1)) + 1) * msgCount P := by rw [Nat.sub_zero]; ring + _ = (msgCount P - 1 - strIdx f.v) * msgCount P := by rw [hd] + _ = (msgCount P - 1 - strIdx f.v) * msgCount P + 1 - 1 := by omega + have hmupos : 1 ≤ mu P f := by + rw [mu_branch P hlv] + omega + obtain ⟨T', hT', hr'⟩ := inner f'' (by omega) hlen fs hok'' a + have hexp : mu P f * (runBound P n + 2) + = mu P f'' * (runBound P n + 2) + (runBound P n + 2) := by + rw [hmu''] + obtain ⟨c, hc⟩ : ∃ c, mu P f = c + 1 := ⟨mu P f - 1, by omega⟩ + rw [hc, Nat.add_sub_cancel] + ring + obtain ⟨hd, hs⟩ := child_phase P hne hcdd hcend hstep rfl + exact ⟨T' + (Tc + 1 + 1), by omega, runsTo_prepend P hd hs hr' hval''⟩ + · -- both loops are done: pop with the sum + have hstep := step_ret_pop P a f fs w + (fun hc => hA ((hcond f.a).mp hc)) (fun hc => hB ((hcond f.v).mp hc)) + have hfinal : binValLE (addBits f.sum (maxBits f.best w)) = frameVal P ps f := by + rw [hfv, htail, ← hchildval, hsumval, sum_col_empty P n ps _ (by omega)] + omega + have hmu1 : mu P f = 1 := by + rw [mu_branch P hlv, hja1] + have : msgCount P - 1 - strIdx f.v = 0 := by omega + rw [this] + omega + obtain ⟨hd, hs⟩ := child_phase P hne hcdd hcend hstep rfl + refine ⟨Tc + 1 + 1, ?_, by omega, hd, addBits f.sum (maxBits f.best w), + hsumlen', hfinal, hs⟩ + rw [hmu1] + omega + +/-- A fresh frame is well formed. -/ +theorem frmOk_fresh (P : Params) (hval : ∀ (n : ℕ) (ps : List (List Bool × List Bool)), + treeVal P n ps ≤ 2 ^ P.t) (ps : List (List Bool × List Bool)) (body lvl : List Bool) : + FrmOk P ps (freshFrm P body lvl) := + { sumLen := by show (zeroCount P).length = P.t + 1; rw [zeroCount, List.length_replicate] + bestLen := by show (zeroCount P).length = P.t + 1; rw [zeroCount, List.length_replicate] + coinLen := fun hc => by + have hc' : lvl = [] := hc + show (if lvl = [] then zeroCoin P else []).length = P.t + rw [if_pos hc', zeroCoin, List.length_replicate] + vIdx := fun _ => by + show strIdx [] < msgCount P + rw [strIdx_nil] + exact msgCount_pos P + aIdx := fun hc => by + have hc' : ¬ (lvl = []) := hc + show strIdx (if lvl = [] then zeroCoin P else []) < msgCount P + rw [if_neg hc', strIdx_nil] + exact msgCount_pos P + bnd := by rw [frameVal_fresh P ps body lvl]; exact hval _ _ } + +/-- **Every pushed frame comes back**, carrying its value, within `runBound` steps. -/ +theorem run_frame (P : Params) (hval : ∀ (n : ℕ) (ps : List (List Bool × List Bool)), + treeVal P n ps ≤ 2 ^ P.t) : + ∀ (n : ℕ) (f : Frm), f.lvl.length = n → ∀ fs : List Frm, FrmOk P (roundsOf fs) f → + ∀ a : Bool, ∃ T ≤ runBound P n, RunsTo P f fs a T := by + intro n + induction n with + | zero => + intro f hlen fs hok a + have hl : f.lvl = [] := List.length_eq_zero_iff.mp hlen + obtain ⟨T, hT, hr⟩ := run_leaf P (mu P f) f le_rfl hl fs hok a + refine ⟨T, ?_, hr⟩ + rw [mu_leaf P hl] at hT + rw [runBound] + exact le_trans hT (Nat.sub_le _ _) + | succ n ih => + intro f hlen fs hok a + obtain ⟨T, hT, hr⟩ := run_branch P hval n ih (mu P f) f le_rfl hlen fs hok a + refine ⟨T, ?_, hr⟩ + obtain ⟨b, t', hlv⟩ : ∃ b t', f.lvl = b :: t' := by + cases hc : f.lvl with + | nil => rw [hc] at hlen; simp at hlen + | cons b t' => exact ⟨b, t', rfl⟩ + have hne : f.lvl ≠ [] := by rw [hlv]; simp + have hmu : mu P f ≤ msgCount P * msgCount P := by + rw [mu_branch P hlv] + have h1 : (msgCount P - 1 - strIdx f.v) * msgCount P ≤ (msgCount P - 1) * msgCount P := + Nat.mul_le_mul_right _ (by omega) + have h2 : (msgCount P - 1) * msgCount P + msgCount P = msgCount P * msgCount P := by + have hp := msgCount_pos P + obtain ⟨c, hc⟩ : ∃ c, msgCount P = c + 1 := ⟨msgCount P - 1, by omega⟩ + rw [hc, Nat.add_sub_cancel] + ring + omega + rw [runBound] + exact le_trans hT (Nat.mul_le_mul_right _ hmu) + +/-- **The whole walk.** From a single fresh frame the machine keeps its flag down, raises it on +the next step, and one step later the flag *is* the verdict. -/ +theorem run_top (P : Params) (hval : ∀ (n : ℕ) (ps : List (List Bool × List Bool)), + treeVal P n ps ≤ 2 ^ P.t) (lvl : List Bool) : + ∃ (T : ℕ) (w : List Bool), T ≤ runBound P lvl.length ∧ w.length = P.t + 1 ∧ + binValLE w = treeVal P lvl.length [] ∧ + (∀ j ≤ T, ((step P)^[j] ⟨false, false, none, [freshFrm P [] lvl]⟩).done = false) ∧ + (step P)^[T + 1] ⟨false, false, none, [freshFrm P [] lvl]⟩ + = ⟨true, cmpBit P w, some w, []⟩ ∧ + (step P)^[T + 2] ⟨false, false, none, [freshFrm P [] lvl]⟩ + = ⟨cmpBit P w, cmpBit P w, some w, []⟩ := by + obtain ⟨T, hT, hpos, hdd, w, hwlen, hwval, hend⟩ := + run_frame P hval lvl.length (freshFrm P [] lvl) rfl [] (frmOk_fresh P hval _ [] lvl) false + rw [roundsOf_nil, frameVal_fresh P [] [] lvl] at hwval + have h1 : (step P)^[T + 1] ⟨false, false, none, [freshFrm P [] lvl]⟩ + = ⟨true, cmpBit P w, some w, []⟩ := by + rw [Function.iterate_succ_apply', hend, step_of_empty] + rfl + refine ⟨T, w, hT, hwlen, hwval, hdd, h1, ?_⟩ + rw [show T + 2 = T + 1 + 1 from rfl, Function.iterate_succ_apply', h1, step_of_done] + +end IPM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPStep.lean b/Complexitylib/Classes/Containments/Internal/IPStep.lean new file mode 100644 index 00000000..1b509ffb --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPStep.lean @@ -0,0 +1,477 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.IPEnc + +/-! +# One step of the walk, inside the polynomial-time algebra + +⚠️ Unreviewed by Bolton + +`Complexity.IPM.step` walks the game tree on an inductive state; +`Complexity.IPM.encSst` writes that state on a tape. This file writes the *step* on the tape, out +of the algebra's operations only, and proves the square commutes. + +Everything the step needs from the protocol enters through three arguments: a ruler `mr` whose +length is the message bound, a ruler `cr` whose length is the coin width, and the leaf test `okf`, +which reads the encoded stack below a leaf and a coin string. + +## Main definitions + +- `Complexity.IPM.ipStep` — the encoded step +- `Complexity.IPM.freshEnc` — the frame a node starts from, on the tape + +## Main results + +- `Complexity.IPM.ipStep_encSst` — one encoded step is one abstract step +- `Complexity.IPM.ipStepFn_mem_FP` — and it is polynomial-time +-/ + +@[expose] public section + +namespace Complexity + +namespace IPM + +open Cobham + +/-! ## Reading and writing the encoded state -/ + +/-- The state's four fields, written. -/ +def mkS (d ab r stk : List Bool) : List Bool := pair d (pair ab (pair r stk)) + +/-- A frame's six fields, written. -/ +def mkF (lvl v a sum best body : List Bool) : List Bool := + pair lvl (pair v (pair a (pair sum (pair best body)))) + +@[simp] theorem mkS_eq (s : Sst) : + mkS [s.done] [s.ansBit] (encRet s.ret) (encStk s.stk) = encSst s := rfl + +@[simp] theorem mkF_eq (f : Frm) : mkF f.lvl f.v f.a f.sum f.best f.body = encFrm f := rfl + +/-- The done flag. -/ +def sDone (z : List Bool) : List Bool := fstBlock z + +/-- The answer bit. -/ +def sAns (z : List Bool) : List Bool := fstBlock (sndBlock z) + +/-- The returning value. -/ +def sRet (z : List Bool) : List Bool := fstBlock (sndBlock (sndBlock z)) + +/-- The stack. -/ +def sStk (z : List Bool) : List Bool := sndBlock (sndBlock (sndBlock z)) + +/-- A frame's level. -/ +def fLvl (y : List Bool) : List Bool := fstBlock y + +/-- A frame's verifier counter. -/ +def fV (y : List Bool) : List Bool := fstBlock (sndBlock y) + +/-- A frame's prover counter, or its coin counter. -/ +def fA (y : List Bool) : List Bool := fstBlock (sndBlock (sndBlock y)) + +/-- A frame's running sum. -/ +def fSum (y : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock y))) + +/-- A frame's running maximum. -/ +def fBest (y : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock (sndBlock y)))) + +/-- The body of the encoding of the rounds below a frame. -/ +def fBody (y : List Bool) : List Bool := sndBlock (sndBlock (sndBlock (sndBlock (sndBlock y)))) + +/-- The frame on top of the stack. -/ +def sTop (S : List Bool) : List Bool := fstBlock S + +/-- The stack below the top frame. -/ +def sRest (S : List Bool) : List Bool := sndBlock S + +@[simp] theorem sDone_enc (s : Sst) : sDone (encSst s) = [s.done] := by + rw [sDone, encSst, fstBlock_pair] + +@[simp] theorem sAns_enc (s : Sst) : sAns (encSst s) = [s.ansBit] := by + rw [sAns, encSst, sndBlock_pair, fstBlock_pair] + +@[simp] theorem sRet_enc (s : Sst) : sRet (encSst s) = encRet s.ret := by + rw [sRet, encSst, sndBlock_pair, sndBlock_pair, fstBlock_pair] + +@[simp] theorem sStk_enc (s : Sst) : sStk (encSst s) = encStk s.stk := by + rw [sStk, encSst, sndBlock_pair, sndBlock_pair, sndBlock_pair] + +@[simp] theorem fLvl_enc (f : Frm) : fLvl (encFrm f) = f.lvl := by + rw [fLvl, encFrm, fstBlock_pair] + +@[simp] theorem fV_enc (f : Frm) : fV (encFrm f) = f.v := by + rw [fV, encFrm, sndBlock_pair, fstBlock_pair] + +@[simp] theorem fA_enc (f : Frm) : fA (encFrm f) = f.a := by + rw [fA, encFrm, sndBlock_pair, sndBlock_pair, fstBlock_pair] + +@[simp] theorem fSum_enc (f : Frm) : fSum (encFrm f) = f.sum := by + rw [fSum, encFrm, sndBlock_pair, sndBlock_pair, sndBlock_pair, fstBlock_pair] + +@[simp] theorem fBest_enc (f : Frm) : fBest (encFrm f) = f.best := by + rw [fBest, encFrm, sndBlock_pair, sndBlock_pair, sndBlock_pair, sndBlock_pair, fstBlock_pair] + +@[simp] theorem fBody_enc (f : Frm) : fBody (encFrm f) = f.body := by + rw [fBody, encFrm, sndBlock_pair, sndBlock_pair, sndBlock_pair, sndBlock_pair, sndBlock_pair] + +@[simp] theorem sTop_pair (y S : List Bool) : sTop (pair y S) = y := by + rw [sTop, fstBlock_pair] + +@[simp] theorem sRest_pair (y S : List Bool) : sRest (pair y S) = S := by + rw [sRest, sndBlock_pair] + +theorem sTop_cons (f : Frm) (fs : List Frm) : sTop (encStk (f :: fs)) = encFrm f := by + rw [encStk_cons, sTop_pair] + +theorem sRest_cons (f : Frm) (fs : List Frm) : sRest (encStk (f :: fs)) = encStk fs := by + rw [encStk_cons, sRest_pair] + +/-! ## The encoded step -/ + +/-- The zero of a count's width, from the coin ruler. -/ +def zcOf (cr : List Bool) : List Bool := padTo (cr ++ [false]) [] + +/-- The first coin string, from the coin ruler. -/ +def zkOf (cr : List Bool) : List Bool := padTo cr [] + +/-- The bitstring of `2 ^ t`, from the coin ruler. -/ +def tpOf (cr : List Bool) : List Bool := padTo cr [] ++ [true, false] + +theorem zcOf_eq (cr : List Bool) (P : Params) (h : cr.length = P.t) : + zcOf cr = zeroCount P := by + rw [zcOf, padTo_nil, zeroCount, List.length_append, h] + simp + +theorem zkOf_eq (cr : List Bool) (P : Params) (h : cr.length = P.t) : + zkOf cr = zeroCoin P := by + rw [zkOf, padTo_nil, zeroCoin, h] + +theorem tpOf_eq (cr : List Bool) (P : Params) (h : cr.length = P.t) : + tpOf cr = twoPowBits P.t := by + rw [tpOf, padTo_nil, twoPowBits, h] + +/-- The frame a node starts from, written on the tape. -/ +def freshEnc (cr body lvl : List Bool) : List Bool := + mkF lvl [] (selectHead (emptyFlag lvl) (zkOf cr) []) (zcOf cr) (zcOf cr) body + +theorem freshEnc_eq (cr : List Bool) (P : Params) (h : cr.length = P.t) (body lvl : List Bool) : + freshEnc cr body lvl = encFrm (freshFrm P body lvl) := by + rw [freshEnc, encFrm, freshFrm, zcOf_eq cr P h] + rcases lvl with _ | ⟨b, t⟩ + · rw [emptyFlag_nil, selectHead_cons_true, zkOf_eq cr P h] + simp [mkF] + · rw [emptyFlag_cons, selectHead_cons_false] + simp [mkF] + +/-- The descending half of the step: a leaf tallies one coin string, a branch pushes a subtree. -/ +def ipDescend (cr : List Bool) (okf : List Bool → List Bool → List Bool) + (z : List Bool) : List Bool := + selectHead (emptyFlag (fLvl (sTop (sStk z)))) + (selectHead (bumpFlag (fA (sTop (sStk z)))) + (mkS [false] (sAns z) + (selectHead (okf (sStk z) (fA (sTop (sStk z)))) + (bumpCode (fSum (sTop (sStk z)))) (fSum (sTop (sStk z)))) + (sRest (sStk z))) + (mkS [false] (sAns z) [] + (pair + (mkF (fLvl (sTop (sStk z))) (fV (sTop (sStk z))) (bumpCode (fA (sTop (sStk z)))) + (selectHead (okf (sStk z) (fA (sTop (sStk z)))) + (bumpCode (fSum (sTop (sStk z)))) (fSum (sTop (sStk z)))) + (fBest (sTop (sStk z))) (fBody (sTop (sStk z)))) + (sRest (sStk z))))) + (mkS [false] (sAns z) [] + (pair + (freshEnc cr + (fBody (sTop (sStk z)) ++ encMsg (fV (sTop (sStk z))) ++ encMsg (fA (sTop (sStk z)))) + (dropOne (fLvl (sTop (sStk z))))) + (sStk z))) + +/-- The returning half of the step: advance a counter, or pop with the sum. -/ +def ipReturn (mr cr : List Bool) (z : List Bool) : List Bool := + selectHead (lenLeFlag mr (nextStr (fA (sTop (sStk z))))) + (mkS [false] (sAns z) [] + (pair + (mkF (fLvl (sTop (sStk z))) (fV (sTop (sStk z))) (nextStr (fA (sTop (sStk z)))) + (fSum (sTop (sStk z))) (maxBits (fBest (sTop (sStk z))) (sRet z)) + (fBody (sTop (sStk z)))) + (sRest (sStk z)))) + (selectHead (lenLeFlag mr (nextStr (fV (sTop (sStk z))))) + (mkS [false] (sAns z) [] + (pair + (mkF (fLvl (sTop (sStk z))) (nextStr (fV (sTop (sStk z)))) [] + (addBits (fSum (sTop (sStk z))) (maxBits (fBest (sTop (sStk z))) (sRet z))) + (zcOf cr) (fBody (sTop (sStk z)))) + (sRest (sStk z)))) + (mkS [false] (sAns z) + (addBits (fSum (sTop (sStk z))) (maxBits (fBest (sTop (sStk z))) (sRet z))) + (sRest (sStk z)))) + +/-- **One step of the walk, on the tape.** -/ +def ipStep (mr cr : List Bool) (okf : List Bool → List Bool → List Bool) + (z : List Bool) : List Bool := + selectHead (sDone z) + (mkS (sAns z) (sAns z) (sRet z) (sStk z)) + (selectHead (emptyFlag (sStk z)) + (mkS [true] (ltFlag (tpOf cr) (false :: sRet z)) (sRet z) (sStk z)) + (selectHead (emptyFlag (sRet z)) + (ipDescend cr okf z) + (ipReturn mr cr z))) + +/-- The state the walk starts from, on the tape. -/ +def ipInit (cr rr : List Bool) : List Bool := + mkS [false] [false] [] (pair (freshEnc cr [] rr) []) + +theorem ipInit_eq (cr : List Bool) (P : Params) (h : cr.length = P.t) (rr : List Bool) : + ipInit cr rr = encSst ⟨false, false, none, [freshFrm P [] rr]⟩ := by + rw [ipInit, freshEnc_eq cr P h] + rfl + +theorem ipInitFn_mem_FP {CR RR : List Bool → List Bool} (hcr : CR ∈ FP) (hrr : RR ∈ FP) : + (fun z => ipInit (CR z) (RR z)) ∈ FP := by + have hzc : (fun z => zcOf (CR z)) ∈ FP := + padToFn_mem_FP (Cobham.appendFn_mem_FP hcr (constFn_mem_FP [false])) (constFn_mem_FP []) + have hzk : (fun z => zkOf (CR z)) ∈ FP := padToFn_mem_FP hcr (constFn_mem_FP []) + have hfresh : (fun z => freshEnc (CR z) [] (RR z)) ∈ FP := + Cobham.pairFn_mem_FP hrr (Cobham.pairFn_mem_FP (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hrr) hzk (constFn_mem_FP [])) + (Cobham.pairFn_mem_FP hzc (Cobham.pairFn_mem_FP hzc (constFn_mem_FP []))))) + exact Cobham.pairFn_mem_FP (constFn_mem_FP [false]) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) + (Cobham.pairFn_mem_FP (constFn_mem_FP []) + (Cobham.pairFn_mem_FP hfresh (constFn_mem_FP [])))) + +/-! ## The square commutes -/ + +theorem lenLeFlag_true (mr u : List Bool) (h : u.length ≤ mr.length) : + lenLeFlag mr u = [true] := (lenLeFlag_eq_true_iff mr u).mpr h + +theorem lenLeFlag_false (mr u : List Bool) (h : ¬ u.length ≤ mr.length) : + lenLeFlag mr u = [false] := by + rcases lenLeFlag_flag mr u with hh | hh + · exact absurd ((lenLeFlag_eq_true_iff mr u).mp hh) h + · exact hh + +/-- **One encoded step is one abstract step.** -/ +theorem ipStep_encSst (P : Params) (mr cr : List Bool) (hm : mr.length = P.m) + (hc : cr.length = P.t) (okf : List Bool → List Bool → List Bool) + (D : ℕ) + (hokf : ∀ (f : Frm) (fs : List Frm), BodyOk (f :: fs) → (f :: fs).length ≤ D → + ∀ u : List Bool, okf (encStk (f :: fs)) u = [P.ok (roundsOf fs) u]) + (s : Sst) (h : EncOk P D s) : + ipStep mr cr okf (encSst s) = encSst (step P s) := by + obtain ⟨d, a, r, stk⟩ := s + cases d + · cases stk with + | nil => + obtain ⟨b, rfl⟩ : ∃ b, r = some b := by + cases r with + | none => exact absurd rfl (h.stkOk rfl) + | some b => exact ⟨b, rfl⟩ + have hblen : b.length = P.t + 1 := h.retLen b rfl + have hcmp : ltFlag (tpOf cr) (false :: b) = [cmpBit P b] := by + rw [tpOf_eq cr P hc, cmpBit, + ltFlag_eq _ _ (by rw [List.length_cons, hblen, twoPowBits_length])] + rw [step_of_empty, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_nil, emptyFlag_nil, + selectHead_cons_true, sRet_enc, encRet_some, sAns_enc, hcmp] + rfl + | cons f fs => + cases r with + | none => + by_cases hl : f.lvl = [] + · have hokv := hokf f fs h.bodyOk (StkDepth.length_le h.depthOk) f.a + rw [encStk_cons] at hokv + by_cases hov : bumpOver f.a = true + · rw [step_leaf_last P a f fs hl hov, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_cons, + emptyFlag_pair, sRet_enc, encRet_none, emptyFlag_nil, selectHead_cons_true, + ipDescend, sTop_pair, sRest_pair, fLvl_enc, fA_enc, fSum_enc, sAns_enc, hl, + hokv, bumpFlag_eq, hov, bumpCode_eq] + cases hokb : P.ok (roundsOf fs) f.a <;> simp [encSst, mkS] + · have hovf : bumpOver f.a = false := by simpa using hov + rw [step_leaf_next P a f fs hl hovf, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_cons, + emptyFlag_pair, sRet_enc, encRet_none, emptyFlag_nil, selectHead_cons_true, + ipDescend, sTop_pair, sRest_pair, fLvl_enc, fA_enc, fSum_enc, fV_enc, + fBest_enc, fBody_enc, sAns_enc, hl, hokv, bumpFlag_eq, hovf, bumpCode_eq] + cases hokb : P.ok (roundsOf fs) f.a <;> simp [encSst, mkS, mkF, encFrm] + · obtain ⟨c, tl, hlc⟩ : ∃ c tl, f.lvl = c :: tl := by + cases hcc : f.lvl with + | nil => exact absurd hcc hl + | cons c tl => exact ⟨c, tl, rfl⟩ + rw [step_push P a f fs hl, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_cons, + emptyFlag_pair, sRet_enc, encRet_none, emptyFlag_nil, selectHead_cons_true, + ipDescend, sTop_pair, fLvl_enc, sAns_enc, hlc, emptyFlag_cons, + selectHead_cons_false] + rw [dropOne, ← hlc, freshEnc_eq cr P hc] + rw [childFrm] + simp [encSst, mkS, encStk_cons] + | some w => + have hew : emptyFlag w = [false] := by + obtain ⟨b0, t0, rfl⟩ : ∃ b0 t0, w = b0 :: t0 := by + cases hcw : w with + | nil => exact absurd (encRet_ne_nil h rfl) (by simp [hcw]) + | cons b0 t0 => exact ⟨b0, t0, rfl⟩ + exact emptyFlag_cons _ _ + by_cases hA : (nextStr f.a).length ≤ P.m + · have h1 : lenLeFlag mr (nextStr f.a) = [true] := + lenLeFlag_true mr (nextStr f.a) (by rw [hm]; exact hA) + rw [step_ret_more_a P a f fs w hA, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_cons, + emptyFlag_pair, sRet_enc, encRet_some, hew, selectHead_cons_false, ipReturn, + sTop_pair, sRest_pair, fA_enc, fV_enc, fLvl_enc, fSum_enc, fBest_enc, + fBody_enc, sAns_enc, h1, selectHead_cons_true] + simp [encSst, mkS, mkF, encFrm] + · have h1 : lenLeFlag mr (nextStr f.a) = [false] := + lenLeFlag_false mr (nextStr f.a) (by rw [hm]; exact hA) + by_cases hV : (nextStr f.v).length ≤ P.m + · have h2 : lenLeFlag mr (nextStr f.v) = [true] := + lenLeFlag_true mr (nextStr f.v) (by rw [hm]; exact hV) + rw [step_ret_more_v P a f fs w hA hV, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_cons, + emptyFlag_pair, sRet_enc, encRet_some, hew, selectHead_cons_false, ipReturn, + sTop_pair, sRest_pair, fA_enc, fV_enc, fLvl_enc, fSum_enc, fBest_enc, + fBody_enc, sAns_enc, h1, h2, selectHead_cons_true] + rw [zcOf_eq cr P hc] + simp [encSst, mkS, mkF, encFrm] + · have h2 : lenLeFlag mr (nextStr f.v) = [false] := + lenLeFlag_false mr (nextStr f.v) (by rw [hm]; exact hV) + rw [step_ret_pop P a f fs w hA hV, ipStep] + simp only [sDone_enc, selectHead_cons_false, sStk_enc, encStk_cons, + emptyFlag_pair, sRet_enc, encRet_some, hew, selectHead_cons_false, ipReturn, + sTop_pair, sRest_pair, fA_enc, fV_enc, fLvl_enc, fSum_enc, fBest_enc, + fBody_enc, sAns_enc, h1, h2] + simp [encSst, mkS] + · rw [step_of_done, ipStep] + simp only [sDone_enc, selectHead_cons_true, sAns_enc, sRet_enc, sStk_enc] + rfl + +/-- **And so is any number of steps.** -/ +theorem ipStep_iterate (P : Params) (mr cr : List Bool) (hm : mr.length = P.m) + (hc : cr.length = P.t) (okf : List Bool → List Bool → List Bool) + (D : ℕ) + (hokf : ∀ (f : Frm) (fs : List Frm), BodyOk (f :: fs) → (f :: fs).length ≤ D → + ∀ u : List Bool, okf (encStk (f :: fs)) u = [P.ok (roundsOf fs) u]) : + ∀ (j : ℕ) (s : Sst), EncOk P D s → + (ipStep mr cr okf)^[j] (encSst s) = encSst ((step P)^[j] s) := by + intro j + induction j with + | zero => intro s _; rfl + | succ j ih => + intro s h + rw [Function.iterate_succ_apply, Function.iterate_succ_apply, + ipStep_encSst P mr cr hm hc okf D hokf s h] + exact ih _ (step_encOk P D h) + +/-! ## The encoded step is polynomial-time -/ + +theorem ipStepFn_mem_FP {A B C : List Bool → List Bool} + (hA : A ∈ FP) (hB : B ∈ FP) (hC : C ∈ FP) + {OK : List Bool → List Bool → List Bool → List Bool} + (hok : ∀ {u v : List Bool → List Bool}, u ∈ FP → v ∈ FP → + (fun z => OK z (u z) (v z)) ∈ FP) : + (fun z => ipStep (A z) (B z) (OK z) (C z)) ∈ FP := by + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.fstBlock_mem_FP + simpa [Function.comp] using this + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + intro a ha + have := mem_FP_comp ha Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + have hcons : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => false :: a z) ∈ FP := by + intro a ha + have := mem_FP_comp ha (Cobham.cons_mem_FP false) + simpa [Function.comp] using this + -- the state's fields + have hD : (fun z => sDone (C z)) ∈ FP := hfst hC + have hAns : (fun z => sAns (C z)) ∈ FP := hfst (hsnd hC) + have hR : (fun z => sRet (C z)) ∈ FP := hfst (hsnd (hsnd hC)) + have hS : (fun z => sStk (C z)) ∈ FP := hsnd (hsnd (hsnd hC)) + -- the top frame's fields + have hT : (fun z => sTop (sStk (C z))) ∈ FP := hfst hS + have hRest : (fun z => sRest (sStk (C z))) ∈ FP := hsnd hS + have hLvl : (fun z => fLvl (sTop (sStk (C z)))) ∈ FP := hfst hT + have hV : (fun z => fV (sTop (sStk (C z)))) ∈ FP := hfst (hsnd hT) + have hAa : (fun z => fA (sTop (sStk (C z)))) ∈ FP := hfst (hsnd (hsnd hT)) + have hSum : (fun z => fSum (sTop (sStk (C z)))) ∈ FP := hfst (hsnd (hsnd (hsnd hT))) + have hBest : (fun z => fBest (sTop (sStk (C z)))) ∈ FP := hfst (hsnd (hsnd (hsnd (hsnd hT)))) + have hBody : (fun z => fBody (sTop (sStk (C z)))) ∈ FP := hsnd (hsnd (hsnd (hsnd (hsnd hT)))) + -- the constants built from the coin ruler + have hzc : (fun z => zcOf (B z)) ∈ FP := + padToFn_mem_FP (Cobham.appendFn_mem_FP hB (constFn_mem_FP [false])) (constFn_mem_FP []) + have hzk : (fun z => zkOf (B z)) ∈ FP := padToFn_mem_FP hB (constFn_mem_FP []) + have htp : (fun z => tpOf (B z)) ∈ FP := + Cobham.appendFn_mem_FP (padToFn_mem_FP hB (constFn_mem_FP [])) (constFn_mem_FP [true, false]) + -- the pieces of the descending half + have hnew : (fun z => selectHead (OK z (sStk (C z)) (fA (sTop (sStk (C z))))) + (bumpCode (fSum (sTop (sStk (C z))))) (fSum (sTop (sStk (C z))))) ∈ FP := + Cobham.selectHeadFn_mem_FP (hok hS hAa) (bumpCodeFn_mem_FP hSum) hSum + have hnb : (fun z => fBody (sTop (sStk (C z))) ++ encMsg (fV (sTop (sStk (C z)))) + ++ encMsg (fA (sTop (sStk (C z))))) ∈ FP := + Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP hBody (encMsgFn_mem_FP hV)) + (encMsgFn_mem_FP hAa) + have hfresh : (fun z => freshEnc (B z) + (fBody (sTop (sStk (C z))) ++ encMsg (fV (sTop (sStk (C z)))) + ++ encMsg (fA (sTop (sStk (C z))))) + (dropOne (fLvl (sTop (sStk (C z)))))) ∈ FP := by + refine Cobham.pairFn_mem_FP (dropOneFn_mem_FP hLvl) (Cobham.pairFn_mem_FP + (constFn_mem_FP []) (Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP (dropOneFn_mem_FP hLvl)) hzk + (constFn_mem_FP [])) + (Cobham.pairFn_mem_FP hzc (Cobham.pairFn_mem_FP hzc hnb)))) + have hdesc : (fun z => ipDescend (B z) (OK z) (C z)) ∈ FP := + Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hLvl) + (Cobham.selectHeadFn_mem_FP (bumpFlagFn_mem_FP hAa) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP hAns + (Cobham.pairFn_mem_FP hnew hRest))) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP hAns + (Cobham.pairFn_mem_FP (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP hLvl (Cobham.pairFn_mem_FP hV + (Cobham.pairFn_mem_FP (bumpCodeFn_mem_FP hAa) + (Cobham.pairFn_mem_FP hnew (Cobham.pairFn_mem_FP hBest hBody))))) + hRest))))) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP hAns + (Cobham.pairFn_mem_FP (constFn_mem_FP []) (Cobham.pairFn_mem_FP hfresh hS)))) + -- the pieces of the returning half + have hmax : (fun z => maxBits (fBest (sTop (sStk (C z)))) (sRet (C z))) ∈ FP := + maxBitsFn_mem_FP hBest hR + have hadd : (fun z => addBits (fSum (sTop (sStk (C z)))) + (maxBits (fBest (sTop (sStk (C z)))) (sRet (C z)))) ∈ FP := addBitsFn_mem_FP hSum hmax + have hret : (fun z => ipReturn (A z) (B z) (C z)) ∈ FP := + Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hA (nextStrFn_mem_FP hAa)) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP hAns + (Cobham.pairFn_mem_FP (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP hLvl (Cobham.pairFn_mem_FP hV + (Cobham.pairFn_mem_FP (nextStrFn_mem_FP hAa) + (Cobham.pairFn_mem_FP hSum (Cobham.pairFn_mem_FP hmax hBody))))) + hRest)))) + (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hA (nextStrFn_mem_FP hV)) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP hAns + (Cobham.pairFn_mem_FP (constFn_mem_FP []) + (Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP hLvl (Cobham.pairFn_mem_FP (nextStrFn_mem_FP hV) + (Cobham.pairFn_mem_FP (constFn_mem_FP []) + (Cobham.pairFn_mem_FP hadd (Cobham.pairFn_mem_FP hzc hBody))))) + hRest)))) + (Cobham.pairFn_mem_FP (constFn_mem_FP [false]) (Cobham.pairFn_mem_FP hAns + (Cobham.pairFn_mem_FP hadd hRest)))) + exact Cobham.selectHeadFn_mem_FP hD + (Cobham.pairFn_mem_FP hAns (Cobham.pairFn_mem_FP hAns (Cobham.pairFn_mem_FP hR hS))) + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hS) + (Cobham.pairFn_mem_FP (constFn_mem_FP [true]) + (Cobham.pairFn_mem_FP (ltFlagFn_mem_FP htp (hcons hR)) + (Cobham.pairFn_mem_FP hR hS))) + (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hR) hdesc hret)) + +end IPM + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/IPWalk.lean b/Complexitylib/Classes/Containments/Internal/IPWalk.lean new file mode 100644 index 00000000..12504ba3 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/IPWalk.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.IPStep +public import Complexitylib.Classes.Containments.Internal.IPGameTree + +/-! +# The walk runs on the protocol's tree + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.IPSem` builds a machine that walks an abstract tree, +parametric in a single test — *does this coin string make the verifier accept below these rounds*. +This file supplies that test from a protocol and checks that the tree the machine walks is the +protocol's own. + +## Main definitions + +- `Complexity.Protocol.walkParams` — the parameters the walk runs on + +## Main results + +- `Complexity.Protocol.treeVal_eq_gvalR` — the abstract tree is the protocol's game tree +- `Complexity.Protocol.treeVal_le_two_pow` — its values fit in the coin space +- `Complexity.Protocol.ipStep_iterate_walk` — the encoded orbit is the abstract one +-/ + +@[expose] public section + +namespace Complexity + +namespace Protocol + +open Classical in +/-- The parameters the walk runs on: the message bound, the coin width, and the leaf test. -/ +noncomputable def walkParams (prot : Protocol) (x : List Bool) : IPM.Params where + m := prot.msgLen x.length + t := prot.coins x.length + ok := fun ps s => + decide (prot.replay x s ps [] = true ∧ + pair (pair x s) (false :: (encBodyR ps ++ [true])) ∈ prot.verdict) + +open Classical in +/-- **The abstract tree is the protocol's game tree.** -/ +theorem treeVal_eq_gvalR (prot : Protocol) (x : List Bool) : + ∀ (n : ℕ) (ps : List (List Bool × List Bool)), + IPM.treeVal (prot.walkParams x) n ps = prot.gvalR x (prot.coins x.length) n ps := by + classical + intro n + induction n with + | zero => + intro ps + rw [IPM.treeVal_zero, gvalR_zero_enum] + refine congrArg Finset.card (Finset.filter_congr fun k _ => ?_) + show ((prot.walkParams x).ok ps (IPM.coinOf (prot.walkParams x) k) = true) ↔ _ + rw [walkParams, IPM.coinOf, IPM.zeroCoin] + simp + | succ n ih => + intro ps + rw [IPM.treeVal, gvalR_succ_enum] + refine Finset.sum_congr rfl fun i _ => ?_ + refine Finset.sup_congr rfl fun j _ => ?_ + rw [ih, IPM.msgOf, IPM.msgOf] + +open Classical in +theorem treeVal_le_two_pow (prot : Protocol) (x : List Bool) (n : ℕ) + (ps : List (List Bool × List Bool)) : + IPM.treeVal (prot.walkParams x) n ps ≤ 2 ^ (prot.walkParams x).t := by + rw [treeVal_eq_gvalR] + exact gvalR_le_two_pow prot x _ n ps + +/-! ## The walk decides membership -/ + +open Classical in +/-- The verdict the walk finishes with is membership. -/ +theorem cmpBit_eq_true_iff {L : Language} (prot : Protocol) (x : List Bool) + (hcomp : ∀ y ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen y.length) ∧ + 2 / 3 ≤ eventProb (prot.acceptEvent S y)) + (hsound : ∀ y ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen y.length) → + eventProb (prot.acceptEvent S y) ≤ 1 / 3) + (w : List Bool) (hwlen : w.length = (prot.walkParams x).t + 1) + (hwval : binValLE w = IPM.treeVal (prot.walkParams x) (prot.rounds x.length) []) : + IPM.cmpBit (prot.walkParams x) w = true ↔ x ∈ L := by + classical + have hlen : (false :: w).length = (twoPowBits (prot.walkParams x).t).length := by + rw [List.length_cons, hwlen, twoPowBits_length] + have h1 : IPM.cmpBit (prot.walkParams x) w = true + ↔ ltFlag (twoPowBits (prot.walkParams x).t) (false :: w) = [true] := by + rw [IPM.cmpBit, ltFlag_eq _ _ hlen] + simp + rw [h1, ← two_pow_lt_two_mul_iff (prot.walkParams x).t w hwlen, hwval, treeVal_eq_gvalR, + gvalR_root] + exact (Protocol.mem_iff_gval prot x hcomp hsound).symm + +open Classical in +/-- **The walk decides membership.** From a single fresh frame of `rounds(|x|)` levels the machine +keeps its flag down, raises it on the next step, and one step later the flag *is* the membership +bit. -/ +theorem walk_decides {L : Language} (prot : Protocol) + (hcomp : ∀ y ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen y.length) ∧ + 2 / 3 ≤ eventProb (prot.acceptEvent S y)) + (hsound : ∀ y ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen y.length) → + eventProb (prot.acceptEvent S y) ≤ 1 / 3) + (x : List Bool) (lvl : List Bool) (hlvl : lvl.length = prot.rounds x.length) : + ∃ T ≤ IPM.runBound (prot.walkParams x) (prot.rounds x.length), + (∀ j ≤ T, ((IPM.step (prot.walkParams x))^[j] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] lvl]⟩).done = false) ∧ + ((IPM.step (prot.walkParams x))^[T + 1] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] lvl]⟩).done = true ∧ + ((((IPM.step (prot.walkParams x))^[T + 2] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] lvl]⟩).done = true) + ↔ x ∈ L) := by + classical + obtain ⟨T, w, hT, hwlen, hwval, hdd, h1, h2⟩ := + IPM.run_top (prot.walkParams x) (treeVal_le_two_pow prot x) lvl + rw [hlvl] at hT hwval + refine ⟨T, hT, hdd, ?_, ?_⟩ + · rw [h1] + · rw [h2] + exact cmpBit_eq_true_iff prot x hcomp hsound w hwlen hwval + +/-- **The encoded orbit is the abstract one.** -/ +theorem ipStep_iterate_walk (prot : Protocol) (x : List Bool) (mr cr : List Bool) + (hm : mr.length = (prot.walkParams x).m) (hc : cr.length = (prot.walkParams x).t) + (okf : List Bool → List Bool → List Bool) + (lvl : List Bool) + (hokf : ∀ (f : IPM.Frm) (fs : List IPM.Frm), IPM.BodyOk (f :: fs) → + (f :: fs).length ≤ lvl.length + 1 → ∀ u : List Bool, + okf (IPM.encStk (f :: fs)) u = [(prot.walkParams x).ok (IPM.roundsOf fs) u]) + (j : ℕ) : + (IPM.ipStep mr cr okf)^[j] + (IPM.encSst ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] lvl]⟩) + = IPM.encSst ((IPM.step (prot.walkParams x))^[j] + ⟨false, false, none, [IPM.freshFrm (prot.walkParams x) [] lvl]⟩) := + IPM.ipStep_iterate (prot.walkParams x) mr cr hm hc okf (lvl.length + 1) hokf j _ + (IPM.encOk_start (prot.walkParams x) lvl) + +end Protocol + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/PVerdict.lean b/Complexitylib/Classes/Containments/Internal/PVerdict.lean new file mode 100644 index 00000000..cfe74031 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/PVerdict.lean @@ -0,0 +1,372 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Classes.P.DecisionFn + +/-! +# A language in `P` has a polynomial-time verdict function + +⚠️ Unreviewed by Bolton + +`Complexity.mem_P_of_decisionFn` puts a language in `P` given a verdict function in `FP`. This +file is the converse: a language in `P` *has* such a function. That is what a development needs +whenever a polynomial-time predicate has to be consulted from inside another polynomial-time +computation — the predicate arrives as a machine, and only a function can be composed. + +The function is the machine's own run, carried out inside the algebra: `Cobham.initFn` encodes +the initial configuration, `Cobham.stepFn` advances it, and after the machine's time bound many +steps `Complexity.acceptFlag` reads the verdict cell off the resulting code. Halted +configurations are fixed points of the encoded step, so running for exactly the time bound is +safe however early the machine stops. + +## Main definitions + +- `Complexity.TM.stepOrStay`, `Complexity.TM.runTo` — the run as a total iteration +- `Complexity.codeStep` — the encoded step with its ruler carried alongside +- `Complexity.pVerdict` — the verdict function + +## Main results + +- `Complexity.runCode_eq` — the encoded run is the code of the real one +- `Complexity.pVerdict_eq_true_iff` — the verdict function decides the language +- `Complexity.pVerdict_mem_FP` — and it is polynomial-time +- `Complexity.exists_decisionFn_of_mem_P` — hence every language in `P` has one +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The run as a total iteration -/ + +namespace TM + +/-- One step of a deterministic machine, staying put once it has halted. -/ +def stepOrStay (tm : TM k) (c : Cfg k tm.Q) : Cfg k tm.Q := (tm.step c).getD c + +theorem stepOrStay_of_halted (tm : TM k) {c : Cfg k tm.Q} (h : c.state = tm.qhalt) : + tm.stepOrStay c = c := by + rw [stepOrStay, TM.step, if_pos h] + rfl + +theorem stepOrStay_of_step (tm : TM k) {c c' : Cfg k tm.Q} (h : tm.step c = some c') : + tm.stepOrStay c = c' := by + rw [stepOrStay, h] + rfl + +/-- The configuration after `n` steps, halted ones counting as no-ops. -/ +def runTo (tm : TM k) (x : List Bool) (n : ℕ) : Cfg k tm.Q := + (tm.stepOrStay)^[n] (tm.initCfg x) + +@[simp] theorem runTo_zero (tm : TM k) (x : List Bool) : tm.runTo x 0 = tm.initCfg x := rfl + +theorem runTo_succ (tm : TM k) (x : List Bool) (n : ℕ) : + tm.runTo x (n + 1) = tm.stepOrStay (tm.runTo x n) := by + rw [runTo, runTo, Function.iterate_succ_apply'] + +/-- A bounded walk is exactly that many total steps. -/ +theorem iterate_stepOrStay_of_reachesIn (tm : TM k) : + ∀ {t : ℕ} {c c' : Cfg k tm.Q}, tm.reachesIn t c c' → (tm.stepOrStay)^[t] c = c' := by + intro t c c' h + induction h with + | zero => rfl + | step hstep _ ih => + rw [Function.iterate_succ_apply, stepOrStay_of_step tm hstep] + exact ih + +/-- A halted configuration is a fixed point of the total step. -/ +theorem iterate_stepOrStay_halted (tm : TM k) {c : Cfg k tm.Q} (h : c.state = tm.qhalt) : + ∀ n, (tm.stepOrStay)^[n] c = c := by + intro n + induction n with + | zero => rfl + | succ n ih => rw [Function.iterate_succ_apply, stepOrStay_of_halted tm h, ih] + +/-- Once the machine has halted, the run stays where it stopped. -/ +theorem runTo_of_halted (tm : TM k) (x : List Bool) {t : ℕ} {c : Cfg k tm.Q} + (h : tm.reachesIn t (tm.initCfg x) c) (hh : c.state = tm.qhalt) {n : ℕ} (hn : t ≤ n) : + tm.runTo x n = c := by + have ht : (tm.stepOrStay)^[t] (tm.initCfg x) = c := iterate_stepOrStay_of_reachesIn tm h + rw [runTo, show n = n - t + t from by omega, Function.iterate_add_apply, ht, + iterate_stepOrStay_halted tm hh] + +/-- Every point of the run is reached by a walk no longer than the index. -/ +theorem exists_reachesIn_runTo (tm : TM k) (x : List Bool) : + ∀ n, ∃ t ≤ n, tm.reachesIn t (tm.initCfg x) (tm.runTo x n) := by + intro n + induction n with + | zero => exact ⟨0, le_rfl, TM.reachesIn.zero⟩ + | succ n ih => + obtain ⟨t, ht, hr⟩ := ih + rw [runTo_succ] + rcases hs : tm.step (tm.runTo x n) with _ | c' + · refine ⟨t, by omega, ?_⟩ + rw [stepOrStay, hs] + exact hr + · refine ⟨t + 1, by omega, ?_⟩ + rw [stepOrStay_of_step tm hs] + exact tm.reachesIn_trans hr (TM.reachesIn.step hs TM.reachesIn.zero) + +/-- The left-end markers survive any walk. -/ +theorem startInvariant_of_reachesIn (tm : TM k) : + ∀ {t : ℕ} {c c' : Cfg k tm.Q}, tm.reachesIn t c c' → + c.input.StartInvariant → (∀ i, (c.work i).StartInvariant) → c.output.StartInvariant → + c'.input.StartInvariant ∧ (∀ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + intro t c c' h + induction h with + | zero => exact fun a b c => ⟨a, b, c⟩ + | step hstep _ ih => + intro hi hw ho + obtain ⟨hi', hw', ho'⟩ := Tape.StartInvariant.step _ hstep hi hw ho + exact ih hi' hw' ho' + +/-- Every point of the run is inside the window a time bound gives. -/ +theorem codeInv_runTo (tm : TM k) (x : List Bool) {W n : ℕ} (hn : n ≤ W) : + CodeInv W (tm.runTo x n) := by + obtain ⟨t, ht, hr⟩ := exists_reachesIn_runTo tm x n + obtain ⟨hi, hw, ho⟩ := startInvariant_of_reachesIn tm hr + (Tape.StartInvariant.init_ofBool x) (fun _ => Tape.StartInvariant.init_nil) + Tape.StartInvariant.init_nil + obtain ⟨hin, hout, hwork⟩ := TM.head_le_of_reachesIn tm hr + refine ⟨fun s hs => ?_, fun s hs => ?_⟩ <;> + · rw [cfgTapes, List.mem_cons, List.mem_cons, List.mem_ofFn] at hs + rcases hs with rfl | rfl | ⟨i, rfl⟩ + · first | exact hi | omega + · first | exact ho | omega + · first | exact hw i | (have := hwork i; omega) + +end TM + +/-! ## The encoded run -/ + +/-- The encoded step, carrying its ruler alongside the code. -/ +noncomputable def codeStep (tm : TM k) (w : List Bool) : List Bool := + pair (fstBlock w) (stepFn tm (fstBlock w) (sndBlock w)) + +theorem codeStep_pair (tm : TM k) (R z : List Bool) : + codeStep tm (pair R z) = pair R (stepFn tm R z) := by + rw [codeStep, fstBlock_pair, sndBlock_pair] + +theorem codeStep_iterate (tm : TM k) (R z : List Bool) : + ∀ n, (codeStep tm)^[n] (pair R z) = pair R ((stepFn tm R)^[n] z) := by + intro n + induction n generalizing z with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, codeStep_pair, ih, Function.iterate_succ_apply] + +theorem codeStep_mem_FP (tm : TM k) : codeStep tm ∈ FP := by + have hfst : (fun z : List Bool => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hstep : (fun w => stepFn tm (fstBlock w) (sndBlock w)) ∈ FP := + binFn_mem_FP (g := stepFn tm) + (Cobham.stepFn_mem tm (Cobham.proj 0) (Cobham.proj 1)) hfst hsnd + exact Cobham.pairFn_mem_FP hfst hstep + +/-- **The encoded run is the code of the real one.** -/ +theorem runCode_eq (tm : TM k) (W : ℕ) (hq : Fintype.card tm.Q ≤ blockWidth W) + (x : List Bool) (hx : x.length ≤ W) : + ∀ n ≤ W, (stepFn tm (blockRuler W))^[n] (Cobham.initFn tm (blockRuler W) x) + = Cobham.cfgCode W (tm.runTo x n) := by + intro n + induction n with + | zero => + intro _ + rw [Function.iterate_zero_apply, Cobham.initFn_eq tm W x hx, TM.runTo_zero] + | succ n ih => + intro hn + have hinv : CodeInv W (tm.runTo x n) := TM.codeInv_runTo tm x (by omega) + have hheads : ∀ t ∈ cfgTapes (tm.runTo x n), t.head ≤ W := hinv.head + rw [Function.iterate_succ_apply', ih (by omega), TM.runTo_succ] + rcases hs : tm.step (tm.runTo x n) with _ | c' + · have hhalt : (tm.runTo x n).state = tm.qhalt := by + by_contra hc + simp [TM.step, hc] at hs + rw [TM.stepOrStay, hs] + exact stepFn_halted tm hhalt hq hheads + · rw [TM.stepOrStay_of_step tm hs] + exact stepFn_eq tm hs hq hheads (hinv.start _ (by simp [cfgTapes])) + (fun i => hinv.start _ (by + rw [cfgTapes] + exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ (List.mem_ofFn.mpr ⟨i, rfl⟩)))) + (stepActs_forall₂ tm _ hinv.start hheads) + +/-! ## Reading the verdict off a code -/ + +/-- **The test decides acceptance**, for a deterministic machine. -/ +theorem acceptFlag_cfgCode_tm (tm : TM k) (W : ℕ) (c : Cfg k tm.Q) + (hq : Fintype.card tm.Q ≤ blockWidth W) (hinv : CodeInv W c) (hW : 1 ≤ W) + (ruler : List Bool) (hruler : W ≤ ruler.length) : + acceptFlag (stateCode tm.qhalt) (blockRuler W) ruler (Cobham.cfgCode W c) = [true] ↔ + c.state = tm.qhalt ∧ c.output.cells 1 = Γ.one := by + have hout : c.output.StartInvariant := hinv.start _ (by simp [cfgTapes]) + have houth : c.output.head ≤ W := hinv.head _ (by simp [cfgTapes]) + have hstate : (blockAt (blockRuler W) (Cobham.cfgCode W c) 0).take + (stateCode tm.qhalt).length = stateCode c.state := by + rw [stateCode_length] + exact state_of_cfgCode W c hq + have hverdict : verdictSym (blockRuler W) + (rewindCode (blockRuler W) ruler (outPair (blockRuler W) (Cobham.cfgCode W c))) + = symCode (c.output.cells 1) := by + rw [outPair_cfgCode, rewindCode_pairCode W c.output hout houth ruler hruler, + verdictSym_rewound W c.output hW] + rw [acceptFlag, andBit_eq_true_iff (eqFlag_flag _ _) (eqFlag_flag _ _), + eqFlag_eq_true_iff, eqFlag_eq_true_iff, hstate, hverdict] + constructor + · rintro ⟨h1, h2⟩ + exact ⟨stateCode_injective h1, symCode_injective h2⟩ + · rintro ⟨h1, h2⟩ + exact ⟨by rw [h1], by rw [h2]⟩ + +/-! ## The verdict function -/ + +/-- The verdict a deterministic machine reaches, computed inside the algebra. -/ +noncomputable def pVerdict (tm : TM k) (wp tp : Polynomial ℕ) (x : List Bool) : List Bool := + acceptFlag (stateCode tm.qhalt) (polyRuler (2 * wp + 2) x) + (wideRuler (codeBlocks k) (polyRuler (2 * wp + 2) x)) + (sndBlock ((codeStep tm)^[(polyRuler tp x).length] + (pair (polyRuler (2 * wp + 2) x) + (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x)))) + +theorem pVerdict_flag (tm : TM k) (wp tp : Polynomial ℕ) (x : List Bool) : + pVerdict tm wp tp x = [true] ∨ pVerdict tm wp tp x = [false] := + acceptFlag_flag _ _ _ _ + +/-- **The verdict function decides the language.** -/ +theorem pVerdict_eq_true_iff (tm : TM k) {L : Language} (wp tp : Polynomial ℕ) + (hdec : tm.DecidesInTime L fun n => tp.eval n) + (hwp : ∀ n, n + tp.eval n + 1 ≤ wp.eval n) + (hq : ∀ n, Fintype.card tm.Q ≤ blockWidth (wp.eval n)) (x : List Bool) : + pVerdict tm wp tp x = [true] ↔ x ∈ L := by + set W := wp.eval x.length with hW + have hbound := hwp x.length + have hxW : x.length ≤ W := by omega + have hW1 : 1 ≤ W := by omega + have hR : polyRuler (2 * wp + 2) x = blockRuler W := (blockRuler_eq_polyRuler wp x).symm + have hruler : W ≤ (wideRuler (codeBlocks k) (blockRuler W)).length := by + rw [wideRuler_length, blockRuler_length, blockWidth] + have hcb : 1 ≤ codeBlocks k := by rw [codeBlocks]; omega + calc W ≤ 1 * (2 * (W + 1)) := by omega + _ ≤ codeBlocks k * (2 * (W + 1)) := Nat.mul_le_mul_right _ hcb + obtain ⟨c, t, htT, hreach, hhalt, hone, hzero⟩ := hdec x + have hrun : tm.runTo x (tp.eval x.length) = c := + TM.runTo_of_halted tm x hreach hhalt (by simpa using htT) + have hcode : sndBlock ((codeStep tm)^[(polyRuler tp x).length] + (pair (polyRuler (2 * wp + 2) x) (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x))) + = Cobham.cfgCode W c := by + rw [codeStep_iterate, sndBlock_pair, polyRuler_length, hR, + runCode_eq tm W (hq x.length) x hxW _ (by omega), hrun] + rw [pVerdict, hcode, hR, + acceptFlag_cfgCode_tm tm W c (hq x.length) + (hrun ▸ TM.codeInv_runTo tm x (n := tp.eval x.length) (by omega)) hW1 _ hruler] + constructor + · rintro ⟨_, hv⟩ + by_contra hx + rw [hzero hx] at hv + exact absurd hv (by decide) + · intro hx + exact ⟨hhalt, hone hx⟩ + +/-! ## The verdict function is polynomial-time -/ + +/-- The encoded run never grows past the code width. -/ +theorem stepFn_iterate_length_le (tm : TM k) (R z : List Bool) + (hz : z.length ≤ codeBlocks k * R.length) : + ∀ n, ((stepFn tm R)^[n] z).length ≤ codeBlocks k * R.length := by + intro n + induction n generalizing z with + | zero => simpa using hz + | succ n ih => + rw [Function.iterate_succ_apply] + exact ih _ (by rw [codeBlocks] at hz ⊢; exact stepFn_length_le tm R z hz) + +/-- The width the whole packed state stays inside. -/ +noncomputable def pStateBound (k : ℕ) (wp : Polynomial ℕ) : Polynomial ℕ := + 2 * (2 * wp + 2) + 2 + Polynomial.C (codeBlocks k) * (2 * wp + 2) + +theorem pStateBound_eval (k : ℕ) (wp : Polynomial ℕ) (n : ℕ) : + (pStateBound k wp).eval n + = 2 * (2 * wp.eval n + 2) + 2 + codeBlocks k * (2 * wp.eval n + 2) := by + simp [pStateBound] + +/-- **The verdict function is polynomial-time.** -/ +theorem pVerdict_mem_FP (tm : TM k) (wp tp : Polynomial ℕ) + (hwp : ∀ n, n ≤ wp.eval n) : pVerdict tm wp tp ∈ FP := by + have hx : (fun x : List Bool => x) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hRf : (fun x => polyRuler (2 * wp + 2) x) ∈ FP := polyRulerFn_mem_FP _ hx + have hRlen : ∀ x : List Bool, + (polyRuler (2 * wp + 2) x).length = 2 * wp.eval x.length + 2 := by + intro x + rw [polyRuler_length] + simp + have hinit : (fun x => pair (polyRuler (2 * wp + 2) x) + (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x)) ∈ FP := + Cobham.pairFn_mem_FP hRf + (binFn_mem_FP (g := Cobham.initFn tm) + (Cobham.initFn_mem tm (Cobham.proj 0) (Cobham.proj 1)) hRf hx) + have hruler : (fun x => polyRuler tp x) ∈ FP := polyRulerFn_mem_FP _ hx + have hwidth : (fun x => polyRuler (pStateBound k wp) x) ∈ FP := polyRulerFn_mem_FP _ hx + have hbound : ∀ x : List Bool, ∀ n ≤ (polyRuler tp x).length, + ((codeStep tm)^[n] (pair (polyRuler (2 * wp + 2) x) + (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x))).length + ≤ (polyRuler (pStateBound k wp) x).length := by + intro x n _ + have hR : polyRuler (2 * wp + 2) x = blockRuler (wp.eval x.length) := + (blockRuler_eq_polyRuler wp x).symm + have hinitlen : (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x).length + ≤ codeBlocks k * (polyRuler (2 * wp + 2) x).length := by + rw [hR, Cobham.initFn_eq tm _ x (hwp x.length), cfgCode_length] + have := stepFn_iterate_length_le tm (polyRuler (2 * wp + 2) x) _ hinitlen n + rw [codeStep_iterate, pair_length, hRlen x, polyRuler_length, pStateBound_eval] + rw [hRlen x] at this + omega + have hiter := Cobham.iterate_mem_FP (codeStep_mem_FP tm) hinit hruler hwidth hbound + have hcode : (fun x => sndBlock ((codeStep tm)^[(polyRuler tp x).length] + (pair (polyRuler (2 * wp + 2) x) + (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x)))) ∈ FP := by + have := mem_FP_comp hiter Cobham.sndBlock_mem_FP + simpa [Function.comp] using this + exact acceptFlagFn_mem_FP _ hRf (wideRulerFn_mem_FP hRf (codeBlocks k)) hcode + +/-! ## The bridge -/ + +/-- **Every language in `P` has a polynomial-time verdict function.** This is the converse of +`Complexity.mem_P_of_decisionFn_bool`: a polynomial-time predicate can always be consulted from +inside another polynomial-time computation. -/ +theorem exists_decisionFn_of_mem_P {L : Language} (hL : L ∈ P) : + ∃ g : List Bool → Bool, (fun x => [g x]) ∈ FP ∧ ∀ x, x ∈ L ↔ g x = true := by + obtain ⟨k, tm, tp, hdec⟩ := mem_P_iff_decidesInTime_polynomial.mp hL + set wp : Polynomial ℕ := + Polynomial.X + tp + Polynomial.C 1 + Polynomial.C (Fintype.card tm.Q) with hwpdef + have hwe : ∀ n, wp.eval n = n + tp.eval n + 1 + Fintype.card tm.Q := by + intro n + rw [hwpdef] + simp + have hwp : ∀ n, n + tp.eval n + 1 ≤ wp.eval n := by + intro n + rw [hwe] + omega + have hq : ∀ n, Fintype.card tm.Q ≤ blockWidth (wp.eval n) := by + intro n + rw [blockWidth, hwe] + omega + refine ⟨fun x => (pVerdict tm wp tp x).headD false, ?_, fun x => ?_⟩ + · have heq : (fun x => [(pVerdict tm wp tp x).headD false]) = pVerdict tm wp tp := by + funext x + rcases pVerdict_flag tm wp tp x with h | h <;> rw [h] <;> rfl + rw [heq] + exact pVerdict_mem_FP tm wp tp fun n => by rw [hwe]; omega + · rw [← pVerdict_eq_true_iff tm wp tp hdec hwp hq x] + rcases pVerdict_flag tm wp tp x with h | h <;> simp [h] + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchAssemble.lean b/Complexitylib/Classes/Containments/Internal/SavitchAssemble.lean new file mode 100644 index 00000000..c0ea5a8b --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchAssemble.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchReach +public import Complexitylib.Classes.Containments.Internal.SpaceIterate + +/-! +# Savitch's machine + +⚠️ Unreviewed by Bolton + +Everything is in place: `Complexity.savG` is the polynomial-time function +`Complexity.SpaceIter.mem_PSPACE_of_iterate` wants, `Complexity.Sav.run_top` says +its orbit reaches an answer, `Complexity.Sav.runBound_le` bounds how long that +takes, and `Complexity.Sav.StkSize` bounds how much room it needs. This file puts +them together. + +## Main results + +- `Complexity.savitch_mem_PSPACE` — a language whose membership is reachability + within `2 ^ poly` steps of a space-bounded machine is in `PSPACE` +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The run at a fixed input -/ + +/-- The abstract step `Complexity.savG` performs, at the ruler it builds. -/ +noncomputable def savSemAt (tm : NTM k) (qp : Polynomial ℕ) (x : List Bool) : + Sav.Sst → Sav.Sst := savSem tm (savR qp x) + +/-- The answer the recursion returns at `x`. -/ +noncomputable def savAns (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : Bool := + Sav.frameVal (baseReachB tm (savR qp x)) + (fun u => baseAccB tm (savR qp x) (savRuler k (savR qp x)) u) + (savZero k (savR qp x)) (savRoot tm qp lp x) + +/-- What a run of `T` steps at `x` achieves: the flag stays down, then goes up, +then becomes the answer. -/ +noncomputable def SavRunSpec (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) + (T : ℕ) : Prop := + T ≤ Sav.runBound (savZero k (savR qp x)).length (lp.eval x.length) ∧ + (∀ j ≤ T, ((savSemAt tm qp x)^[j] (savInitSst tm qp lp x)).done = false) ∧ + (savSemAt tm qp x)^[T + 1] (savInitSst tm qp lp x) + = ⟨true, savAns tm qp lp x, some (savAns tm qp lp x), []⟩ ∧ + (savSemAt tm qp x)^[T + 2] (savInitSst tm qp lp x) + = ⟨savAns tm qp lp x, savAns tm qp lp x, some (savAns tm qp lp x), []⟩ + +theorem savRun_exists (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : + ∃ T, SavRunSpec tm qp lp x T := by + have hlvl : (savRoot tm qp lp x).lvl.length = lp.eval x.length := by + rw [savRoot, polyRuler_length] + have hok : Sav.FrmOk (baseReachB tm (savR qp x)) (savZero k (savR qp x)) + (savRoot tm qp lp x) := ⟨rfl, by rw [savRoot]; simp⟩ + obtain ⟨T, hT, h⟩ := Sav.run_top (baseReachB tm (savR qp x)) + (fun u => baseAccB tm (savR qp x) (savRuler k (savR qp x)) u) + (savZero k (savR qp x)) (binValLE_savZero k _) (savRoot tm qp lp x) hok + rw [hlvl] at hT + exact ⟨T, hT, h⟩ + +/-- The number of steps Savitch's recursion takes at `x`. -/ +noncomputable def savT (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : ℕ := + Classical.choose (savRun_exists tm qp lp x) + +theorem savT_spec (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : + SavRunSpec tm qp lp x (savT tm qp lp x) := + Classical.choose_spec (savRun_exists tm qp lp x) + +/-! ## The pieces of the space-bounded iteration -/ + +section + +variable (tm : NTM k) {L : Language} {S : ℕ → ℕ} (hdec : tm.DecidesInSpace L S) + (qp lp : Polynomial ℕ) + (hqp : ∀ n, n + S n + 1 ≤ qp.eval n) + (hcardq : ∀ n, Fintype.card tm.Q ≤ blockWidth (qp.eval n)) + +include hdec hqp hcardq in +/-- **The answer the recursion returns is membership.** -/ +theorem frameVal_savRoot (x : List Bool) + (hmem : x ∈ L ↔ ∃ c, tm.ReachesCfgLe (2 ^ lp.eval x.length) (tm.initCfg x) c ∧ + tm.halted c ∧ c.output.cells 1 = Γ.one) : + savAns tm qp lp x = true ↔ x ∈ L := by + have hW := hqp x.length + have hxW : x.length ≤ qp.eval x.length := by omega + have hR : savR qp x = blockRuler (qp.eval x.length) := savR_eq qp x + have hfresh := Sav.frameVal_fresh (baseReachB tm (savR qp x)) + (fun u => baseAccB tm (savR qp x) (savRuler k (savR qp x)) u) + (savZero k (savR qp x)) (binValLE_savZero k _) + (f := savRoot tm qp lp x) (by rw [savRoot]) + rw [savAns, hfresh] + have hkind : (savRoot tm qp lp x).kind = true := rfl + have hu : (savRoot tm qp lp x).u = Cobham.cfgCode (qp.eval x.length) (tm.initCfg x) := by + rw [savRoot, hR, initRecord_eq tm _ x hxW] + have hl : (savRoot tm qp lp x).lvl.length = lp.eval x.length := by + rw [savRoot, polyRuler_length] + rw [hkind, if_pos rfl, hu, hl, hR] + rw [accB_cfgCode tm hdec x (qp.eval x.length) (hcardq x.length) hW _ _ + (NTM.reachesCfg_refl tm _), hmem] + +end + +/-! ## The whole containment -/ + +/-- **Savitch's machine.** A language whose membership is reachability within +`2 ^ lp(|x|)` steps of a machine bounded by `S` is in `PSPACE`. -/ +theorem savitch_mem_PSPACE (tm : NTM k) {L : Language} {S : ℕ → ℕ} + (hdec : tm.DecidesInSpace L S) (qp lp r w : Polynomial ℕ) + (hqp : ∀ n, n + S n + 1 ≤ qp.eval n) + (hcardq : ∀ n, Fintype.card tm.Q ≤ blockWidth (qp.eval n)) + (hmem : ∀ x : List Bool, x ∈ L ↔ ∃ c, tm.ReachesCfgLe (2 ^ lp.eval x.length) + (tm.initCfg x) c ∧ tm.halted c ∧ c.output.cells 1 = Γ.one) + (hr : ∀ n, 2 * (2 * (2 * qp.eval n + 2) + + (lp.eval n + 1) * (2 * (2 * lp.eval n + + 5 * (codeBlocks k * (2 * qp.eval n + 2)) + 14) + 2) + 14) + 2 + n ≤ r.eval n) + (hw : ∀ n, (codeBlocks k * (2 * qp.eval n + 2) + 3) * lp.eval n + 2 ≤ w.eval n) : + L ∈ PSPACE := by + classical + -- the standing abbreviations at a fixed input + set G : List Bool → List Bool := savG tm qp lp with hG + have hGfp : G ∈ FP := savG_mem_FP tm qp lp + set Nof : List Bool → ℕ := fun x => savT tm qp lp x + 2 with hNof + -- the ruler and the widths + have hRlen : ∀ x : List Bool, (savR qp x).length = 2 * qp.eval x.length + 2 := by + intro x + rw [savR_eq, blockRuler_length, blockWidth] + ring + have hzlen : ∀ x : List Bool, + (savZero k (savR qp x)).length = codeBlocks k * (2 * qp.eval x.length + 2) := by + intro x + rw [savZero_length, hRlen] + -- the orbit + have horb : ∀ (x : List Bool) (j : ℕ), G^[j + 1] (pair [] x) + = pair (encSst (savR qp x) ((savSemAt tm qp x)^[j] (savInitSst tm qp lp x))) x := by + intro x j + rw [hG, savG_iterate] + rfl + -- the stack invariant along the orbit + have hstk : ∀ (x : List Bool) (j : ℕ), + Sav.StkSize (lp.eval x.length) (codeBlocks k * (2 * qp.eval x.length + 2)) + ((savSemAt tm qp x)^[j] (savInitSst tm qp lp x)).stk := by + intro x j + have hxW : x.length ≤ qp.eval x.length := by have := hqp x.length; omega + have hu : (savRoot tm qp lp x).u.length + = codeBlocks k * (2 * qp.eval x.length + 2) := by + rw [savRoot, savR_eq, initRecord_eq tm _ x hxW, cfgCode_length, blockRuler_length, + blockWidth] + ring + have h0 : Sav.StkSize (lp.eval x.length) (codeBlocks k * (2 * qp.eval x.length + 2)) + (savInitSst tm qp lp x).stk := by + refine ⟨?_, ⟨by rw [hu], ?_, ?_⟩, trivial⟩ + · show ([] : List Sav.Frm).length + (savRoot tm qp lp x).lvl.length = lp.eval x.length + rw [savRoot] + simp + · rw [savRoot] + exact le_of_eq (hzlen x) + · rw [savRoot] + exact le_of_eq (hzlen x) + exact Sav.iterate_stkSize _ _ _ (le_of_eq (hzlen x)) j _ h0 + -- the four contracts + have hN : ∀ x : List Bool, Nof x = savT tm qp lp x + 2 := fun _ => rfl + refine SpaceIter.mem_PSPACE_of_iterate hGfp r w Nof ?_ ?_ ?_ ?_ ?_ ?_ ?_ + · -- lengths + intro x i _ + have hbase := hr x.length + cases i with + | zero => + rw [Function.iterate_zero_apply, pair_length, List.length_nil] + omega + | succ j => + rw [horb x j, pair_length] + have := encSst_length_le (Lmax := lp.eval x.length) + (Wm := codeBlocks k * (2 * qp.eval x.length + 2)) (savR qp x) _ (hstk x j) + rw [hRlen x] at this + omega + · intro x + rw [hN x] + omega + · -- the step count + intro x + obtain ⟨hT, _, _, _⟩ := savT_spec tm qp lp x + have hle := Sav.runBound_le (savZero k (savR qp x)).length (lp.eval x.length) + have hmono : (2 : ℕ) ^ (((savZero k (savR qp x)).length + 3) * lp.eval x.length + 2) + ≤ 2 ^ w.eval x.length := by + refine Nat.pow_le_pow_right (by omega) ?_ + rw [hzlen x] + exact hw x.length + rw [hN x] + omega + · -- the flag stays down + intro x i hi hlt + obtain ⟨_, hdown, _, _⟩ := savT_spec tm qp lp x + rw [hN x] at hlt + cases i with + | zero => omega + | succ j => + rw [horb x j, headD_pair_encSst] + exact hdown j (by omega) + · -- the flag goes up + intro x + obtain ⟨_, _, hup, _⟩ := savT_spec tm qp lp x + rw [hN x, show savT tm qp lp x + 2 = savT tm qp lp x + 1 + 1 from rfl, + horb x (savT tm qp lp x + 1), headD_pair_encSst, hup] + · intro x + rw [hN x, show savT tm qp lp x + 2 + 1 = savT tm qp lp x + 2 + 1 from rfl, + horb x (savT tm qp lp x + 2)] + intro hc + have := congrArg List.length hc + rw [pair_length] at this + simp at this + · -- the answer + intro x + obtain ⟨_, _, _, hans⟩ := savT_spec tm qp lp x + rw [hN x, horb x (savT tm qp lp x + 2), headD_pair_encSst, hans] + exact (frameVal_savRoot tm hdec qp lp hqp hcardq x (hmem x)).symm + +/-! ## The containment -/ + +/-- The polynomial bounding the width of the window Savitch's machine writes on. -/ +noncomputable def savWidthPoly (cardQ : ℕ) (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.X + p + Polynomial.C 1 + Polynomial.C cardQ + +/-- The polynomial bounding the length of the state Savitch's machine carries. -/ +noncomputable def savStatePoly (k : ℕ) (qp lp : Polynomial ℕ) : Polynomial ℕ := + 2 * (2 * (2 * qp + 2) + + (lp + 1) * (2 * (2 * lp + 5 * (Polynomial.C (codeBlocks k) * (2 * qp + 2)) + 14) + 2) + + 14) + 2 + Polynomial.X + +/-- The polynomial bounding the logarithm of the number of steps it takes. -/ +noncomputable def savCountPoly (k : ℕ) (qp lp : Polynomial ℕ) : Polynomial ℕ := + (Polynomial.C (codeBlocks k) * (2 * qp + 2) + 3) * lp + 2 + +theorem savWidthPoly_eval (cardQ : ℕ) (p : Polynomial ℕ) (n : ℕ) : + (savWidthPoly cardQ p).eval n = n + p.eval n + 1 + cardQ := by + simp [savWidthPoly] + +theorem savStatePoly_eval (k : ℕ) (qp lp : Polynomial ℕ) (n : ℕ) : + (savStatePoly k qp lp).eval n + = 2 * (2 * (2 * qp.eval n + 2) + + (lp.eval n + 1) * (2 * (2 * lp.eval n + + 5 * (codeBlocks k * (2 * qp.eval n + 2)) + 14) + 2) + 14) + 2 + n := by + simp [savStatePoly] + +theorem savCountPoly_eval (k : ℕ) (qp lp : Polynomial ℕ) (n : ℕ) : + (savCountPoly k qp lp).eval n + = (codeBlocks k * (2 * qp.eval n + 2) + 3) * lp.eval n + 2 := by + simp [savCountPoly] + +/-- **`NPSPACE ⊆ PSPACE`** (Savitch's theorem). -/ +theorem NPSPACE_subset_PSPACE_internal : NPSPACE ⊆ PSPACE := by + intro L hL + obtain ⟨m, hm⟩ := Set.mem_iUnion.mp hL + obtain ⟨k, tm, S, hdec, hS⟩ := hm + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hS + set lp : Polynomial ℕ := codeExpBound (Fintype.card tm.Q) k p with hlp + set qp : Polynomial ℕ := savWidthPoly (Fintype.card tm.Q) p with hqpdef + have hqe : ∀ n, qp.eval n = n + p.eval n + 1 + Fintype.card tm.Q := by + intro n + rw [hqpdef, savWidthPoly_eval] + have hqp : ∀ n, n + S n + 1 ≤ qp.eval n := by + intro n + have := hp n + rw [hqe] + omega + have hcardq : ∀ n, Fintype.card tm.Q ≤ blockWidth (qp.eval n) := by + intro n + rw [blockWidth, hqe] + omega + have hreach : ∀ x : List Bool, x ∈ L ↔ + ∃ c, tm.ReachesCfgLe (2 ^ lp.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ + c.output.cells 1 = Γ.one := by + intro x + rw [mem_iff_exists_accepting_reachable hdec x] + constructor + · rintro ⟨c, hr, hh, ho⟩ + exact ⟨c, (NTM.reachesCfg_iff_reachesCfgLe tm _ (cfgCode x.length (S x.length)) + (fun ha hb => NTM.cfgCode_inj_of_reachesCfg hdec x ha hb) + (card_Code_le_two_pow_poly tm.Q k S p hp x.length) c).mp hr, hh, ho⟩ + · rintro ⟨c, hle, hh, ho⟩ + exact ⟨c, (NTM.reachesCfg_iff_reachesCfgLe tm _ (cfgCode x.length (S x.length)) + (fun ha hb => NTM.cfgCode_inj_of_reachesCfg hdec x ha hb) + (card_Code_le_two_pow_poly tm.Q k S p hp x.length) c).mpr hle, hh, ho⟩ + exact savitch_mem_PSPACE tm hdec qp lp (savStatePoly k qp lp) (savCountPoly k qp lp) + hqp hcardq hreach (fun n => le_of_eq (savStatePoly_eval k qp lp n).symm) + (fun n => le_of_eq (savCountPoly_eval k qp lp n).symm) + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean b/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean index 11f70fef..7b976488 100644 --- a/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean +++ b/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean @@ -121,11 +121,15 @@ def stkTop (S : List Bool) : List Bool := fstBlock S /-- The stack below the top frame. -/ def stkRest (S : List Bool) : List Bool := sndBlock S -@[simp] theorem stkTop_cons (f : List Bool) (fs : List (List Bool)) : - stkTop (encStack (f :: fs)) = f := by simp [stkTop] +@[simp] theorem stkTop_pair (f g : List Bool) : stkTop (pair f g) = f := by simp [stkTop] -@[simp] theorem stkRest_cons (f : List Bool) (fs : List (List Bool)) : - stkRest (encStack (f :: fs)) = encStack fs := by simp [stkRest] +@[simp] theorem stkRest_pair (f g : List Bool) : stkRest (pair f g) = g := by simp [stkRest] + +theorem stkTop_cons (f : List Bool) (fs : List (List Bool)) : + stkTop (encStack (f :: fs)) = f := by simp + +theorem stkRest_cons (f : List Bool) (fs : List (List Bool)) : + stkRest (encStack (f :: fs)) = encStack fs := by simp /-- A stack is empty exactly when its encoding is. -/ theorem encStack_eq_nil_iff (fs : List (List Bool)) : encStack fs = [] ↔ fs = [] := by diff --git a/Complexitylib/Classes/Containments/Internal/SavitchReach.lean b/Complexitylib/Classes/Containments/Internal/SavitchReach.lean new file mode 100644 index 00000000..31138504 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchReach.lean @@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchSim +public import Complexitylib.Classes.Containments.Internal.SavitchBound +public import Complexitylib.Classes.Containments.Internal.BinArith + +/-! +# What Savitch's recursion computes + +⚠️ Unreviewed by Bolton + +`Complexity.Sav.rchB` and `Complexity.Sav.accB` are the values the abstract +machine returns, defined purely on bitstrings: a level-`n` reachability question +is answered by trying every string of the enumeration's width as a midpoint. This +file identifies them with reachability in the configuration graph, for as long as +the strings involved are codes of configurations reachable from the start. + +The two directions are both easy once the statement is right. Soundness follows +because a midpoint that passes the first half is itself the code of a reachable +configuration, so the induction hypothesis applies to it; completeness follows +because the enumeration is *every* string of the code width, and a code has +exactly that width. + +## Main results + +- `Complexity.baseReachB_cfgCode`, `Complexity.baseAccB_cfgCode` — the base tests +- `Complexity.rchB_cfgCode`, `Complexity.accB_cfgCode` — the recursion +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## The bottom of the enumeration -/ + +@[simp] theorem binValLE_savZero (k : ℕ) (R : List Bool) : binValLE (savZero k R) = 0 := by + rw [savZero, padTo_nil, binValLE_replicate_false] + +/-! ## The base tests as propositions -/ + +theorem baseReachB_eq_true_iff (tm : NTM k) (R u v : List Bool) : + baseReachB tm R u v = true ↔ + u = v ∨ nstepFn tm false R u = v ∨ nstepFn tm true R u = v := by + have hb : baseReachB tm R u v = true ↔ baseReach tm R u v = [true] := by + rw [baseReach_eq]; simp + rw [hb, baseReach, + orBit_eq_true_iff (eqFlag_flag _ _) (orBit_flag (eqFlag_flag _ _) (eqFlag_flag _ _)), + orBit_eq_true_iff (eqFlag_flag _ _) (eqFlag_flag _ _), eqFlag_eq_true_iff, + eqFlag_eq_true_iff, eqFlag_eq_true_iff] + +theorem baseAccB_eq_true_iff (tm : NTM k) (R rl u : List Bool) : + baseAccB tm R rl u = true ↔ + acceptFlag (stateCode tm.qhalt) R rl u = [true] ∨ + acceptFlag (stateCode tm.qhalt) R rl (nstepFn tm false R u) = [true] ∨ + acceptFlag (stateCode tm.qhalt) R rl (nstepFn tm true R u) = [true] := by + have hb : baseAccB tm R rl u = true ↔ baseAcc tm R rl u = [true] := by + rw [baseAcc_eq]; simp + rw [hb, baseAcc, + orBit_eq_true_iff (acceptFlag_flag _ _ _ _) + (orBit_flag (acceptFlag_flag _ _ _ _) (acceptFlag_flag _ _ _ _)), + orBit_eq_true_iff (acceptFlag_flag _ _ _ _) (acceptFlag_flag _ _ _ _)] + +/-! ## One step of the graph -/ + +namespace NTM + +variable {tm : NTM k} + +theorem eq_of_reachesCfgIn_of_halted {s : ℕ} {c c' : Cfg k tm.Q} + (h : tm.ReachesCfgIn s c c') (hh : c.state = tm.qhalt) : c' = c := by + cases h with + | refl _ => rfl + | head hstep _ => exact absurd hh hstep.1 + +theorem eq_of_reachesCfgLe_of_halted {t : ℕ} {c c' : Cfg k tm.Q} + (h : tm.ReachesCfgLe t c c') (hh : c.state = tm.qhalt) : c' = c := by + obtain ⟨s, _, hw⟩ := h + exact eq_of_reachesCfgIn_of_halted hw hh + +theorem reachesCfg_of_reachesCfgIn {s : ℕ} {c c' : Cfg k tm.Q} + (h : tm.ReachesCfgIn s c c') : tm.ReachesCfg c c' := by + induction h with + | refl c => exact NTM.reachesCfg_refl tm c + | head hstep _ ih => exact NTM.reachesCfg_head hstep ih + +theorem reachesCfg_of_reachesCfgLe {t : ℕ} {c c' : Cfg k tm.Q} + (h : tm.ReachesCfgLe t c c') : tm.ReachesCfg c c' := by + obtain ⟨s, _, hw⟩ := h + exact reachesCfg_of_reachesCfgIn hw + +theorem reachesCfgLe_one_iff (tm : NTM k) (c c' : Cfg k tm.Q) : + tm.ReachesCfgLe 1 c c' ↔ c' = c ∨ (c.state ≠ tm.qhalt ∧ ∃ b, c' = tm.stepCfg b c) := by + constructor + · rintro ⟨s, hs, hw⟩ + cases hw with + | refl _ => exact Or.inl rfl + | head hstep hrest => + cases hrest with + | refl _ => exact Or.inr ⟨hstep.1, hstep.2⟩ + | head _ _ => omega + · rintro (rfl | ⟨hne, b, rfl⟩) + · exact ⟨0, by omega, NTM.ReachesCfgIn.refl _⟩ + · exact ⟨1, le_rfl, NTM.ReachesCfgIn.head ⟨hne, b, rfl⟩ (NTM.ReachesCfgIn.refl _)⟩ + +end NTM + +/-! ## The recursion against the graph -/ + +section + +variable (tm : NTM k) {L : Language} {S : ℕ → ℕ} (hdec : tm.DecidesInSpace L S) + (x : List Bool) (W : ℕ) (hq : Fintype.card tm.Q ≤ blockWidth W) + (hW : x.length + S x.length + 1 ≤ W) + +include hdec hW hq in +theorem baseReachB_cfgCode {c : Cfg k tm.Q} (hc : tm.ReachesCfg (tm.initCfg x) c) + (v : List Bool) : + baseReachB tm (blockRuler W) (Cobham.cfgCode W c) v = true ↔ + ∃ c', tm.ReachesCfgLe 1 c c' ∧ v = Cobham.cfgCode W c' := by + have hinv : CodeInv W c := codeInv_of_reachesCfg tm hdec x hc W hW + rw [baseReachB_eq_true_iff] + by_cases hh : c.state = tm.qhalt + · rw [nstepFn_code_halted tm false W c hq hinv hh, nstepFn_code_halted tm true W c hq hinv hh] + constructor + · intro h + exact ⟨c, NTM.reachesCfgLe_refl tm 1 c, + by rcases h with h | h | h <;> exact h.symm⟩ + · rintro ⟨c', hle, rfl⟩ + exact Or.inl (by rw [NTM.eq_of_reachesCfgLe_of_halted hle hh]) + · rw [nstepFn_code tm false W c hq hinv hh, nstepFn_code tm true W c hq hinv hh] + constructor + · rintro (h | h | h) + · exact ⟨c, NTM.reachesCfgLe_refl tm 1 c, h.symm⟩ + · exact ⟨tm.stepCfg false c, + (NTM.reachesCfgLe_one_iff tm c _).mpr (Or.inr ⟨hh, false, rfl⟩), h.symm⟩ + · exact ⟨tm.stepCfg true c, + (NTM.reachesCfgLe_one_iff tm c _).mpr (Or.inr ⟨hh, true, rfl⟩), h.symm⟩ + · rintro ⟨c', hle, rfl⟩ + rcases (NTM.reachesCfgLe_one_iff tm c c').mp hle with rfl | ⟨_, b, rfl⟩ + · exact Or.inl rfl + · cases b + · exact Or.inr (Or.inl rfl) + · exact Or.inr (Or.inr rfl) + +include hdec hW hq in +theorem baseAccB_cfgCode {c : Cfg k tm.Q} (hc : tm.ReachesCfg (tm.initCfg x) c) : + baseAccB tm (blockRuler W) (savRuler k (blockRuler W)) (Cobham.cfgCode W c) = true ↔ + ∃ c', tm.ReachesCfgLe 1 c c' ∧ c'.state = tm.qhalt ∧ c'.output.cells 1 = Γ.one := by + have hW1 : 1 ≤ W := by omega + have hruler : W ≤ (savRuler k (blockRuler W)).length := by + rw [savRuler, wideRuler_length, blockRuler_length, blockWidth] + have hcb : 1 ≤ codeBlocks k := by rw [codeBlocks]; omega + calc W ≤ 1 * (2 * (W + 1)) := by omega + _ ≤ codeBlocks k * (2 * (W + 1)) := Nat.mul_le_mul_right _ hcb + have hflag : ∀ c'' : Cfg k tm.Q, tm.ReachesCfg (tm.initCfg x) c'' → + (acceptFlag (stateCode tm.qhalt) (blockRuler W) (savRuler k (blockRuler W)) + (Cobham.cfgCode W c'') = [true] ↔ + c''.state = tm.qhalt ∧ c''.output.cells 1 = Γ.one) := fun c'' hc'' => + acceptFlag_cfgCode tm W c'' hq (codeInv_of_reachesCfg tm hdec x hc'' W hW) hW1 _ hruler + have hinv : CodeInv W c := codeInv_of_reachesCfg tm hdec x hc W hW + rw [baseAccB_eq_true_iff] + by_cases hh : c.state = tm.qhalt + · rw [nstepFn_code_halted tm false W c hq hinv hh, nstepFn_code_halted tm true W c hq hinv hh, + hflag c hc] + constructor + · intro h + exact ⟨c, NTM.reachesCfgLe_refl tm 1 c, by rcases h with h | h | h <;> exact h⟩ + · rintro ⟨c', hle, h1, h2⟩ + rw [NTM.eq_of_reachesCfgLe_of_halted hle hh] at h1 h2 + exact Or.inl ⟨h1, h2⟩ + · have hs : ∀ b : Bool, tm.ReachesCfg (tm.initCfg x) (tm.stepCfg b c) := fun b => + hc.trans (NTM.reachesCfg_of_reachesCfgLe + ((NTM.reachesCfgLe_one_iff tm c _).mpr (Or.inr ⟨hh, b, rfl⟩))) + rw [nstepFn_code tm false W c hq hinv hh, nstepFn_code tm true W c hq hinv hh, + hflag c hc, hflag _ (hs false), hflag _ (hs true)] + constructor + · rintro (h | h | h) + · exact ⟨c, NTM.reachesCfgLe_refl tm 1 c, h⟩ + · exact ⟨tm.stepCfg false c, + (NTM.reachesCfgLe_one_iff tm c _).mpr (Or.inr ⟨hh, false, rfl⟩), h⟩ + · exact ⟨tm.stepCfg true c, + (NTM.reachesCfgLe_one_iff tm c _).mpr (Or.inr ⟨hh, true, rfl⟩), h⟩ + · rintro ⟨c', hle, h1, h2⟩ + rcases (NTM.reachesCfgLe_one_iff tm c c').mp hle with rfl | ⟨_, b, rfl⟩ + · exact Or.inl ⟨h1, h2⟩ + · cases b + · exact Or.inr (Or.inl ⟨h1, h2⟩) + · exact Or.inr (Or.inr ⟨h1, h2⟩) + +include hdec hW hq in +/-- **The recursion decides bounded reachability.** -/ +theorem rchB_cfgCode : + ∀ (n : ℕ) (c : Cfg k tm.Q), tm.ReachesCfg (tm.initCfg x) c → ∀ v : List Bool, + Sav.rchB (baseReachB tm (blockRuler W)) (savZero k (blockRuler W)) n + (Cobham.cfgCode W c) v = true ↔ + ∃ c', tm.ReachesCfgLe (2 ^ n) c c' ∧ v = Cobham.cfgCode W c' := by + intro n + induction n with + | zero => + intro c hc v + rw [Sav.rchB, pow_zero] + exact baseReachB_cfgCode tm hdec x W hq hW hc v + | succ n ih => + intro c hc v + rw [Sav.rchB] + constructor + · intro h + obtain ⟨i, _, hP⟩ := Sav.exists_of_anyMid h + rw [Bool.and_eq_true] at hP + obtain ⟨cm, hcm, hwm⟩ := (ih c hc _).mp hP.1 + have hcm' : tm.ReachesCfg (tm.initCfg x) cm := + hc.trans (NTM.reachesCfg_of_reachesCfgLe hcm) + obtain ⟨c', hc', hv⟩ := (ih cm hcm' v).mp (by rw [← hwm]; exact hP.2) + exact ⟨c', (NTM.reachesCfgLe_two_pow_succ_iff tm n c c').mpr ⟨cm, hcm, hc'⟩, hv⟩ + · rintro ⟨c', hle, rfl⟩ + obtain ⟨cm, h₁, h₂⟩ := (NTM.reachesCfgLe_two_pow_succ_iff tm n c c').mp hle + have hcm' : tm.ReachesCfg (tm.initCfg x) cm := + hc.trans (NTM.reachesCfg_of_reachesCfgLe h₁) + refine Sav.anyMid_of_length (w := Cobham.cfgCode W cm) (binValLE_savZero k _) ?_ ?_ + · rw [cfgCode_length, savZero_length] + · rw [Bool.and_eq_true] + exact ⟨(ih c hc _).mpr ⟨cm, h₁, rfl⟩, (ih cm hcm' _).mpr ⟨c', h₂, rfl⟩⟩ + +include hdec hW hq in +/-- **The recursion decides bounded acceptance.** -/ +theorem accB_cfgCode : + ∀ (n : ℕ) (c : Cfg k tm.Q), tm.ReachesCfg (tm.initCfg x) c → + (Sav.accB (baseReachB tm (blockRuler W)) + (fun u => baseAccB tm (blockRuler W) (savRuler k (blockRuler W)) u) + (savZero k (blockRuler W)) n (Cobham.cfgCode W c) = true ↔ + ∃ c', tm.ReachesCfgLe (2 ^ n) c c' ∧ c'.state = tm.qhalt ∧ + c'.output.cells 1 = Γ.one) := by + intro n + induction n with + | zero => + intro c hc + rw [Sav.accB, pow_zero] + exact baseAccB_cfgCode tm hdec x W hq hW hc + | succ n ih => + intro c hc + rw [Sav.accB] + constructor + · intro h + obtain ⟨i, _, hP⟩ := Sav.exists_of_anyMid h + rw [Bool.and_eq_true] at hP + obtain ⟨cm, hcm, hwm⟩ := (rchB_cfgCode tm hdec x W hq hW n c hc _).mp hP.1 + have hcm' : tm.ReachesCfg (tm.initCfg x) cm := + hc.trans (NTM.reachesCfg_of_reachesCfgLe hcm) + obtain ⟨c', hc', h1, h2⟩ := (ih cm hcm').mp (by rw [← hwm]; exact hP.2) + exact ⟨c', (NTM.reachesCfgLe_two_pow_succ_iff tm n c c').mpr ⟨cm, hcm, hc'⟩, h1, h2⟩ + · rintro ⟨c', hle, h1, h2⟩ + obtain ⟨cm, hm₁, hm₂⟩ := (NTM.reachesCfgLe_two_pow_succ_iff tm n c c').mp hle + have hcm' : tm.ReachesCfg (tm.initCfg x) cm := + hc.trans (NTM.reachesCfg_of_reachesCfgLe hm₁) + refine Sav.anyMid_of_length (w := Cobham.cfgCode W cm) (binValLE_savZero k _) ?_ ?_ + · rw [cfgCode_length, savZero_length] + · rw [Bool.and_eq_true] + exact ⟨(rchB_cfgCode tm hdec x W hq hW n c hc _).mpr ⟨cm, hm₁, rfl⟩, + (ih cm hcm').mpr ⟨c', hm₂, h1, h2⟩⟩ + +end + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchSem.lean b/Complexitylib/Classes/Containments/Internal/SavitchSem.lean new file mode 100644 index 00000000..0dba4e09 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchSem.lean @@ -0,0 +1,817 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchBits + +/-! +# The abstract semantics of Savitch's stack machine + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.SavitchStep` writes Savitch's +recursion as a polynomial-time function on a bitstring. This file gives the same +recursion on an ordinary inductive state — a `List` of frames rather than a +right-nested chain of pairs — where its correctness and its running time can be +proved by induction without any encoding in the way. + +The machine is parametric in the two base tests it calls, `br` (is `v` within one +step of `u`) and `ba` (is `u` accepting, or within one step of accepting), and in +the all-zero code `z`, which is both the first midpoint every frame tries and the +width the enumeration wraps at. + +## Main definitions + +- `Complexity.Sav.Frm`, `Complexity.Sav.Sst` — a frame and the machine's state +- `Complexity.Sav.step` — one step of the recursion +- `Complexity.Sav.rchB`, `Complexity.Sav.accB` — what the recursion computes +- `Complexity.Sav.frameVal` — the value a frame is going to return +- `Complexity.Sav.runBound` — the number of steps a level costs + +## Main results + +- `Complexity.Sav.run_frame` — a frame pushed on the stack is popped again, with + its value, within `runBound` steps, and the done flag stays down throughout +-/ + +@[expose] public section + +namespace Complexity +namespace Sav + +/-! ## The state -/ + +/-- A frame of Savitch's recursion: which subproblem it is working on (`kind`), +which half of the interval it is trying (`ph`), the level in unary (`lvl`), the +two endpoints (`u`, `v`) and the midpoint being tried (`m`). -/ +structure Frm where + /-- `true` for *is an accepting configuration reachable from `u`*, `false` for + *is `v` reachable from `u`*. -/ + kind : Bool + /-- `false` while the first half of the interval is being tried. -/ + ph : Bool + /-- The level, in unary: `2 ^ lvl.length` steps are allowed. -/ + lvl : List Bool + /-- The source endpoint. -/ + u : List Bool + /-- The target endpoint; unused by an acceptance frame. -/ + v : List Bool + /-- The midpoint being tried, which doubles as the enumeration's counter. -/ + m : List Bool + +/-- The machine's state: the done flag, the answer, the value a finished subcall +is returning (`none` while descending), and the stack. -/ +structure Sst where + /-- The bit the space-bounded iteration watches. -/ + done : Bool + /-- The answer, once it is known. -/ + ans : Bool + /-- The value a finished subcall is returning. -/ + ret : Option Bool + /-- The stack, top frame first. -/ + stk : List Frm + +/-! ## One step -/ + +/-- The child a frame pushes: the first half of its interval while its phase is +zero, the second half afterwards. -/ +def child (z : List Bool) (f : Frm) : Frm := + if f.ph then + if f.kind then ⟨true, false, f.lvl.drop 1, f.m, z, z⟩ + else ⟨false, false, f.lvl.drop 1, f.m, f.v, z⟩ + else ⟨false, false, f.lvl.drop 1, f.u, f.m, z⟩ + +/-- The value a level-zero frame returns. -/ +def baseVal (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (f : Frm) : Bool := + if f.kind then ba f.u else br f.u f.v + +/-- **One step of Savitch's recursion**, on the abstract state. -/ +def step (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + (s : Sst) : Sst := + if s.done then ⟨s.ans, s.ans, s.ret, s.stk⟩ + else + match s.stk, s.ret with + | [], r => ⟨true, r.getD false, r, []⟩ + | f :: fs, none => + if f.lvl = [] then ⟨false, s.ans, some (baseVal br ba f), fs⟩ + else ⟨false, s.ans, none, child z f :: f :: fs⟩ + | f :: fs, some true => + if f.ph then ⟨false, s.ans, some true, fs⟩ + else ⟨false, s.ans, none, { f with ph := true } :: fs⟩ + | f :: fs, some false => + if bumpOver f.m then ⟨false, s.ans, some false, fs⟩ + else ⟨false, s.ans, none, { f with ph := false, m := bumpBits f.m } :: fs⟩ + +variable (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + +@[simp] theorem step_of_done (a : Bool) (r : Option Bool) (stk : List Frm) : + step br ba z ⟨true, a, r, stk⟩ = ⟨a, a, r, stk⟩ := rfl + +@[simp] theorem step_of_empty (a : Bool) (r : Option Bool) : + step br ba z ⟨false, a, r, []⟩ = ⟨true, r.getD false, r, []⟩ := rfl + +theorem step_base (a : Bool) (f : Frm) (fs : List Frm) (h : f.lvl = []) : + step br ba z ⟨false, a, none, f :: fs⟩ = ⟨false, a, some (baseVal br ba f), fs⟩ := by + simp [step, h] + +theorem step_push (a : Bool) (f : Frm) (fs : List Frm) (h : f.lvl ≠ []) : + step br ba z ⟨false, a, none, f :: fs⟩ = ⟨false, a, none, child z f :: f :: fs⟩ := by + simp [step, h] + +theorem step_ret_true_ph (a : Bool) (f : Frm) (fs : List Frm) (h : f.ph = true) : + step br ba z ⟨false, a, some true, f :: fs⟩ = ⟨false, a, some true, fs⟩ := by + simp [step, h] + +theorem step_ret_true_of_ph_false (a : Bool) (f : Frm) (fs : List Frm) (h : f.ph = false) : + step br ba z ⟨false, a, some true, f :: fs⟩ + = ⟨false, a, none, { f with ph := true } :: fs⟩ := by + simp [step, h] + +theorem step_ret_false_over (a : Bool) (f : Frm) (fs : List Frm) (h : bumpOver f.m = true) : + step br ba z ⟨false, a, some false, f :: fs⟩ = ⟨false, a, some false, fs⟩ := by + simp [step, h] + +theorem step_ret_false_bump (a : Bool) (f : Frm) (fs : List Frm) (h : bumpOver f.m = false) : + step br ba z ⟨false, a, some false, f :: fs⟩ + = ⟨false, a, none, { f with ph := false, m := bumpBits f.m } :: fs⟩ := by + simp [step, h] + +/-! ## What the recursion computes -/ + +/-- Try `j` successive midpoints, starting at `m`. -/ +def anyMid (P : List Bool → Bool) : List Bool → ℕ → Bool + | _, 0 => false + | m, j + 1 => P m || anyMid P (bumpBits m) j + +@[simp] theorem anyMid_zero (P : List Bool → Bool) (m : List Bool) : anyMid P m 0 = false := rfl + +@[simp] theorem anyMid_succ (P : List Bool → Bool) (m : List Bool) (j : ℕ) : + anyMid P m (j + 1) = (P m || anyMid P (bumpBits m) j) := rfl + +/-- **Reachability within `2 ^ n` steps**, as the recursion computes it. -/ +def rchB (br : List Bool → List Bool → Bool) (z : List Bool) : + ℕ → List Bool → List Bool → Bool + | 0, u, v => br u v + | n + 1, u, v => anyMid (fun m => rchB br z n u m && rchB br z n m v) z (2 ^ z.length) + +/-- **Acceptance within `2 ^ n` steps**, as the recursion computes it. -/ +def accB (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) : + ℕ → List Bool → Bool + | 0, u => ba u + | n + 1, u => anyMid (fun m => rchB br z n u m && accB br ba z n m) z (2 ^ z.length) + +/-- The number of midpoints a frame has still to try. -/ +def midRem (m : List Bool) : ℕ := 2 ^ m.length - binValLE m + +theorem midRem_pos (m : List Bool) : 0 < midRem m := + Nat.sub_pos_of_lt (binValLE_lt m) + +theorem midRem_le (m : List Bool) : midRem m ≤ 2 ^ m.length := Nat.sub_le _ _ + +theorem midRem_of_over {m : List Bool} (h : bumpOver m = true) : midRem m = 1 := by + have hv := (bumpOver_iff m).mp h + have hp : 0 < 2 ^ m.length := Nat.two_pow_pos _ + rw [midRem, hv] + omega + +theorem midRem_bump {m : List Bool} (h : bumpOver m = false) : + midRem (bumpBits m) + 1 = midRem m := by + have hv := binValLE_bumpBits_of_not_over m h + have hlen := bumpBits_length m + have hlt := binValLE_lt (bumpBits m) + rw [hlen] at hlt + rw [midRem, midRem, hlen, hv] + have hp : 0 < 2 ^ m.length := Nat.two_pow_pos _ + omega + +theorem midRem_zero {m : List Bool} (h : binValLE m = 0) : midRem m = 2 ^ m.length := by + rw [midRem, h, Nat.sub_zero] + +/-- The value the frame `f` is going to return, given the state it is in. -/ +def frameValAux (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + (kind : Bool) (lvl u v m : List Bool) : Bool := + match lvl with + | [] => if kind then ba u else br u v + | _ :: t => + anyMid (fun w => rchB br z t.length u w && + (if kind then accB br ba z t.length w else rchB br z t.length w v)) m (midRem m) + +/-- The value the frame `f` is going to return. -/ +def frameVal (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + (f : Frm) : Bool := + frameValAux br ba z f.kind f.lvl f.u f.v f.m + +theorem frameVal_of_nil {f : Frm} (h : f.lvl = []) : + frameVal br ba z f = baseVal br ba f := by + rw [frameVal, baseVal, h]; rfl + +theorem frameVal_of_cons {f : Frm} {b : Bool} {t : List Bool} (h : f.lvl = b :: t) : + frameVal br ba z f + = anyMid (fun w => rchB br z t.length f.u w && + (if f.kind then accB br ba z t.length w else rchB br z t.length w f.v)) + f.m (midRem f.m) := by + rw [frameVal, h]; rfl + +/-- A fresh frame — phase zero, midpoint at the bottom of the enumeration — +returns exactly the value its level asks for. -/ +theorem frameVal_fresh {f : Frm} (hz : binValLE z = 0) (hm : f.m = z) : + frameVal br ba z f + = if f.kind then accB br ba z f.lvl.length f.u else rchB br z f.lvl.length f.u f.v := by + rcases hl : f.lvl with _ | ⟨b, t⟩ + · rw [frameVal_of_nil br ba z hl, baseVal] + cases f.kind <;> simp [accB, rchB] + · rw [frameVal_of_cons br ba z hl, hm, midRem_zero hz, List.length_cons] + cases f.kind <;> simp [accB, rchB] + +/-! ## The invariant a frame carries -/ + +/-- A frame is well formed when its midpoint has the enumeration's width and, +once its phase has advanced, its first half really did succeed. -/ +structure FrmOk (br : List Bool → List Bool → Bool) (z : List Bool) (f : Frm) : Prop where + /-- The midpoint is a code. -/ + mlen : f.m.length = z.length + /-- The first half succeeded before the phase advanced. -/ + phase : f.ph = true → rchB br z (f.lvl.length - 1) f.u f.m = true + +/-! ## The number of steps -/ + +/-- The steps a frame at level `n` costs, over an enumeration of width `W`. -/ +def runBound (W : ℕ) : ℕ → ℕ + | 0 => 1 + | n + 1 => (2 * 2 ^ W + 1) * (runBound W n + 2) + +/-- How much work a frame has left, within its level. -/ +def mu (f : Frm) : ℕ := 2 * midRem f.m + (if f.ph then 0 else 1) + +theorem mu_of_ph_true {f : Frm} (h : f.ph = true) : mu f = 2 * midRem f.m := by + rw [mu, h]; simp + +theorem mu_of_ph_false {f : Frm} (h : f.ph = false) : mu f = 2 * midRem f.m + 1 := by + rw [mu, h]; simp + +theorem mu_pos (f : Frm) : 0 < mu f := by + have := midRem_pos f.m + rw [mu] + split <;> omega + +theorem mu_le {f : Frm} (h : f.m.length = z.length) : mu f ≤ 2 * 2 ^ z.length + 1 := by + have := midRem_le f.m + rw [h] at this + rw [mu] + split <;> omega + +/-! ## The done flag stays down -/ + +/-- The done flag is down at every point of the first `T` steps from `s`. -/ +def DoneDown (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + (s : Sst) (T : ℕ) : Prop := ∀ j ≤ T, ((step br ba z)^[j] s).done = false + +theorem doneDown_zero {s : Sst} (h : s.done = false) : DoneDown br ba z s 0 := by + intro j hj + have : j = 0 := Nat.le_zero.mp hj + subst this + simpa using h + +theorem doneDown_add {s : Sst} {T₁ T₂ : ℕ} (h₁ : DoneDown br ba z s T₁) + (h₂ : DoneDown br ba z ((step br ba z)^[T₁] s) T₂) : DoneDown br ba z s (T₁ + T₂) := by + intro j hj + by_cases hle : j ≤ T₁ + · exact h₁ j hle + · have hj' : j = T₂ ⊓ (j - T₁) + T₁ := by omega + have : j = (j - T₁) + T₁ := by omega + rw [this, Function.iterate_add_apply] + exact h₂ _ (by omega) + +theorem doneDown_succ {s : Sst} {T : ℕ} (h : DoneDown br ba z s T) + (h' : ((step br ba z)^[T + 1] s).done = false) : DoneDown br ba z s (T + 1) := by + intro j hj + rcases Nat.lt_or_ge j (T + 1) with hlt | hge + · exact h j (by omega) + · have : j = T + 1 := by omega + subst this + exact h' + +/-! ## Unfolding a frame's value -/ + +@[simp] theorem child_lvl (f : Frm) : (child z f).lvl = f.lvl.drop 1 := by + rw [child]; split_ifs <;> rfl + +@[simp] theorem child_m (f : Frm) : (child z f).m = z := by + rw [child]; split_ifs <;> rfl + +@[simp] theorem child_ph (f : Frm) : (child z f).ph = false := by + rw [child]; split_ifs <;> rfl + +theorem frameVal_child_of_ph_false (hz : binValLE z = 0) {f : Frm} (h : f.ph = false) : + frameVal br ba z (child z f) = rchB br z (f.lvl.length - 1) f.u f.m := by + have hc : child z f = ⟨false, false, f.lvl.drop 1, f.u, f.m, z⟩ := by + rw [child, h]; simp + rw [frameVal_fresh br ba z hz (show (child z f).m = z by rw [hc]), hc] + simp + +theorem frameVal_child_of_ph_true (hz : binValLE z = 0) {f : Frm} (h : f.ph = true) : + frameVal br ba z (child z f) + = if f.kind then accB br ba z (f.lvl.length - 1) f.m + else rchB br z (f.lvl.length - 1) f.m f.v := by + have hc : child z f = + if f.kind then ⟨true, false, f.lvl.drop 1, f.m, z, z⟩ + else ⟨false, false, f.lvl.drop 1, f.m, f.v, z⟩ := by + rw [child, h]; simp + rw [frameVal_fresh br ba z hz (show (child z f).m = z by rw [child_m]), hc] + cases f.kind <;> simp + +/-- The candidate a frame is currently testing. -/ +def midVal (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + (n : ℕ) (f : Frm) : Bool := + rchB br z n f.u f.m && (if f.kind then accB br ba z n f.m else rchB br z n f.m f.v) + +theorem frameVal_of_last {f : Frm} {b : Bool} {t : List Bool} (hl : f.lvl = b :: t) + (hov : bumpOver f.m = true) : frameVal br ba z f = midVal br ba z t.length f := by + rw [frameVal_of_cons br ba z hl, midRem_of_over hov, anyMid_succ, anyMid_zero, + Bool.or_false, midVal] + +theorem frameVal_of_bump {f : Frm} {b : Bool} {t : List Bool} (hl : f.lvl = b :: t) + (hov : bumpOver f.m = false) : + frameVal br ba z f + = (midVal br ba z t.length f || + frameVal br ba z { f with ph := false, m := bumpBits f.m }) := by + have hr : midRem f.m = midRem (bumpBits f.m) + 1 := (midRem_bump hov).symm + rw [frameVal_of_cons br ba z hl, hr, anyMid_succ, + frameVal_of_cons br ba z (f := { f with ph := false, m := bumpBits f.m }) (by simpa using hl)] + rfl + +theorem frameVal_of_mid {f : Frm} {b : Bool} {t : List Bool} (hl : f.lvl = b :: t) + (h : midVal br ba z t.length f = true) : frameVal br ba z f = true := by + obtain ⟨r, hr⟩ : ∃ r, midRem f.m = r + 1 := ⟨midRem f.m - 1, by have := midRem_pos f.m; omega⟩ + rw [frameVal_of_cons br ba z hl, hr, anyMid_succ] + rw [midVal] at h + rw [h, Bool.true_or] + +/-! ## Runs -/ + +/-- The frame `f`, pushed on top of `fs`, is popped again with its value after +exactly `T` steps, and the done flag stays down throughout. -/ +def RunsTo (br : List Bool → List Bool → Bool) (ba : List Bool → Bool) (z : List Bool) + (f : Frm) (fs : List Frm) (a : Bool) (T : ℕ) : Prop := + 0 < T ∧ DoneDown br ba z ⟨false, a, none, f :: fs⟩ T ∧ + (step br ba z)^[T] ⟨false, a, none, f :: fs⟩ = ⟨false, a, some (frameVal br ba z f), fs⟩ + +/-- A run that begins by re-entering a frame of the same value. -/ +theorem runsTo_prepend {f g : Frm} {fs : List Frm} {a : Bool} {T₀ T₁ : ℕ} + (hd : DoneDown br ba z ⟨false, a, none, f :: fs⟩ T₀) + (hs : (step br ba z)^[T₀] ⟨false, a, none, f :: fs⟩ = ⟨false, a, none, g :: fs⟩) + (hr : RunsTo br ba z g fs a T₁) + (hval : frameVal br ba z g = frameVal br ba z f) : + RunsTo br ba z f fs a (T₁ + T₀) := by + obtain ⟨hpos, hdd, hend⟩ := hr + refine ⟨by omega, ?_, ?_⟩ + · rw [Nat.add_comm] + exact doneDown_add br ba z hd (by rw [hs]; exact hdd) + · rw [Function.iterate_add_apply, hs, hend, hval] + +/-- Pushing a frame's child, running it, and processing its return. -/ +theorem child_phase {f : Frm} {fs : List Frm} {a : Bool} {Tc : ℕ} {s : Sst} + (hne : f.lvl ≠ []) + (hc : RunsTo br ba z (child z f) (f :: fs) a Tc) + (hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ = s) + (hsdone : s.done = false) : + DoneDown br ba z ⟨false, a, none, f :: fs⟩ (Tc + 1 + 1) ∧ + (step br ba z)^[Tc + 1 + 1] ⟨false, a, none, f :: fs⟩ = s := by + obtain ⟨hpos, hdd, hend⟩ := hc + have hpush : step br ba z ⟨false, a, none, f :: fs⟩ + = ⟨false, a, none, child z f :: f :: fs⟩ := step_push br ba z a f fs hne + have h1 : (step br ba z)^[Tc + 1] ⟨false, a, none, f :: fs⟩ + = ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ := by + rw [Function.iterate_succ_apply, hpush, hend] + have h2 : (step br ba z)^[Tc + 1 + 1] ⟨false, a, none, f :: fs⟩ = s := by + rw [Function.iterate_succ_apply', h1, hstep] + refine ⟨?_, h2⟩ + have d1 : DoneDown br ba z ⟨false, a, none, f :: fs⟩ 1 := by + refine doneDown_succ br ba z (doneDown_zero br ba z rfl) ?_ + rw [Function.iterate_one, hpush] + have d2 : DoneDown br ba z ⟨false, a, none, f :: fs⟩ (Tc + 1) := by + have := doneDown_add br ba z d1 (by rw [Function.iterate_one, hpush]; exact hdd) + rwa [Nat.add_comm 1 Tc] at this + exact doneDown_succ br ba z d2 (by rw [h2]; exact hsdone) + +/-! ## Every pushed frame comes back -/ + +private theorem run_aux (hz : binValLE z = 0) (n : ℕ) + (ih : ∀ g : Frm, g.lvl.length = n → FrmOk br z g → ∀ (gs : List Frm) (a : Bool), + ∃ T ≤ runBound z.length n, RunsTo br ba z g gs a T) : + ∀ (M : ℕ) (f : Frm), mu f ≤ M → f.lvl.length = n + 1 → FrmOk br z f → + ∀ (fs : List Frm) (a : Bool), + ∃ T ≤ mu f * (runBound z.length n + 2), RunsTo br ba z f fs a T := by + intro M + induction M with + | zero => + intro f hmu _ _ _ _ + have := mu_pos f + omega + | succ M IH => + intro f hmu hlen hok fs a + obtain ⟨b, t, hl⟩ : ∃ b t, f.lvl = b :: t := by + cases hlv : f.lvl with + | nil => rw [hlv] at hlen; simp at hlen + | cons b t => exact ⟨b, t, rfl⟩ + have hne : f.lvl ≠ [] := by rw [hl]; simp + have htn : t.length = n := by + have := hlen + rw [hl, List.length_cons] at this + omega + have hdrop : f.lvl.length - 1 = n := by omega + set rb := runBound z.length n with hrb + -- the child, and the fact that it is well formed + have hgl : (child z f).lvl.length = n := by + rw [child_lvl, List.length_drop, hlen] + omega + have hgok : FrmOk br z (child z f) := + ⟨by rw [child_m], by rw [child_ph]; simp⟩ + obtain ⟨Tc, hTc, hcr⟩ := ih (child z f) hgl hgok (f :: fs) a + have hmid : ∀ g : Frm, g.kind = f.kind → g.u = f.u → g.v = f.v → g.m = f.m → + midVal br ba z t.length g = midVal br ba z t.length f := by + intro g h1 h2 h3 h4 + rw [midVal, midVal, h1, h2, h3, h4] + cases hph : f.ph + · -- descending into the first half + have hb : frameVal br ba z (child z f) = rchB br z n f.u f.m := by + rw [frameVal_child_of_ph_false br ba z hz hph, hdrop] + cases hb1 : rchB br z n f.u f.m + · -- the first half failed: try the next midpoint + cases hov : bumpOver f.m + · set f'' : Frm := { f with ph := false, m := bumpBits f.m } with hf'' + have hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ + = ⟨false, a, none, f'' :: fs⟩ := by + rw [hb, hb1] + exact step_ret_false_bump br ba z a f fs hov + obtain ⟨hd, hs⟩ := child_phase br ba z hne hcr hstep rfl + have hokv : midVal br ba z t.length f = false := by + rw [midVal, htn, hb1, Bool.false_and] + have hval : frameVal br ba z f'' = frameVal br ba z f := by + rw [frameVal_of_bump br ba z hl hov, hokv, Bool.false_or] + have hmu'' : mu f = mu f'' + 2 := by + have h1 : mu f'' = 2 * midRem (bumpBits f.m) + 1 := by rw [hf'', mu]; simp + have h2 : mu f = 2 * midRem f.m + 1 := mu_of_ph_false hph + have h3 := midRem_bump hov + omega + have hlen'' : f''.lvl.length = n + 1 := hlen + have hok'' : FrmOk br z f'' := + ⟨by rw [hf'']; simpa using hok.mlen, by rw [hf'']; simp⟩ + obtain ⟨T', hT', hr'⟩ := IH f'' (by omega) hlen'' hok'' fs a + refine ⟨T' + (Tc + 1 + 1), ?_, runsTo_prepend br ba z hd hs hr' hval⟩ + have hexp : mu f * (rb + 2) = mu f'' * (rb + 2) + 2 * (rb + 2) := by + rw [hmu'']; ring + omega + · -- the enumeration has wrapped: the frame fails + have hokv : midVal br ba z t.length f = false := by + rw [midVal, htn, hb1, Bool.false_and] + have hval : frameVal br ba z f = false := by + rw [frameVal_of_last br ba z hl hov, hokv] + have hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ + = ⟨false, a, some (frameVal br ba z f), fs⟩ := by + rw [hb, hb1, hval] + exact step_ret_false_over br ba z a f fs hov + obtain ⟨hd, hs⟩ := child_phase br ba z hne hcr hstep rfl + refine ⟨Tc + 1 + 1, ?_, by omega, hd, hs⟩ + have hmuf : 3 ≤ mu f := by + have h2 : mu f = 2 * midRem f.m + 1 := mu_of_ph_false hph + rw [midRem_of_over hov] at h2 + omega + calc Tc + 1 + 1 ≤ rb + 2 := by omega + _ ≤ 3 * (rb + 2) := by omega + _ ≤ mu f * (rb + 2) := Nat.mul_le_mul_right _ hmuf + · -- the first half succeeded: advance the phase + set f' : Frm := { f with ph := true } with hf' + have hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ + = ⟨false, a, none, f' :: fs⟩ := by + rw [hb, hb1] + exact step_ret_true_of_ph_false br ba z a f fs hph + obtain ⟨hd, hs⟩ := child_phase br ba z hne hcr hstep rfl + have hval : frameVal br ba z f' = frameVal br ba z f := rfl + have hmu' : mu f = mu f' + 1 := by + have h1 : mu f' = 2 * midRem f.m := by rw [hf', mu]; simp + have h2 : mu f = 2 * midRem f.m + 1 := mu_of_ph_false hph + omega + have hok' : FrmOk br z f' := + ⟨hok.mlen, by intro _; rw [hf', hdrop]; exact hb1⟩ + obtain ⟨T', hT', hr'⟩ := IH f' (by omega) hlen hok' fs a + refine ⟨T' + (Tc + 1 + 1), ?_, runsTo_prepend br ba z hd hs hr' hval⟩ + have hexp : mu f * (rb + 2) = mu f' * (rb + 2) + (rb + 2) := by + rw [hmu']; ring + omega + · -- descending into the second half + have hb : frameVal br ba z (child z f) + = (if f.kind then accB br ba z n f.m else rchB br z n f.m f.v) := by + rw [frameVal_child_of_ph_true br ba z hz hph, hdrop] + have hfirst : rchB br z t.length f.u f.m = true := by + have := hok.phase hph + rwa [hdrop, ← htn] at this + have hmv : midVal br ba z t.length f + = (if f.kind then accB br ba z n f.m else rchB br z n f.m f.v) := by + rw [midVal, hfirst, Bool.true_and, htn] + cases hb2 : (if f.kind then accB br ba z n f.m else rchB br z n f.m f.v) + · cases hov : bumpOver f.m + · set f'' : Frm := { f with ph := false, m := bumpBits f.m } with hf'' + have hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ + = ⟨false, a, none, f'' :: fs⟩ := by + rw [hb, hb2] + exact step_ret_false_bump br ba z a f fs hov + obtain ⟨hd, hs⟩ := child_phase br ba z hne hcr hstep rfl + have hokv : midVal br ba z t.length f = false := by rw [hmv, hb2] + have hval : frameVal br ba z f'' = frameVal br ba z f := by + rw [frameVal_of_bump br ba z hl hov, hokv, Bool.false_or] + have hmu'' : mu f = mu f'' + 1 := by + have h1 : mu f'' = 2 * midRem (bumpBits f.m) + 1 := by rw [hf'', mu]; simp + have h2 : mu f = 2 * midRem f.m := mu_of_ph_true hph + have h3 := midRem_bump hov + omega + have hok'' : FrmOk br z f'' := + ⟨by rw [hf'']; simpa using hok.mlen, by rw [hf'']; simp⟩ + obtain ⟨T', hT', hr'⟩ := IH f'' (by omega) hlen hok'' fs a + refine ⟨T' + (Tc + 1 + 1), ?_, runsTo_prepend br ba z hd hs hr' hval⟩ + have hexp : mu f * (rb + 2) = mu f'' * (rb + 2) + (rb + 2) := by + rw [hmu'']; ring + omega + · have hokv : midVal br ba z t.length f = false := by rw [hmv, hb2] + have hval : frameVal br ba z f = false := by + rw [frameVal_of_last br ba z hl hov, hokv] + have hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ + = ⟨false, a, some (frameVal br ba z f), fs⟩ := by + rw [hb, hb2, hval] + exact step_ret_false_over br ba z a f fs hov + obtain ⟨hd, hs⟩ := child_phase br ba z hne hcr hstep rfl + refine ⟨Tc + 1 + 1, ?_, by omega, hd, hs⟩ + have hmuf : 2 ≤ mu f := by + have h2 : mu f = 2 * midRem f.m := mu_of_ph_true hph + rw [midRem_of_over hov] at h2 + omega + calc Tc + 1 + 1 ≤ rb + 2 := by omega + _ ≤ 2 * (rb + 2) := by omega + _ ≤ mu f * (rb + 2) := Nat.mul_le_mul_right _ hmuf + · have hval : frameVal br ba z f = true := + frameVal_of_mid br ba z hl (by rw [hmv, hb2]) + have hstep : step br ba z ⟨false, a, some (frameVal br ba z (child z f)), f :: fs⟩ + = ⟨false, a, some (frameVal br ba z f), fs⟩ := by + rw [hb, hb2, hval] + exact step_ret_true_ph br ba z a f fs hph + obtain ⟨hd, hs⟩ := child_phase br ba z hne hcr hstep rfl + refine ⟨Tc + 1 + 1, ?_, by omega, hd, hs⟩ + have hmuf : 2 ≤ mu f := by + have h2 : mu f = 2 * midRem f.m := mu_of_ph_true hph + have := midRem_pos f.m + omega + calc Tc + 1 + 1 ≤ rb + 2 := by omega + _ ≤ 2 * (rb + 2) := by omega + _ ≤ mu f * (rb + 2) := Nat.mul_le_mul_right _ hmuf + +/-- **Every pushed frame comes back.** A frame at level `n` is popped again, +carrying its value, within `runBound` steps, and the done flag stays down for +the whole of that run. -/ +theorem run_frame (hz : binValLE z = 0) : + ∀ (n : ℕ) (f : Frm), f.lvl.length = n → FrmOk br z f → ∀ (fs : List Frm) (a : Bool), + ∃ T ≤ runBound z.length n, RunsTo br ba z f fs a T := by + intro n + induction n with + | zero => + intro f hlen _ fs a + have hl : f.lvl = [] := List.length_eq_zero_iff.mp hlen + have hstep : step br ba z ⟨false, a, none, f :: fs⟩ + = ⟨false, a, some (frameVal br ba z f), fs⟩ := by + rw [frameVal_of_nil br ba z hl] + exact step_base br ba z a f fs hl + refine ⟨1, by rw [runBound], Nat.one_pos, ?_, by rw [Function.iterate_one, hstep]⟩ + exact doneDown_succ br ba z (doneDown_zero br ba z rfl) + (by rw [Function.iterate_one, hstep]) + | succ n IH => + intro f hlen hok fs a + obtain ⟨T, hT, hr⟩ := run_aux br ba z hz n IH (mu f) f le_rfl hlen hok fs a + refine ⟨T, ?_, hr⟩ + rw [runBound] + exact le_trans hT (Nat.mul_le_mul_right _ (mu_le z hok.mlen)) + +/-! ## The enumeration covers every candidate -/ + +theorem anyMid_of_lt {P : List Bool → Bool} {m : List Bool} {i j : ℕ} (hij : i < j) + (h : P (bumpBits^[i] m) = true) : anyMid P m j = true := by + induction j generalizing m i with + | zero => omega + | succ j ih => + rw [anyMid_succ] + cases i with + | zero => rw [Function.iterate_zero_apply] at h; rw [h]; rfl + | succ i => + rw [Function.iterate_succ_apply] at h + rw [ih (by omega) h, Bool.or_true] + +theorem exists_of_anyMid {P : List Bool → Bool} {m : List Bool} {j : ℕ} + (h : anyMid P m j = true) : ∃ i < j, P (bumpBits^[i] m) = true := by + induction j generalizing m with + | zero => simp at h + | succ j ih => + rw [anyMid_succ, Bool.or_eq_true] at h + rcases h with h | h + · exact ⟨0, by omega, by simpa using h⟩ + · obtain ⟨i, hi, hP⟩ := ih h + exact ⟨i + 1, by omega, by rwa [Function.iterate_succ_apply]⟩ + +/-- **Every string of the enumeration's width is tried.** -/ +theorem anyMid_of_length {P : List Bool → Bool} {z w : List Bool} (hz : binValLE z = 0) + (hw : w.length = z.length) (h : P w = true) : anyMid P z (2 ^ z.length) = true := by + have hzb : bitsOfLenLE z.length 0 = z := by + have := bitsOfLenLE_binValLE z + rwa [hz] at this + have hv : binValLE w < 2 ^ z.length := by + have := binValLE_lt w + rwa [hw] at this + have hstep : bumpBits^[binValLE w] z = w := by + have := bumpBits_iterate z.length (binValLE w) hv + rw [hzb] at this + rw [this, ← hw, bitsOfLenLE_binValLE] + exact anyMid_of_lt hv (by rw [hstep]; exact h) + +/-! ## The stack invariant the encoding needs -/ + +/-- Nothing is returning only while the stack is nonempty. -/ +def StkOk (s : Sst) : Prop := s.stk = [] → s.ret ≠ none + +theorem step_stkOk {s : Sst} (h : StkOk s) : StkOk (step br ba z s) := by + obtain ⟨d, a, r, stk⟩ := s + cases d + · cases stk with + | nil => + obtain ⟨b, rfl⟩ : ∃ b, r = some b := by + cases r with + | none => exact absurd rfl (h rfl) + | some b => exact ⟨b, rfl⟩ + rw [step_of_empty] + intro _ + simp + | cons f fs => + cases r with + | none => + by_cases hl : f.lvl = [] + · rw [step_base _ _ _ a f fs hl] + intro _ + simp + · rw [step_push _ _ _ a f fs hl] + intro hc + simp at hc + | some b => + cases b + · cases hov : bumpOver f.m + · rw [step_ret_false_bump _ _ _ a f fs hov] + intro hc + simp at hc + · rw [step_ret_false_over _ _ _ a f fs hov] + intro _ + simp + · cases hp : f.ph + · rw [step_ret_true_of_ph_false _ _ _ a f fs hp] + intro hc + simp at hc + · rw [step_ret_true_ph _ _ _ a f fs hp] + intro _ + simp + · rw [step_of_done] + exact h + +/-! ## The number of steps is at most exponential in a polynomial -/ + +theorem runBound_pos (W : ℕ) : ∀ n, 0 < runBound W n := by + intro n + induction n with + | zero => rw [runBound]; omega + | succ n ih => + rw [runBound] + have : 0 < 2 * 2 ^ W + 1 := by omega + exact Nat.mul_pos this (by omega) + +theorem runBound_le (W : ℕ) : ∀ n, runBound W n + 2 ≤ 2 ^ ((W + 3) * n + 2) := by + intro n + induction n with + | zero => rw [runBound]; norm_num + | succ n ih => + have h1 : (1 : ℕ) ≤ 2 ^ W := Nat.one_le_two_pow + have hA : 2 * 2 ^ W + 2 ≤ 2 ^ (W + 3) := by + have h8 : 2 ^ (W + 3) = 8 * 2 ^ W := by rw [pow_add]; ring + omega + have hc : 2 ≤ runBound W n + 2 := by omega + have hstep : runBound W (n + 1) + 2 ≤ (2 * 2 ^ W + 2) * (runBound W n + 2) := by + rw [runBound] + calc (2 * 2 ^ W + 1) * (runBound W n + 2) + 2 + ≤ (2 * 2 ^ W + 1) * (runBound W n + 2) + (runBound W n + 2) := by omega + _ = (2 * 2 ^ W + 2) * (runBound W n + 2) := by ring + calc runBound W (n + 1) + 2 + ≤ (2 * 2 ^ W + 2) * (runBound W n + 2) := hstep + _ ≤ 2 ^ (W + 3) * 2 ^ ((W + 3) * n + 2) := Nat.mul_le_mul hA ih + _ = 2 ^ ((W + 3) * (n + 1) + 2) := by rw [← pow_add]; ring_nf + +/-! ## The whole run -/ + +/-- **The recursion terminates with its answer.** From the state carrying one +frame, the machine keeps its done flag down for `T` steps, raises it on the next +one, and one step later the flag *is* the answer. -/ +theorem run_top (hz : binValLE z = 0) (root : Frm) (hok : FrmOk br z root) : + ∃ T ≤ runBound z.length root.lvl.length, + (∀ j ≤ T, ((step br ba z)^[j] ⟨false, false, none, [root]⟩).done = false) ∧ + (step br ba z)^[T + 1] ⟨false, false, none, [root]⟩ + = ⟨true, frameVal br ba z root, some (frameVal br ba z root), []⟩ ∧ + (step br ba z)^[T + 2] ⟨false, false, none, [root]⟩ + = ⟨frameVal br ba z root, frameVal br ba z root, some (frameVal br ba z root), []⟩ := by + obtain ⟨T, hT, hpos, hdd, hend⟩ := + run_frame br ba z hz root.lvl.length root rfl hok [] false + have h1 : (step br ba z)^[T + 1] ⟨false, false, none, [root]⟩ + = ⟨true, frameVal br ba z root, some (frameVal br ba z root), []⟩ := by + rw [Function.iterate_succ_apply', hend, step_of_empty] + rfl + refine ⟨T, hT, hdd, h1, ?_⟩ + rw [show T + 2 = T + 1 + 1 from rfl, Function.iterate_succ_apply', h1, step_of_done] + +/-! ## The size of the state -/ + +/-- The three codes a frame carries fit in `Wm` bits. -/ +def FrmSize (Wm : ℕ) (f : Frm) : Prop := + f.u.length ≤ Wm ∧ f.v.length ≤ Wm ∧ f.m.length ≤ Wm + +/-- The stack descends exactly one level per frame — which is what bounds its +depth — and every frame's codes fit. -/ +def StkSize (Lmax Wm : ℕ) : List Frm → Prop + | [] => True + | f :: fs => fs.length + f.lvl.length = Lmax ∧ FrmSize Wm f ∧ StkSize Lmax Wm fs + +theorem StkSize.length_le {Lmax Wm : ℕ} : + ∀ {stk : List Frm}, StkSize Lmax Wm stk → stk.length ≤ Lmax + 1 + | [], _ => by simp + | f :: fs, h => by + rw [List.length_cons] + have := h.1 + omega + +theorem StkSize.mem_bound {Lmax Wm : ℕ} : + ∀ {stk : List Frm}, StkSize Lmax Wm stk → + ∀ f ∈ stk, f.lvl.length ≤ Lmax ∧ FrmSize Wm f + | [], _ => by simp + | g :: fs, h => by + intro f hf + rcases List.mem_cons.mp hf with rfl | hf + · exact ⟨by have := h.1; omega, h.2.1⟩ + · exact StkSize.mem_bound h.2.2 f hf + +theorem step_stkSize {Lmax Wm : ℕ} {s : Sst} (hzw : z.length ≤ Wm) + (h : StkSize Lmax Wm s.stk) : StkSize Lmax Wm (step br ba z s).stk := by + obtain ⟨d, a, r, stk⟩ := s + cases d + · cases stk with + | nil => cases r <;> simp [step, StkSize] + | cons f fs => + obtain ⟨hd, hfs, hrest⟩ := h + cases r with + | none => + by_cases hl : f.lvl = [] + · rw [step_base _ _ _ a f fs hl] + exact hrest + · rw [step_push _ _ _ a f fs hl] + have hpos : 1 ≤ f.lvl.length := by + cases hlv : f.lvl with + | nil => exact absurd hlv hl + | cons _ t => simp + refine ⟨?_, ?_, hd, hfs, hrest⟩ + · rw [child_lvl, List.length_drop, List.length_cons] + omega + · rw [FrmSize, child_m] + refine ⟨?_, ?_, hzw⟩ <;> rw [child] <;> split_ifs <;> + first + | exact hfs.1 + | exact hfs.2.1 + | exact hfs.2.2 + | exact hzw + | some b => + cases b + · cases hov : bumpOver f.m + · rw [step_ret_false_bump _ _ _ a f fs hov] + exact ⟨hd, ⟨hfs.1, hfs.2.1, by rw [bumpBits_length]; exact hfs.2.2⟩, hrest⟩ + · rw [step_ret_false_over _ _ _ a f fs hov] + exact hrest + · cases hp : f.ph + · rw [step_ret_true_of_ph_false _ _ _ a f fs hp] + exact ⟨hd, hfs, hrest⟩ + · rw [step_ret_true_ph _ _ _ a f fs hp] + exact hrest + · rw [step_of_done] + exact h + +theorem iterate_stkSize {Lmax Wm : ℕ} (hzw : z.length ≤ Wm) : + ∀ (j : ℕ) (s : Sst), StkSize Lmax Wm s.stk → + StkSize Lmax Wm ((step br ba z)^[j] s).stk := by + intro j + induction j with + | zero => intro s h; exact h + | succ j ih => + intro s h + rw [Function.iterate_succ_apply] + exact ih _ (step_stkSize br ba z hzw h) + +end Sav +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchSim.lean b/Complexitylib/Classes/Containments/Internal/SavitchSim.lean new file mode 100644 index 00000000..b80e6064 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SavitchSim.lean @@ -0,0 +1,286 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchSem +public import Complexitylib.Classes.Containments.Internal.SavitchStep +public import Complexitylib.Classes.Containments.Internal.BinArith + +/-! +# The encoded step simulates the abstract one + +⚠️ Unreviewed by Bolton + +`Complexity.savStep` is Savitch's recursion written on a bitstring, so that it +lands in `FP`; `Complexity.Sav.step` is the same recursion on an inductive state, +where it can be reasoned about. This file writes the encoding down and proves the +square commutes. + +## Main definitions + +- `Complexity.encFrm`, `Complexity.encSst` — the encoding of a frame and a state +- `Complexity.savSem` — the abstract step the encoded one simulates + +## Main results + +- `Complexity.savStep_encSst` — one encoded step is one abstract step +- `Complexity.savStep_iterate_encSst` — hence so is any number of them +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +variable {k : ℕ} + +/-! ## Flags as booleans -/ + +/-- The base reachability test, as a boolean. -/ +noncomputable def baseReachB (tm : NTM k) (R u v : List Bool) : Bool := + (baseReach tm R u v).headD false + +/-- The base acceptance test, as a boolean. -/ +noncomputable def baseAccB (tm : NTM k) (R rl u : List Bool) : Bool := + (baseAcc tm R rl u).headD false + +theorem baseReach_eq (tm : NTM k) (R u v : List Bool) : + baseReach tm R u v = [baseReachB tm R u v] := by + rcases baseReach_flag tm R u v with h | h <;> rw [baseReachB, h] <;> rfl + +theorem baseAcc_eq (tm : NTM k) (R rl u : List Bool) : + baseAcc tm R rl u = [baseAccB tm R rl u] := by + rcases baseAcc_flag tm R rl u with h | h <;> rw [baseAccB, h] <;> rfl + +/-! ## The encoding -/ + +/-- A returned value on the tape. -/ +def encOpt : Option Bool → List Bool + | none => [] + | some b => [b] + +@[simp] theorem encOpt_none : encOpt none = [] := rfl + +@[simp] theorem encOpt_some (b : Bool) : encOpt (some b) = [b] := rfl + +/-- A frame on the tape. -/ +def encFrm (f : Sav.Frm) : List Bool := mkFrame [f.kind] [f.ph] f.lvl f.u f.v f.m + +/-- A state on the tape. -/ +def encSst (R : List Bool) (s : Sav.Sst) : List Bool := + mkSt [s.done] [s.ans] R (encOpt s.ret) (encStack (s.stk.map encFrm)) + +/-- The abstract step the encoded one runs. -/ +noncomputable def savSem (tm : NTM k) (R : List Bool) : Sav.Sst → Sav.Sst := + Sav.step (baseReachB tm R) (fun u => baseAccB tm R (savRuler k R) u) (savZero k R) + +/-! ## The square commutes -/ + +@[simp] theorem stDone_encSst (R : List Bool) (s : Sav.Sst) : + stDone (encSst R s) = [s.done] := by rw [encSst, stDone_mk] + +@[simp] theorem stAns_encSst (R : List Bool) (s : Sav.Sst) : + stAns (encSst R s) = [s.ans] := by rw [encSst, stAns_mk] + +@[simp] theorem stR_encSst (R : List Bool) (s : Sav.Sst) : + stR (encSst R s) = R := by rw [encSst, stR_mk] + +@[simp] theorem stRet_encSst (R : List Bool) (s : Sav.Sst) : + stRet (encSst R s) = encOpt s.ret := by rw [encSst, stRet_mk] + +@[simp] theorem stStk_encSst (R : List Bool) (s : Sav.Sst) : + stStk (encSst R s) = encStack (s.stk.map encFrm) := by rw [encSst, stStk_mk] + +@[simp] theorem frKind_encFrm (f : Sav.Frm) : frKind (encFrm f) = [f.kind] := by + rw [encFrm, frKind_mk] + +@[simp] theorem frPh_encFrm (f : Sav.Frm) : frPh (encFrm f) = [f.ph] := by + rw [encFrm, frPh_mk] + +@[simp] theorem frLvl_encFrm (f : Sav.Frm) : frLvl (encFrm f) = f.lvl := by + rw [encFrm, frLvl_mk] + +@[simp] theorem frU_encFrm (f : Sav.Frm) : frU (encFrm f) = f.u := by + rw [encFrm, frU_mk] + +@[simp] theorem frV_encFrm (f : Sav.Frm) : frV (encFrm f) = f.v := by + rw [encFrm, frV_mk] + +@[simp] theorem frM_encFrm (f : Sav.Frm) : frM (encFrm f) = f.m := by + rw [encFrm, frM_mk] + +/-- **One encoded step is one abstract step.** The side condition rules out the +one shape the encoding cannot express: an empty stack with nothing returning. -/ +theorem savStep_encSst (tm : NTM k) (R : List Bool) (s : Sav.Sst) + (hne : s.stk = [] → s.ret ≠ none) : + savStep tm (encSst R s) = encSst R (savSem tm R s) := by + obtain ⟨d, a, r, stk⟩ := s + rw [savSem] + cases d + · cases stk with + | nil => + obtain ⟨b, rfl⟩ : ∃ b, r = some b := by + cases r with + | none => exact absurd rfl (hne rfl) + | some b => exact ⟨b, rfl⟩ + rw [Sav.step_of_empty] + simp [savStep, encSst, encOpt] + | cons f fs => + cases r with + | none => + by_cases hl : f.lvl = [] + · rw [Sav.step_base _ _ _ a f fs hl] + cases hk : f.kind + · simp [savStep, savDescend, savTop, savRest, stkTop, stkRest, encSst, encFrm, encOpt, + emptyFlag_pair, hl, hk, Sav.baseVal, baseReach_eq] + · simp [savStep, savDescend, savTop, savRest, stkTop, stkRest, encSst, encFrm, encOpt, + emptyFlag_pair, hl, hk, Sav.baseVal, baseAcc_eq] + · rw [Sav.step_push _ _ _ a f fs hl] + obtain ⟨c, t, hct⟩ : ∃ c t, f.lvl = c :: t := by + cases hlv : f.lvl with + | nil => exact absurd hlv hl + | cons c t => exact ⟨c, t, rfl⟩ + cases hp : f.ph + · simp [savStep, savDescend, savChild, savTop, savRest, stkTop, stkRest, + encSst, encFrm, + encOpt, emptyFlag_pair, emptyFlag_cons, hct, hp, Sav.child, dropOne] + · cases hk : f.kind + · simp [savStep, savDescend, savChild, savTop, savRest, stkTop, stkRest, + encSst, encFrm, + encOpt, emptyFlag_pair, emptyFlag_cons, hct, hp, hk, Sav.child, dropOne] + · simp [savStep, savDescend, savChild, savTop, savRest, stkTop, stkRest, + encSst, encFrm, + encOpt, emptyFlag_pair, emptyFlag_cons, hct, hp, hk, Sav.child, dropOne] + | some b => + cases b + · cases hov : bumpOver f.m + · rw [Sav.step_ret_false_bump _ _ _ a f fs hov] + simp [savStep, savReturn, savAdvance, savTop, savRest, stkTop, stkRest, + encSst, encFrm, + encOpt, emptyFlag_pair, emptyFlag_cons, hov] + · rw [Sav.step_ret_false_over _ _ _ a f fs hov] + simp [savStep, savReturn, savAdvance, savTop, savRest, stkTop, stkRest, + encSst, encFrm, + encOpt, emptyFlag_pair, emptyFlag_cons, hov] + · cases hp : f.ph + · rw [Sav.step_ret_true_of_ph_false _ _ _ a f fs hp] + simp [savStep, savReturn, savTop, savRest, stkTop, stkRest, encSst, encFrm, encOpt, + emptyFlag_pair, emptyFlag_cons, hp] + · rw [Sav.step_ret_true_ph _ _ _ a f fs hp] + simp [savStep, savReturn, savTop, savRest, stkTop, stkRest, encSst, encFrm, encOpt, + emptyFlag_pair, emptyFlag_cons, hp] + · rw [Sav.step_of_done] + simp [savStep, encSst, encOpt] + +/-! ## Iterating -/ + +theorem encSst_ne_nil (R : List Bool) (s : Sav.Sst) : encSst R s ≠ [] := + mkSt_ne_nil _ _ _ _ _ + +theorem savStep_iterate (tm : NTM k) (R : List Bool) : + ∀ (j : ℕ) (s : Sav.Sst), Sav.StkOk s → + (savStep tm)^[j] (encSst R s) = encSst R ((savSem tm R)^[j] s) := by + intro j + induction j with + | zero => intro s _; rfl + | succ j ih => + intro s h + rw [Function.iterate_succ_apply, Function.iterate_succ_apply, + savStep_encSst tm R s h] + exact ih _ (Sav.step_stkOk _ _ _ h) + +/-- The root frame the recursion starts from. -/ +noncomputable def savRoot (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : Sav.Frm := + ⟨true, false, polyRuler lp x, initRecord tm (savR qp x) x, savZero k (savR qp x), + savZero k (savR qp x)⟩ + +/-- The state `Complexity.savInit` builds, decoded. -/ +noncomputable def savInitSst (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : Sav.Sst := + ⟨false, false, none, [savRoot tm qp lp x]⟩ + +theorem savInit_eq (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : + savInit tm qp lp x = encSst (savR qp x) (savInitSst tm qp lp x) := rfl + +theorem savSem_iterate_stkOk (tm : NTM k) (R : List Bool) : + ∀ (j : ℕ) (s : Sav.Sst), Sav.StkOk s → Sav.StkOk ((savSem tm R)^[j] s) := by + intro j + induction j with + | zero => intro s h; exact h + | succ j ih => + intro s h + rw [Function.iterate_succ_apply] + exact ih _ (Sav.step_stkOk _ _ _ h) + +theorem savInitSst_stkOk (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : + Sav.StkOk (savInitSst tm qp lp x) := by + intro hc + rw [savInitSst] at hc + simp at hc + +/-- **The packed orbit is the abstract one.** -/ +theorem savG_iterate (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : + ∀ j : ℕ, (savG tm qp lp)^[j + 1] (pair [] x) + = pair (encSst (savR qp x) + ((savSem tm (savR qp x))^[j] (savInitSst tm qp lp x))) x := by + intro j + induction j with + | zero => + rw [Function.iterate_one, savG_nil, savInit_eq] + rfl + | succ j ih => + have hst : Sav.StkOk ((savSem tm (savR qp x))^[j] (savInitSst tm qp lp x)) := + savSem_iterate_stkOk tm _ j _ (savInitSst_stkOk tm qp lp x) + rw [Function.iterate_succ_apply', ih, savG_step _ _ _ _ _ (encSst_ne_nil _ _), + savStep_encSst tm _ _ hst, Function.iterate_succ_apply'] + +/-- The head of a packed state is its done flag. -/ +theorem headD_pair_encSst (R : List Bool) (s : Sav.Sst) (x : List Bool) : + (pair (encSst R s) x).headD false = s.done := by + rw [encSst, mkSt, pair_cons_eq, pair_cons_eq] + rfl + +/-! ## How long an encoded state is -/ + +theorem encStack_length_le : ∀ (fs : List (List Bool)) (B : ℕ), (∀ f ∈ fs, f.length ≤ B) → + (encStack fs).length ≤ fs.length * (2 * B + 2) + | [], _, _ => by simp + | f :: fs, B, h => by + have hf : f.length ≤ B := h f List.mem_cons_self + have hrest := encStack_length_le fs B fun g hg => h g (List.mem_cons_of_mem _ hg) + rw [encStack_cons, pair_length, List.length_cons, + show (fs.length + 1) * (2 * B + 2) = fs.length * (2 * B + 2) + (2 * B + 2) from by ring] + omega + +theorem encFrm_length_le {Lmax Wm : ℕ} {f : Sav.Frm} (hl : f.lvl.length ≤ Lmax) + (hs : Sav.FrmSize Wm f) : (encFrm f).length ≤ 2 * Lmax + 5 * Wm + 14 := by + obtain ⟨h1, h2, h3⟩ := hs + rw [encFrm, mkFrame_length] + simp only [List.length_cons, List.length_nil] + omega + +/-- **An encoded state is polynomially long.** -/ +theorem encSst_length_le {Lmax Wm : ℕ} (R : List Bool) (s : Sav.Sst) + (h : Sav.StkSize Lmax Wm s.stk) : + (encSst R s).length + ≤ 2 * R.length + (Lmax + 1) * (2 * (2 * Lmax + 5 * Wm + 14) + 2) + 14 := by + have hall : ∀ g ∈ s.stk.map encFrm, g.length ≤ 2 * Lmax + 5 * Wm + 14 := by + intro g hg + obtain ⟨f, hf, rfl⟩ := List.mem_map.mp hg + obtain ⟨hl, hs⟩ := Sav.StkSize.mem_bound h f hf + exact encFrm_length_le hl hs + have hstk := encStack_length_le (s.stk.map encFrm) _ hall + have hlen : (s.stk.map encFrm).length ≤ Lmax + 1 := by + rw [List.length_map] + exact Sav.StkSize.length_le h + have hmul : (s.stk.map encFrm).length * (2 * (2 * Lmax + 5 * Wm + 14) + 2) + ≤ (Lmax + 1) * (2 * (2 * Lmax + 5 * Wm + 14) + 2) := Nat.mul_le_mul_right _ hlen + have hret : (encOpt s.ret).length ≤ 1 := by + cases s.ret <;> simp + rw [encSst, mkSt_length] + simp only [List.length_cons, List.length_nil] + omega + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/SavitchStep.lean b/Complexitylib/Classes/Containments/Internal/SavitchStep.lean index 50978e79..80bd7c7a 100644 --- a/Complexitylib/Classes/Containments/Internal/SavitchStep.lean +++ b/Complexitylib/Classes/Containments/Internal/SavitchStep.lean @@ -7,6 +7,7 @@ module public import Complexitylib.Classes.Containments.Internal.SavitchFrame public import Complexitylib.Classes.Containments.Internal.CodeAccept public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble +public import Complexitylib.Classes.Containments.Internal.BinArith /-! # One step of Savitch's stack machine @@ -53,23 +54,6 @@ variable {k : ℕ} /-! ## Reading the state -/ -/-- Is the string empty, as a flag. -/ -def emptyFlag (y : List Bool) : List Bool := lenLeFlag [] y - -@[simp] theorem emptyFlag_nil : emptyFlag [] = [true] := rfl - -theorem emptyFlag_cons (b : Bool) (y : List Bool) : emptyFlag (b :: y) = [false] := by - rw [emptyFlag, lenLeFlag] - simp [nonemptyFlag, notBit] - -theorem emptyFlag_pair (a b : List Bool) : emptyFlag (pair a b) = [false] := by - cases a with - | nil => rw [pair]; rfl - | cons c a => rw [pair_cons_eq]; exact emptyFlag_cons _ _ - -/-- Drop the leading bit. -/ -def dropOne (y : List Bool) : List Bool := y.drop 1 - /-- The frame on top of the state's stack. -/ def savTop (s : List Bool) : List Bool := stkTop (stStk s) @@ -211,15 +195,6 @@ theorem savG_step (tm : NTM k) (qp lp : Polynomial ℕ) (s x : List Bool) (hs : /-! ## The step is polynomial-time -/ -theorem emptyFlagFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : - (fun z => emptyFlag (a z)) ∈ FP := - lenLeFlagFn_mem_FP (constFn_mem_FP []) ha - -theorem dropOneFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : - (fun z => dropOne (a z)) ∈ FP := by - have := dropLenFn_mem_FP (constFn_mem_FP [false]) ha - simpa [dropOne] using this - theorem savRulerFn_mem_FP (k : ℕ) {a : List Bool → List Bool} (ha : a ∈ FP) : (fun z => savRuler k (a z)) ∈ FP := wideRulerFn_mem_FP ha (codeBlocks k) diff --git a/Complexitylib/Classes/Containments/Internal/SuccMachine.lean b/Complexitylib/Classes/Containments/Internal/SuccMachine.lean new file mode 100644 index 00000000..cc0253c3 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/SuccMachine.lean @@ -0,0 +1,5125 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BlockScan +public import Complexitylib.Models.TuringMachine.Subroutines.InputMatch +public import Complexitylib.Models.TuringMachine.Subroutines.WriteOutputBit +public import Complexitylib.Models.TuringMachine.Combinators.Internal.LoopIteration +public import Complexitylib.Classes.Containments.Internal.CountingCert +public import Complexitylib.Models.TuringMachine.GuessAssembly +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryFor +public import Complexitylib.Models.TuringMachine.Placement.Hoare +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import Complexitylib.Models.TuringMachine.Combinators.Internal.LoopIndexed + +/-! +# Assembling the successor check + +⚠️ Unreviewed by Bolton + +`Complexitylib.Classes.Containments.Internal.BlockScan` proves what the scans decide, in terms of +what the registers hold. `Complexitylib.Models.TuringMachine.GuessAssembly` proves what the guess +machinery puts on a register. This file is where the two meet: a block of guesses written onto a +register is a register the scans can read. + +## Main results + +- `Complexity.holdsBits_of_guessBlock` — a written block of guesses is a register holding those + bits +- `Complexity.ofTable_state` — the state a scan reads off a code's state register +- `Complexity.blockEmit_work`, `Complexity.blockEmit_output`, `Complexity.inHeadEmit_code` — what + each scan says about the code the registers hold +- `Complexity.mem_codeSucc_of_scans` — and together: the scans decide `codeSucc` membership +- `Complexity.HoldsCode.inj` — the registers determine the code, so comparing registers compares + codes +- `Complexity.codeBlock`, `Complexity.codeWidth`, `Complexity.codeRegsOf` — the block layout a + code guess uses +- `Complexity.holdsCode_of_guessBlocks`, `Complexity.holdsCode_of_guessStage`, + `Complexity.holdsCode_of_stage` — a guess stage can lay down any code, the rewind that follows + it does not disturb one, and a stage of a loop lays down the code its stream names +- `Complexity.codeBlockScan`, `Complexity.HoldsCodeScan`, `Complexity.holdsCodeScan_of_blocks` — + the padded layout the walk's checks read, and that a guess lays it down +- `Complexity.eqScanner`, `Complexity.eqScanner_decides`, `Complexity.eqScanner_accepts` — one + comparison per block, in one scan, deciding that two guesses are the same code — and accepting + when they are +- `Complexity.succScanner`, `Complexity.succScanner_verdicts` — and every successor check in one + scan, with each component's verdict recovered +- `Complexity.succScanner_decides` — that scan decides a successor step +- `Complexity.succScanner_accepts` — and accepts a genuine one, which is what says the right guess + exists +- `Complexity.walkCodeScanner`, `Complexity.walkCodeScanner_decides` — both halves together: + one scan whose verdict is exactly one step of the walk, together with the direction the input + head is to take +- `Complexity.walkCodeScanner_accepts_stay`, `Complexity.walkCodeScanner_accepts_succ` — and + accepts either kind of genuine step +- `Complexity.walkStepScanner`, `Complexity.walkStepScanner_decides`, + `Complexity.walkStepScanner_accepts`, `Complexity.walkStepScanner_accepts_stay`, + `Complexity.walkStepScanner_accepts_succ` — and with the counter, the whole verdict of a step, + in both directions +- `Complexity.rulerBlock`, `Complexity.scanTape_of_ruler`, `Complexity.ruler_of_holds` — the + guessed register that fixes the scan's length +- `Complexity.checkedCells`, `Complexity.checkPhase_hoareTime` — the input check and the scan in + sequence, with the check's verdict on a register the scan reads +- `Complexity.checkMove_hoareTime` — and with the input head's move, the whole guess-free part of + a walk step +- `Complexity.verdictCells`, `Complexity.verdictCells_acc_one` — and the register a verdict is + published on +- `Complexity.loopTestScanner`, `Complexity.loopTestScanner_decides`, + `Complexity.loopTestScanner_of_fail`, `Complexity.loopTestTM`, + `Complexity.publishTestTM_hoareTime` — the loop's test: stop when the counter reaches its target + or a check has failed, with the verdict published where `TM.loopTM` reads it +- `Complexity.counterStepScanner`, `Complexity.counterStepScanner_decides`, + `Complexity.counterStepScanner_accepts` — the counter check of a step: stay, or advance by one +- `Complexity.mem_reachCodes_of_pairWalk` — a walk of even length reaches whatever a shorter one + does +- `Complexity.DirCodec`, `Complexity.dirCodec`, `Complexity.move_head_of_dir` — a direction in one + cell, and that the input head lands where the code says +- `Complexity.adjustedDir`, `Complexity.move_adjusted`, `Complexity.dirCheckScanner`, + `Complexity.dirCheckScanner_decides`, `Complexity.dirCheckScanner_accepts` — and the direction a + head pinned away from the marker must actually take, decided and accepted +- `Complexity.move_of_walkStep`, `Complexity.move_of_walkStay`, + `Complexity.walkStep_transports` — a step carries the input head to where the next code says, + and its code is one step of the walk +- `Complexity.succ_fields_of_eq` — a genuine successor's fields are what the checks compare + against +- `Complexity.WalkLayout`, `Complexity.WalkWidths` — which register plays which role in the walk, + and how wide each is guessed +- `Complexity.stageBits`, `Complexity.walkCert` — what one stage of the walk must guess into each + of them, and the certificate for a whole walk +- `Complexity.stageCells`, `Complexity.stageCols` — the registers a stage leaves, as the scan + sees them +- `Complexity.stage_accepts_stay`, `Complexity.stage_accepts_succ` — a stage of a real walk is + accepted, whichever kind of step it takes +- `Complexity.guessFrom_after_stage` — and the guess tape is left ready for the next stage +- `Complexity.holdsBits_block_of_stage`, `Complexity.cell_of_stage` and their instances for the + code tuples, the parameter block, the counters, the direction cells and the ruler — after a + stage, each register holds what the certificate names +- `Complexity.walkReg`, `Complexity.WalkLoopInv`, `Complexity.holdsCounter_of_walkLoopInv`, + `Complexity.inSym_of_walkLoopInv`, `Complexity.guessFrom_of_walkLoopInv` — the walk loop's + invariant: the counter names the iteration, the registers hold the code, the input head sits + where the code says, and the guess tape still holds what the rest of the walk will need +- `Complexity.walkPairTM`, `Complexity.guessProtocol_walkPairTM` — the loop's body: two steps + with the code's registers swapping roles, so no register need be copied +- `Complexity.walkLoopTM`, `Complexity.guessProtocol_walkLoopTM` — the walk as a machine, driven + by `TM.binaryForTM`'s own binary counter, and that only its guess stage consumes guesses +- `Complexity.walkCheckTM`, `Complexity.walkStepTM`, `Complexity.walkStepTM_hoareTime`, + `Complexity.guessProtocol_walkStepTM` — one walk step as a machine: guess, rewind, check the + input symbol, scan, move the input head, and conjoin the verdict into the accumulator; its + contract, and that it respects the guess protocol. The step holds `r` further tapes still + (`TM.liftMany`) — the enclosing loops' counters and the accumulator, none of them guessed, none + of them scanned +- `Complexity.windowParams_congr`, `Complexity.walkParams_eq`, `Complexity.params_of_holds` — all + of those checks read the same guessed parameters, through either of the two readers +- `Complexity.walkScanLen` — a scan length that covers every check of a walk step +- `Complexity.mem_reachCodes_of_walk` — what a walk establishes +- `Complexity.roundList_of_inj` — what the counting establishes +- `Complexity.WalkInv`, `Complexity.counterVal_of_walkInv` — the walk loop's invariant, and that + the counter reads back the loop's index +- `Complexity.walkLoop_hoareTime` — and the loop itself, given a body that carries it forward +- `Complexity.HoldsCounter`, `Complexity.counterLoop_hoareTime` — the general counter-driven loop + rule the walk and both enumerations share +- `Complexity.windowScanner` — the scanner that checks one tape window against its successor +- `Complexity.outputScanner`, `Complexity.headScanner` — the output-window and input-head + checkers +- `Complexity.stateScanner` — the state checker +- `Complexity.dirScanner`, `Complexity.dirScanner_decides` — the checker that pins the guessed + input-head direction, the one cell `TM.inMoveTM` reads +- `Complexity.inSym_cells`, `Complexity.inSym_eq_of_inMatch`, + `Complexity.inMatchVerdict_of_inSym` — the guessed input symbol opens the parameter register, + where `TM.inMatchTM` checks it against the machine's own input tape, in both directions +- `Complexity.headZeroScanner`, `Complexity.headNonZeroScanner` and their decision lemmas — + whether the simulated input head is at the marker, where no tape read is possible +- `Complexity.parStart_iff` — and that the parameter register opens with two ones exactly when the + guessed symbol is the marker +- `Complexity.windowScanner_run`, `Complexity.outputScanner_run`, + `Complexity.headScanner_run`, `Complexity.stateScanner_run` — and what each computes +- `Complexity.windowScanner_decides`, `Complexity.outputScanner_decides`, + `Complexity.headScanner_decides`, `Complexity.stateScanner_decides` — and what each decides + about the code the registers hold +- `Complexity.combineTM`, `Complexity.combineTM_hoareTime`, `Complexity.combineTM_verdict` — and + the machine that combines their verdicts + +## Main definitions + +- `Complexity.CodeRegs` — which register holds which field of a code +- `Complexity.HoldsCode` — and that they hold a given code +-/ + +@[expose] public section + +namespace Complexity + +/-- A machine's state type is nonempty: it has a start state. -/ +instance instNonemptyNTMQ {kk : ℕ} (tm : NTM kk) : Nonempty tm.Q := ⟨tm.qstart⟩ + +variable {m : ℕ} + +/-- **A block of guesses is a register the scans can read.** Writing `n + 1` guessed bits onto a +register parked at cell one leaves it holding exactly those bits. -/ +theorem holdsBits_of_guessBlock (r : Fin (m + 1)) (hr : r ≠ Fin.last m) (n : ℕ) + (W : Fin (m + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : (W r).head = 1) (b : ℕ → Bool) + (hg : ∀ p ≤ n, (W (Fin.last m)).cells ((W (Fin.last m)).head + p) = Γ.ofBool (b p)) : + HoldsBits (fun p i => (TM.guessBlockTapes r n W i).cells p) 0 r + (List.ofFn (fun q : Fin (n + 1) => b q.val)) := by + obtain ⟨-, -, -, -, hcells⟩ := TM.guessBlockTapes_spec r hr n W hinv hh + intro q hq + have hqlt : q < n + 1 := by simpa using hq + show (TM.guessBlockTapes r n W r).cells (0 + q + 1) = _ + rw [show 0 + q + 1 = (W r).head + q by rw [hr1]; omega, hcells q (by omega), + hg q (by omega), List.getElem_ofFn] + +/-- **Several blocks of guesses give several registers to read.** Each target register, parked at +cell one, ends up holding the bits guessed for its own block. -/ +theorem holdsBits_of_guessBlocks (j : ℕ → Fin (m + 1)) (hj : ∀ p, j p ≠ Fin.last m) (w : ℕ → ℕ) + (t : ℕ) (W : Fin (m + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (hinj : ∀ p q, p < t → q < t → j p = j q → p = q) + (hr1 : ∀ p, p < t → (W (j p)).head = 1) (b : ℕ → ℕ → Bool) + (hg : ∀ p, p < t → ∀ q ≤ w p, (W (Fin.last m)).cells + ((W (Fin.last m)).head + TM.guessOffset w p + q) = Γ.ofBool (b p q)) : + ∀ p, p < t → HoldsBits (fun c i => (TM.guessBlocksTapes j w t W i).cells c) 0 (j p) + (List.ofFn (fun q : Fin (w p + 1) => b p q.val)) := by + obtain ⟨-, -, -, -, hblk⟩ := TM.guessBlocksTapes_spec j hj w t W hinv hh hinj + intro p hp q hq + have hqlt : q < w p + 1 := by simpa using hq + show (TM.guessBlocksTapes j w t W (j p)).cells (0 + q + 1) = _ + rw [show 0 + q + 1 = (W (j p)).head + q by rw [hr1 p hp]; omega, + (hblk p hp).2 q (by omega), hg p hp q (by omega), List.getElem_ofFn] + +/-! ## Which register holds which field -/ + +/-- The layout of a configuration code across registers: one for the state, one for the input +head, one per work window, and one for the output window. -/ +structure CodeRegs (kk jj : ℕ) where + /-- The register holding the state. -/ + st : Fin (jj + 1) + /-- The register holding the input head. -/ + hd : Fin (jj + 1) + /-- The registers holding the work windows. -/ + wk : Fin kk → Fin (jj + 1) + /-- The register holding the output window. -/ + ot : Fin (jj + 1) + +/-- Those registers hold the code `a`. -/ +def HoldsCode {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) {jj : ℕ} + (cols : ℕ → Fin (jj + 1) → Γ) (off : ℕ) (R : CodeRegs kk jj) + (a : Code tm.Q kk x.length S) : Prop := + HoldsBits (fun q => cols (off + q)) 0 R.st ((qCodec tm.Q).enc a.1) ∧ + HoldsBits (fun q => cols (off + q)) 0 R.hd ((finCodec (x.length + S + 2)).enc a.2.1) ∧ + (∀ i, HoldsWindow (fun q => cols (off + q)) 0 (R.wk i) (a.2.2.1 i).1 (a.2.2.1 i).2) ∧ + HoldsWindow (fun q => cols (off + q)) 0 R.ot a.2.2.2.1 a.2.2.2.2 + +theorem HoldsCode.state {kk : ℕ} {tm : NTM kk} {x : List Bool} {S jj : ℕ} + {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} {R : CodeRegs kk jj} + {a : Code tm.Q kk x.length S} (h : HoldsCode tm x S cols off R a) : + HoldsBits (fun q => cols (off + q)) 0 R.st ((qCodec tm.Q).enc a.1) := h.1 + +theorem HoldsCode.inputHead {kk : ℕ} {tm : NTM kk} {x : List Bool} {S jj : ℕ} + {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} {R : CodeRegs kk jj} + {a : Code tm.Q kk x.length S} (h : HoldsCode tm x S cols off R a) : + HoldsBits (fun q => cols (off + q)) 0 R.hd + ((finCodec (x.length + S + 2)).enc a.2.1) := h.2.1 + +theorem HoldsCode.work {kk : ℕ} {tm : NTM kk} {x : List Bool} {S jj : ℕ} + {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} {R : CodeRegs kk jj} + {a : Code tm.Q kk x.length S} (h : HoldsCode tm x S cols off R a) (i : Fin kk) : + HoldsWindow (fun q => cols (off + q)) 0 (R.wk i) (a.2.2.1 i).1 (a.2.2.1 i).2 := h.2.2.1 i + +theorem HoldsCode.output {kk : ℕ} {tm : NTM kk} {x : List Bool} {S jj : ℕ} + {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} {R : CodeRegs kk jj} + {a : Code tm.Q kk x.length S} (h : HoldsCode tm x S cols off R a) : + HoldsWindow (fun q => cols (off + q)) 0 R.ot a.2.2.2.1 a.2.2.2.2 := h.2.2.2 + +/-! ## Guessing a whole code -/ + +/-- The raw width of block `p` of a code: the state, the input head, the `kk` work windows, then +the output window. -/ +noncomputable def codeWidthRaw {kk : ℕ} (tm : NTM kk) (nn S : ℕ) (p : ℕ) : ℕ := + if p = 0 then (qCodec tm.Q).width + else if p = 1 then (finCodec (nn + S + 2)).width + else if p < kk + 2 then (S + 1) * 3 + else (S + 2) * 3 + +/-- The block width a code guess passes to `TM.guessBlocksTM`, which writes `n + 1` bits for a +block of `n`. A field of width zero is guessed one bit wide and its (empty) contents read back +off the prefix. -/ +noncomputable def codeWidth {kk : ℕ} (tm : NTM kk) (nn S : ℕ) (p : ℕ) : ℕ := + codeWidthRaw tm nn S p - 1 + +/-- The bits block `p` of a code guess should hold. -/ +noncomputable def codeBlock {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (p : ℕ) : List Bool := + if _ : p = 0 then (qCodec tm.Q).enc a.1 + else if _ : p = 1 then (finCodec (x.length + S + 2)).enc a.2.1 + else if h : p < kk + 2 then (tapeCodec (S + 1)).enc (a.2.2.1 ⟨p - 2, by omega⟩) + else (tapeCodec (S + 2)).enc a.2.2.2 + +@[simp] theorem codeBlock_st {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) : codeBlock tm x S a 0 = (qCodec tm.Q).enc a.1 := by + rw [codeBlock, dif_pos rfl] + +@[simp] theorem codeBlock_hd {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) : + codeBlock tm x S a 1 = (finCodec (x.length + S + 2)).enc a.2.1 := by + rw [codeBlock, dif_neg (by omega), dif_pos rfl] + +@[simp] theorem codeBlock_wk {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (i : Fin kk) : + codeBlock tm x S a (i.val + 2) = (tapeCodec (S + 1)).enc (a.2.2.1 i) := by + rw [codeBlock, dif_neg (by omega), dif_neg (by omega), dif_pos (by omega), + show (⟨i.val + 2 - 2, by omega⟩ : Fin kk) = i from Fin.ext (by simp)] + +@[simp] theorem codeBlock_ot {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) : + codeBlock tm x S a (kk + 2) = (tapeCodec (S + 2)).enc a.2.2.2 := by + rw [codeBlock, dif_neg (by omega), dif_neg (by omega), dif_neg (by omega)] + +theorem codeBlock_length {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (p : ℕ) : + (codeBlock tm x S a p).length = codeWidthRaw tm x.length S p := by + unfold codeBlock codeWidthRaw + split_ifs with h0 h1 h2 + · exact (qCodec tm.Q).enc_length _ + · exact (finCodec (x.length + S + 2)).enc_length _ + · exact (tapeCodec (S + 1)).enc_length _ + · exact (tapeCodec (S + 2)).enc_length _ + +/-- The registers a code guess writes to: one block each, in the order of `codeBlock`. -/ +def codeRegsOf {kk jj : ℕ} (j : ℕ → Fin (jj + 1)) : CodeRegs kk jj where + st := j 0 + hd := j 1 + wk i := j (i.val + 2) + ot := j (kk + 2) + +/-! ## The registers determine the code -/ + +/-- A register holding an encoded window determines the window. -/ +theorem HoldsWindow.inj {m : ℕ} [NeZero m] {jj : ℕ} {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} + {r : Fin (jj + 1)} {hd hd' : Fin m} {cl cl' : Fin m → Γ} + (h : HoldsWindow cols off r hd cl) (h' : HoldsWindow cols off r hd' cl') : + (hd, cl) = (hd', cl') := by + have hb : HoldsBits cols off r ((tapeCodec m).enc (hd, cl)) := by + intro q hq + exact h q (by rw [(tapeCodec m).enc_length] at hq; exact hq) + have hb' : HoldsBits cols off r ((tapeCodec m).enc (hd', cl')) := by + intro q hq + exact h' q (by rw [(tapeCodec m).enc_length] at hq; exact hq) + refine (tapeCodec m).enc_injective (hb.inj hb' ?_) + rw [(tapeCodec m).enc_length, (tapeCodec m).enc_length] + +/-- **The registers determine the code.** The same registers cannot hold two different codes, so +comparing registers compares codes — which is what the walk's "stay" step and the final +comparison need. -/ +theorem HoldsCode.inj {kk : ℕ} {tm : NTM kk} {x : List Bool} {S jj : ℕ} + {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} {R : CodeRegs kk jj} + {a b : Code tm.Q kk x.length S} (ha : HoldsCode tm x S cols off R a) + (hb : HoldsCode tm x S cols off R b) : a = b := by + have hst : a.1 = b.1 := by + refine (qCodec tm.Q).enc_injective (ha.state.inj hb.state ?_) + rw [(qCodec tm.Q).enc_length, (qCodec tm.Q).enc_length] + have hhd : a.2.1 = b.2.1 := by + refine (finCodec (x.length + S + 2)).enc_injective (ha.inputHead.inj hb.inputHead ?_) + rw [(finCodec (x.length + S + 2)).enc_length, (finCodec (x.length + S + 2)).enc_length] + have hwk : a.2.2.1 = b.2.2.1 := by + funext i + exact HoldsWindow.inj (ha.work i) (hb.work i) + have hot : a.2.2.2 = b.2.2.2 := HoldsWindow.inj ha.output hb.output + exact Prod.ext hst (Prod.ext hhd (Prod.ext hwk hot)) + +/-- A register holding an encoded window holds the corresponding bits. -/ +theorem HoldsWindow.bits {m : ℕ} [NeZero m] {jj : ℕ} {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} + {r : Fin (jj + 1)} {hd : Fin m} {cl : Fin m → Γ} (h : HoldsWindow cols off r hd cl) : + HoldsBits cols off r ((tapeCodec m).enc (hd, cl)) := by + intro q hq + exact h q (by rw [(tapeCodec m).enc_length] at hq; exact hq) + +/-- A register holding an encoded window holds that window. -/ +theorem HoldsWindow.of_bits {m : ℕ} [NeZero m] {jj : ℕ} {cols : ℕ → Fin (jj + 1) → Γ} {off : ℕ} + {r : Fin (jj + 1)} {hd : Fin m} {cl : Fin m → Γ} + (h : HoldsBits cols off r ((tapeCodec m).enc (hd, cl))) : HoldsWindow cols off r hd cl := by + intro q hq + exact h q (by rw [(tapeCodec m).enc_length]; exact hq) + +/-- **Blocks on the right registers are a code.** -/ +theorem holdsCode_of_blocks {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (j : ℕ → Fin (jj + 1)) (a : Code tm.Q kk x.length S) + (h : ∀ p, p < kk + 3 → + HoldsBits (fun q => cols (0 + q)) 0 (j p) (codeBlock tm x S a p)) : + HoldsCode tm x S cols 0 (codeRegsOf j) a := by + refine ⟨?_, ?_, fun i => ?_, ?_⟩ + · have := h 0 (by omega) + rwa [codeBlock, dif_pos rfl] at this + · have := h 1 (by omega) + rwa [codeBlock, dif_neg (by omega), dif_pos rfl] at this + · have hb := h (i.val + 2) (by omega) + rw [codeBlock, dif_neg (by omega), dif_neg (by omega), dif_pos (by omega), + show (⟨i.val + 2 - 2, by omega⟩ : Fin kk) = i from Fin.ext (by simp)] at hb + exact HoldsWindow.of_bits hb + · have hb := h (kk + 2) (by omega) + rw [codeBlock, dif_neg (by omega), dif_neg (by omega), dif_neg (by omega)] at hb + exact HoldsWindow.of_bits hb + +/-- **A guess stage can lay down any code.** Given a guess tape whose bits, block by block, are +the code's own encoding, the `kk + 3` guessed registers hold that code. Together with +`Complexity.NTM.exists_loadTape` this is how a nondeterministic step is taken: guess a code, then +check it. -/ +theorem holdsCode_of_guessBlocks {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) {m : ℕ} + (j : ℕ → Fin (m + 1)) (hj : ∀ p, j p ≠ Fin.last m) (W : Fin (m + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (hinj : ∀ p q, p < kk + 3 → q < kk + 3 → j p = j q → p = q) + (hr1 : ∀ p, p < kk + 3 → (W (j p)).head = 1) (a : Code tm.Q kk x.length S) + (hg : ∀ p, p < kk + 3 → ∀ q ≤ codeWidth tm x.length S p, (W (Fin.last m)).cells + ((W (Fin.last m)).head + TM.guessOffset (codeWidth tm x.length S) p + q) + = Γ.ofBool ((codeBlock tm x S a p).getD q false)) : + HoldsCode tm x S + (fun c i => (TM.guessBlocksTapes j (codeWidth tm x.length S) (kk + 3) W i).cells c) 0 + (codeRegsOf j) a := by + have hbits := holdsBits_of_guessBlocks j hj (codeWidth tm x.length S) (kk + 3) W hinv hh hinj + hr1 (fun p q => (codeBlock tm x S a p).getD q false) hg + refine holdsCode_of_blocks tm x S _ j a (fun p hp => ?_) + simp only [Nat.zero_add] + refine (hbits p hp).of_isPrefix + (isPrefix_ofFn (fun q => (codeBlock tm x S a p).getD q false) ?_ ?_) + · rw [codeBlock_length, codeWidth] + omega + · intro q hq + simp [List.getD, List.getElem?_eq_getElem hq] + +/-- **A stage of the loop lays down the code its stream names.** The guess-tape clause of the +walk's invariant feeds exactly this. -/ +theorem holdsCode_of_stage {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) {m : ℕ} + (j : ℕ → Fin (m + 1)) (hj : ∀ p, j p ≠ Fin.last m) (W : Fin (m + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (hinj : ∀ p q, p < kk + 3 → q < kk + 3 → j p = j q → p = q) + (hr1 : ∀ p, p < kk + 3 → (W (j p)).head = 1) (b : ℕ → ℕ → ℕ → Bool) (g : ℕ → Bool) + (hs : TM.StageBlocks (codeWidth tm x.length S) (kk + 3) b g) (s : ℕ) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (codeWidth tm x.length S) (kk + 3) + q)) + (W (Fin.last m))) + (a : Code tm.Q kk x.length S) + (hb : ∀ p, p < kk + 3 → ∀ q, q ≤ codeWidth tm x.length S p → + b s p q = (codeBlock tm x S a p).getD q false) : + HoldsCode tm x S + (fun c i => (TM.guessBlocksTapes j (codeWidth tm x.length S) (kk + 3) W i).cells c) 0 + (codeRegsOf j) a := by + refine holdsCode_of_guessBlocks tm x S j hj W hinv hh hinj hr1 a ?_ + intro p hp q hq + rw [TM.blocks_of_stageBlocks hs s hgf p hp q hq, hb p hp q hq] + + +/-- Holding a code depends only on the registers' cells, not on their heads — which is why a +rewind between the guess and the checks is harmless. -/ +theorem HoldsCode.of_cells_eq {kk jj : ℕ} {tm : NTM kk} {x : List Bool} {S : ℕ} + {cols cols' : ℕ → Fin (jj + 1) → Γ} {off : ℕ} {R : CodeRegs kk jj} + {a : Code tm.Q kk x.length S} (h : HoldsCode tm x S cols off R a) + (hc : ∀ q i, cols' q i = cols q i) : HoldsCode tm x S cols' off R a := by + have heq : cols' = cols := by + funext q i + exact hc q i + rw [heq] + exact h + +/-- **After a code-guessing stage the registers hold the code.** The stage rewinds the guessed +registers so the scans can read them; the rewind moves heads, and a code is held in cells. -/ +theorem holdsCode_of_guessStage {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) {m : ℕ} + (j : ℕ → Fin (m + 1)) (hj : ∀ p, j p ≠ Fin.last m) (W : Fin (m + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (hinj : ∀ p q, p < kk + 3 → q < kk + 3 → j p = j q → p = q) + (hr1 : ∀ p, p < kk + 3 → (W (j p)).head = 1) (a : Code tm.Q kk x.length S) + (hg : ∀ p, p < kk + 3 → ∀ q ≤ codeWidth tm x.length S p, (W (Fin.last m)).cells + ((W (Fin.last m)).head + TM.guessOffset (codeWidth tm x.length S) p + q) + = Γ.ofBool ((codeBlock tm x S a p).getD q false)) + (work : Fin (m + 1) → Tape) + (hcells : ∀ i, (work i).cells + = (TM.guessBlocksTapes j (codeWidth tm x.length S) (kk + 3) W i).cells) : + HoldsCode tm x S (fun c i => (work i).cells c) 0 (codeRegsOf j) a := + (holdsCode_of_guessBlocks tm x S j hj W hinv hh hinj hr1 a hg).of_cells_eq + (fun q i => by rw [hcells i]) + +/-! ## The layout the walk's scan reads + +A check reads the guessed transition from the first cells of the parameter register, and the +fields it checks from the cells after that. So every register except the state's — whose check +reads it alongside the parameters — carries a block of padding as wide as the parameter block, +and its field begins where the padding ends. -/ + +/-- The bits block `p` of a code guess holds in the walk's layout. -/ +noncomputable def codeBlockScan {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (p : ℕ) : List Bool := + if p = 0 then codeBlock tm x S a 0 + else List.replicate (succParamsCodec tm.Q kk).width false ++ (codeBlock tm x S a p ++ [false]) + +/-- The block widths that layout guesses. -/ +noncomputable def codeWidthScan {kk : ℕ} (tm : NTM kk) (nn S : ℕ) (p : ℕ) : ℕ := + if p = 0 then codeWidth tm nn S 0 + else (succParamsCodec tm.Q kk).width + codeWidth tm nn S p + 1 + +/-- The registers hold code `a` where the walk's scan looks for it. -/ +def HoldsCodeScan {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) {jj : ℕ} + (cols : ℕ → Fin (jj + 1) → Γ) (R : CodeRegs kk jj) (a : Code tm.Q kk x.length S) : Prop := + HoldsBits cols 0 R.st ((qCodec tm.Q).enc a.1) ∧ + HoldsBits cols (succParamsCodec tm.Q kk).width R.hd + ((finCodec (x.length + S + 2)).enc a.2.1) ∧ + (∀ i, HoldsWindow cols (succParamsCodec tm.Q kk).width (R.wk i) + (a.2.2.1 i).1 (a.2.2.1 i).2) ∧ + HoldsWindow cols (succParamsCodec tm.Q kk).width R.ot a.2.2.2.1 a.2.2.2.2 + +/-- **The block ends with a cell carrying no head marker.** The window checks need to know that +the chunk just past the window is unmarked; rather than reason about untouched tape, the guess +writes one more zero and the check reads it. -/ +theorem markOf_end {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (p m : ℕ) (hp : p ≠ 0) + (hlen : (codeBlock tm x S a p).length = 3 * m) + (cols : ℕ → Fin (jj + 1) → Γ) (r : Fin (jj + 1)) + (h : HoldsBits cols 0 r (codeBlockScan tm x S a p)) : + markOf cols (succParamsCodec tm.Q kk).width r m = false := by + set pw := (succParamsCodec tm.Q kk).width with hpw + have hblk : codeBlockScan tm x S a p + = List.replicate pw false ++ (codeBlock tm x S a p ++ [false]) := by + rw [codeBlockScan, if_neg hp] + have hlast : (codeBlockScan tm x S a p)[pw + 3 * m]? = some false := by + rw [hblk, List.getElem?_append_right (by rw [List.length_replicate]; omega), + List.length_replicate, show pw + 3 * m - pw = 3 * m by omega, + List.getElem?_append_right (by omega), hlen, show 3 * m - 3 * m = 0 by omega] + rfl + have hlt : pw + 3 * m < (codeBlockScan tm x S a p).length := by + rw [hblk] + simp only [List.length_append, List.length_replicate, hlen, List.length_cons, + List.length_nil] + omega + have hcell := h (pw + 3 * m) hlt + rw [Nat.zero_add] at hcell + have hval : (codeBlockScan tm x S a p)[pw + 3 * m]'hlt = false := + Option.some_injective _ (by rw [← List.getElem?_eq_getElem hlt, hlast]) + rw [hval] at hcell + rw [markOf, hcell] + rfl + +/-- **Blocks in the walk's layout are a code the scan can read.** -/ +theorem holdsCodeScan_of_blocks {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (j : ℕ → Fin (jj + 1)) (a : Code tm.Q kk x.length S) + (h : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) : + HoldsCodeScan tm x S cols (codeRegsOf j) a := by + have hpad : ∀ p, p < kk + 3 → p ≠ 0 → + HoldsBits cols (succParamsCodec tm.Q kk).width (j p) (codeBlock tm x S a p) := by + intro p hp hp0 + have hb := h p hp + rw [codeBlockScan, if_neg hp0] at hb + have hdrop := hb.drop_prefix + rw [List.length_replicate] at hdrop + exact hdrop.of_isPrefix ⟨[false], rfl⟩ + refine ⟨?_, ?_, fun i => ?_, ?_⟩ + · have hb := h 0 (by omega) + rw [codeBlockScan, if_pos rfl, codeBlock, dif_pos rfl] at hb + exact hb + · have hb := hpad 1 (by omega) (by omega) + rwa [codeBlock, dif_neg (by omega), dif_pos rfl] at hb + · have hb := hpad (i.val + 2) (by omega) (by omega) + rw [codeBlock, dif_neg (by omega), dif_neg (by omega), dif_pos (by omega), + show (⟨i.val + 2 - 2, by omega⟩ : Fin kk) = i from Fin.ext (by simp)] at hb + exact HoldsWindow.of_bits hb + · have hb := hpad (kk + 2) (by omega) (by omega) + rw [codeBlock, dif_neg (by omega), dif_neg (by omega), dif_neg (by omega)] at hb + exact HoldsWindow.of_bits hb + +/-! ## What each scan says about the code the registers hold -/ + +variable {kk : ℕ} {tm : NTM kk} {x : List Bool} {S jj : ℕ} {cols : ℕ → Fin (jj + 1) → Γ} + {off : ℕ} + +/-- The state a scan reads off a code's state register. -/ +theorem ofTable_state {R : CodeRegs kk jj} {a : Code tm.Q kk x.length S} + (h : HoldsCode tm x S cols off R a) (s w : ℕ) (regs : Fin s → Fin (jj + 1)) (t : Fin s) + (ht : regs t = R.st) (hc : (qCodec tm.Q).width ≤ w) (x₀ : Fin s → Fin w → Bool) : + (qCodec tm.Q).ofTable (tableSlice + (Scanner.auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (Scanner.bitsStep s w regs) + (fun q => cols (off + q)) w).2 t (qCodec tm.Q).width hc) = a.1 := + ofTable_of_holds (qCodec tm.Q) a.1 cols off s w regs t hc x₀ (ht ▸ h.state) + +/-- **What the work-window scan says.** -/ +theorem blockEmit_work {Ra Rb : CodeRegs kk jj} {a b : Code tm.Q kk x.length S} + (ha : HoldsCode tm x S cols off Ra a) (hb : HoldsCode tm x S cols off Rb b) + (P : SuccParams tm.Q kk) (i : Fin kk) + (hend : markOf (fun q => cols (off + q)) 0 (Ra.wk i) (S + 1) = false) : + blockEmit (succDir tm P i) (Scanner.chunkRun + (blockStep (Ra.wk i) (Rb.wk i) (gammaBits (P.wSym i)) (gammaBits (succWrite tm P i)) + (succDir tm P i)) (fun q => cols (off + q)) 0 blockStart (S + 1)) = true ↔ + ((a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i ∧ + (∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) ∧ + (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val) := + blockEmit_holds (fun q => cols (off + q)) 0 (Ra.wk i) (Rb.wk i) _ _ _ _ (ha.work i) + (hb.work i) (P.wSym i) (succWrite tm P i) (succDir tm P i) (by omega) hend + +/-- **What the output-window scan says.** -/ +theorem blockEmit_output {Ra Rb : CodeRegs kk jj} {a b : Code tm.Q kk x.length S} + (ha : HoldsCode tm x S cols off Ra a) (hb : HoldsCode tm x S cols off Rb b) + (P : SuccParams tm.Q kk) + (hend : markOf (fun q => cols (off + q)) 0 Ra.ot (S + 2) = false) : + blockEmit (succTrans tm P).2.2.2.2.2 (Scanner.chunkRun + (blockStep Ra.ot Rb.ot (gammaBits P.oSym) + (gammaBits (((succTrans tm P).2.2.1 : Γw) : Γ)) (succTrans tm P).2.2.2.2.2) + (fun q => cols (off + q)) 0 blockStart (S + 2)) = true ↔ + (a.2.2.2.2 a.2.2.2.1 = P.oSym ∧ + (∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) ∧ + b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val) := + blockEmit_holds (fun q => cols (off + q)) 0 Ra.ot Rb.ot _ _ _ _ ha.output hb.output + P.oSym (((succTrans tm P).2.2.1 : Γw) : Γ) (succTrans tm P).2.2.2.2.2 (by omega) hend + +/-- **What the input-head scan says.** -/ +theorem inHeadEmit_code {Ra Rb : CodeRegs kk jj} {a b : Code tm.Q kk x.length S} + (ha : HoldsCode tm x S cols off Ra a) (hb : HoldsCode tm x S cols off Rb b) + (d : Dir3) (hleft : d = Dir3.left → 0 < a.2.1.val) : + inHeadEmit d (Scanner.cellFold (inHeadStep Ra.hd Rb.hd d) cols off (true, true) + (bitWidth (x.length + S + 2))) = true ↔ + b.2.1.val = movedIdx d a.2.1.val := + inHeadEmit_of_holds cols off Ra.hd Rb.hd d (bitWidth (x.length + S + 2)) a.2.1.val b.2.1.val + (lt_of_lt_of_le a.2.1.isLt (le_two_pow_bitWidth _)) + (lt_of_lt_of_le b.2.1.isLt (le_two_pow_bitWidth _)) + ha.inputHead hb.inputHead hleft + +/-- **The successor check, assembled.** Every scan verdict says what its field must, and together +they say the guessed code is a successor of the held one. -/ +theorem mem_codeSucc_of_scans {Ra Rb : CodeRegs kk jj} {a b : Code tm.Q kk x.length S} + (ha : HoldsCode tm x S cols off Ra a) (hb : HoldsCode tm x S cols off Rb b) + (P : SuccParams tm.Q kk) (hne : a.1 ≠ tm.qhalt) + (hq : a.1 = P.q) (hstate : b.1 = succState tm P) + (hin : P.inSym = inSymOf tm x S a) + (hclampIn : movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ≤ x.length + S + 1) + (hclampW : ∀ i, movedIdx (succDir tm P i) (a.2.2.1 i).1.val ≤ S) + (hclampO : movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ≤ S + 1) + (hleft : (succTrans tm P).2.2.2.1 = Dir3.left → 0 < a.2.1.val) + (hendW : ∀ i, markOf (fun q => cols (off + q)) 0 (Ra.wk i) (S + 1) = false) + (hendO : markOf (fun q => cols (off + q)) 0 Ra.ot (S + 2) = false) + (vhead : inHeadEmit (succTrans tm P).2.2.2.1 + (Scanner.cellFold (inHeadStep Ra.hd Rb.hd (succTrans tm P).2.2.2.1) cols off (true, true) + (bitWidth (x.length + S + 2))) = true) + (vwork : ∀ i, blockEmit (succDir tm P i) (Scanner.chunkRun + (blockStep (Ra.wk i) (Rb.wk i) (gammaBits (P.wSym i)) (gammaBits (succWrite tm P i)) + (succDir tm P i)) (fun q => cols (off + q)) 0 blockStart (S + 1)) = true) + (vout : blockEmit (succTrans tm P).2.2.2.2.2 (Scanner.chunkRun + (blockStep Ra.ot Rb.ot (gammaBits P.oSym) + (gammaBits (((succTrans tm P).2.2.1 : Γw) : Γ)) (succTrans tm P).2.2.2.2.2) + (fun q => cols (off + q)) 0 blockStart (S + 2)) = true) : + b ∈ NTM.codeSucc tm x S a := by + have hw := fun i => (blockEmit_work ha hb P i (hendW i)).mp (vwork i) + have ho := (blockEmit_output ha hb P hendO).mp vout + exact mem_codeSucc_of_checks tm x S a b P hne hq hin (fun i => (hw i).1) ho.1 + hclampIn hclampW hclampO hstate ((inHeadEmit_code ha hb _ hleft).mp vhead) + (fun i => ⟨(hw i).2.2, (hw i).2.1⟩) ⟨ho.2.2, ho.2.1⟩ + +/-! ## What the loops establish + +The walk and the counting are stated here in the form the loops produce them: a walk as a +sequence of codes each either kept or stepped, and a round list as an injective enumeration. -/ + +/-- **What a walk establishes.** A sequence of codes, each either equal to its predecessor or a +verified successor of it, lands in the round its length names. -/ +theorem mem_reachCodes_of_walk (tm : NTM kk) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q kk x.length S) (i : ℕ) (f : ℕ → Code tm.Q kk x.length S) + (h0 : f 0 = a₀) + (hstep : ∀ j < i, f (j + 1) = f j ∨ f (j + 1) ∈ NTM.codeSucc tm x S (f j)) : + f i ∈ NTM.reachCodes tm x S a₀ i := + (NTM.mem_reachCodes_iff_walk tm x S a₀ i (f i)).mpr ⟨f, h0, rfl, hstep⟩ + +/-- **What the counting establishes.** Codes enumerated without repetition, each verified to be in +the round, and at least as many of them as the round holds, form a round list — which is what +licenses concluding that a code not among them is not in the round. -/ +theorem roundList_of_inj (tm : NTM kk) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q kk x.length S) (i N : ℕ) (g : Fin N → Code tm.Q kk x.length S) + (hinj : Function.Injective g) (hmem : ∀ t, g t ∈ NTM.reachCodes tm x S a₀ i) + (hcard : (NTM.reachCodes tm x S a₀ i).card ≤ N) : + NTM.RoundList tm x S a₀ i (List.ofFn g) := by + refine ⟨List.nodup_ofFn.mpr hinj, ?_, ?_⟩ + · intro c hc + obtain ⟨t, rfl⟩ := List.mem_ofFn.mp hc + exact hmem t + · rw [List.length_ofFn] + exact hcard + +/-! ## The shape of a loop invariant + +`TM.loopTM_hoareTime_indexed` asks for a family of tape predicates `E j`, a step from `E j` to +`E (j + 1)`, and a stop at `E N`. For the walk, `E j` says the counter holds `j` and the code +registers hold the `j`-th code of the walk — so the loop's own index is the walk's index. -/ + +/-- The reading of a counter register as a number. -/ +def counterVal {jj : ℕ} (cnt : Fin (jj + 1)) (wc : ℕ) (work : Fin (jj + 1) → Tape) : ℕ := + binValLE (List.ofFn fun q : Fin wc => decide ((work cnt).cells (q.val + 1) = Γ.one)) + +/-- A tape predicate pinning a counter register to a value. The bound `v < 2 ^ wc` is part of it: +past that point a fixed-width counter wraps, and a loop rule needs the counter to *name* its +index. -/ +def HoldsCounter {jj : ℕ} (cnt : Fin (jj + 1)) (wc : ℕ) (v : ℕ) : TM.TapePred (jj + 1) := + fun _inp work _out => v < 2 ^ wc ∧ + HoldsBits (fun p i => (work i).cells p) 0 cnt (bitsOfLenLE wc v) + +/-- The walk loop's invariant. The bound `j < 2 ^ wc` is part of it: past that point the counter +would wrap, and the loop rule needs the counter to *name* the index. -/ +def WalkInv (tm : NTM kk) (x : List Bool) (S : ℕ) {jj : ℕ} (R : CodeRegs kk jj) + (cnt : Fin (jj + 1)) (wc : ℕ) (f : ℕ → Code tm.Q kk x.length S) (j : ℕ) : + TM.TapePred (jj + 1) := + fun _inp work _out => + j < 2 ^ wc ∧ HoldsCode tm x S (fun p i => (work i).cells p) 0 R (f j) ∧ + HoldsBits (fun p i => (work i).cells p) 0 cnt (bitsOfLenLE wc j) + +/-- **The counter reads back the index.** This is the `idx` obligation of the indexed loop rule: +a tape predicate that pins the counter determines the loop's index. -/ +theorem counterVal_of_walkInv (tm : NTM kk) (x : List Bool) (S : ℕ) {jj : ℕ} + (R : CodeRegs kk jj) (cnt : Fin (jj + 1)) (wc : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (j : ℕ) + (inp : Tape) (work : Fin (jj + 1) → Tape) (out : Tape) + (h : WalkInv tm x S R cnt wc f j inp work out) : counterVal cnt wc work = j := by + obtain ⟨hj, -, hcnt⟩ := h + have hbits : (List.ofFn fun q : Fin wc => decide ((work cnt).cells (q.val + 1) = Γ.one)) + = bitsOfLenLE wc j := by + refine List.ext_getElem (by simp [bitsOfLenLE_length]) ?_ + intro q h1 h2 + have hq : q < wc := by simpa using h1 + have hc := hcnt q (by rw [bitsOfLenLE_length]; exact hq) + simp only [Nat.zero_add] at hc + simp only [List.getElem_ofFn] + show decide ((work cnt).cells (q + 1) = Γ.one) = _ + rw [hc] + cases (bitsOfLenLE wc j)[q]'(by rw [bitsOfLenLE_length]; exact hq) <;> simp [Γ.ofBool] + rw [counterVal, hbits, binValLE_bitsOfLenLE wc j hj] + +/-! ## The scanner that checks one window + +Three tapes are scanned: the parameter block, the old window, the new window; the verdict goes to +a fourth. The parameters come first, so by the time the windows are reached the transition is +known. -/ + +/-- The state of a window check: a chunk position, two buffered columns, and the four running +checks. -/ +abbrev WindowState : Type := + Fin 3 × (Fin 3 → Γ) × (Fin 3 → Γ) × + ((Bool × Bool) × (Bool × Bool) × (Bool × Bool) × (Bool × Bool × Bool × Bool)) + +/-- Equality of window states is decidable; the machine need not be computable. -/ +noncomputable instance : DecidableEq WindowState := Classical.decEq _ + +/-- The state a parameter reader accumulates: how many cells it has read, and the bits. -/ +abbrev ParamAcc (tm : NTM kk) : Type := + Fin ((succParamsCodec tm.Q kk).width + 1) × + (Fin 1 → Fin (succParamsCodec tm.Q kk).width → Bool) + +/-- The parameters a window check has read. -/ +noncomputable def paramsOfTable (tm : NTM kk) (a : ParamAcc tm) : SuccParams tm.Q kk := + (succParamsCodec tm.Q kk).ofTable (a.2 0) + +/-- **The window checker.** -/ +noncomputable def windowScanner (tm : NTM kk) (i : Fin kk) : Scanner 2 := + Scanner.prefixed (succParamsCodec tm.Q kk).width (ParamAcc tm) WindowState + (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0)) + (fun _ => (0, (fun _ => Γ.blank), (fun _ => Γ.blank), blockStart)) + (fun a t col => Scanner.chunkStepCell + (blockStep 1 2 (gammaBits ((paramsOfTable tm a).wSym i)) + (gammaBits (succWrite tm (paramsOfTable tm a) i)) + (succDir tm (paramsOfTable tm a) i)) t col) + (fun a t => blockEmit (succDir tm (paramsOfTable tm a) i) t.2.2.2) + +theorem succParamsCodec_width_pos (tm : NTM kk) : 0 < (succParamsCodec tm.Q kk).width := by + rw [succParamsCodec_width] + omega + +/-- The parameters a window scan reads off the tapes it is given. -/ +noncomputable def windowParams (tm : NTM kk) (cols : ℕ → Fin 3 → Γ) : SuccParams tm.Q kk := + paramsOfTable tm (Scanner.auxRun (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0)) cols + (succParamsCodec tm.Q kk).width) + +set_option maxHeartbeats 1000000 in +/-- **What the window checker computes**: the block check, with the parameters it read. -/ +theorem windowScanner_run (tm : NTM kk) (i : Fin kk) (cols : ℕ → Fin 3 → Γ) (S : ℕ) : + (windowScanner tm i).emit ((windowScanner tm i).run cols + ((succParamsCodec tm.Q kk).width + 3 * (S + 1))) + = blockEmit (succDir tm (windowParams tm cols) i) + (Scanner.chunkRun (blockStep 1 2 (gammaBits ((windowParams tm cols).wSym i)) + (gammaBits (succWrite tm (windowParams tm cols) i)) + (succDir tm (windowParams tm cols) i)) cols (succParamsCodec tm.Q kk).width + blockStart (S + 1)) := by + rw [windowParams, windowScanner, + Scanner.prefixed_run _ _ _ _ _ _ cols (succParamsCodec_width_pos tm) (3 * (S + 1))] + rw [Scanner.mainRun_eq_cellFold] + exact congrArg _ (Scanner.cellFold_chunk _ cols _ blockStart _ _ (S + 1)).2 + +/-- **The output-window checker.** The same scanner as for a work tape, with the transition's +output write and direction. -/ +noncomputable def outputScanner (tm : NTM kk) : Scanner 2 := + Scanner.prefixed (succParamsCodec tm.Q kk).width (ParamAcc tm) WindowState + (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0)) + (fun _ => (0, (fun _ => Γ.blank), (fun _ => Γ.blank), blockStart)) + (fun a t col => Scanner.chunkStepCell + (blockStep 1 2 (gammaBits (paramsOfTable tm a).oSym) + (gammaBits (((succTrans tm (paramsOfTable tm a)).2.2.1 : Γw) : Γ)) + (succTrans tm (paramsOfTable tm a)).2.2.2.2.2) t col) + (fun a t => blockEmit (succTrans tm (paramsOfTable tm a)).2.2.2.2.2 t.2.2.2) + +set_option maxHeartbeats 1000000 in +/-- **What the output checker computes.** -/ +theorem outputScanner_run (tm : NTM kk) (cols : ℕ → Fin 3 → Γ) (S : ℕ) : + (outputScanner tm).emit ((outputScanner tm).run cols + ((succParamsCodec tm.Q kk).width + 3 * (S + 2))) + = blockEmit (succTrans tm (windowParams tm cols)).2.2.2.2.2 + (Scanner.chunkRun (blockStep 1 2 (gammaBits (windowParams tm cols).oSym) + (gammaBits (((succTrans tm (windowParams tm cols)).2.2.1 : Γw) : Γ)) + (succTrans tm (windowParams tm cols)).2.2.2.2.2) cols + (succParamsCodec tm.Q kk).width blockStart (S + 2)) := by + rw [windowParams, outputScanner, + Scanner.prefixed_run _ _ _ _ _ _ cols (succParamsCodec_width_pos tm) (3 * (S + 2))] + rw [Scanner.mainRun_eq_cellFold] + exact congrArg _ (Scanner.cellFold_chunk _ cols _ blockStart _ _ (S + 2)).2 + +/-- **The input-head checker.** Two tapes are scanned: the parameter block and, after it, the two +input-head registers — the direction is known by the time they are reached. -/ +noncomputable def headScanner (tm : NTM kk) : Scanner 2 := + Scanner.prefixed (succParamsCodec tm.Q kk).width (ParamAcc tm) (Bool × Bool) + (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0)) + (fun _ => (true, true)) + (fun a t col => inHeadStep 1 2 (succTrans tm (paramsOfTable tm a)).2.2.2.1 t col) + (fun a t => inHeadEmit (succTrans tm (paramsOfTable tm a)).2.2.2.1 t) + +set_option maxHeartbeats 1000000 in +/-- **What the input-head checker computes.** -/ +theorem headScanner_run (tm : NTM kk) (cols : ℕ → Fin 3 → Γ) (w : ℕ) : + (headScanner tm).emit ((headScanner tm).run cols + ((succParamsCodec tm.Q kk).width + w)) + = inHeadEmit (succTrans tm (windowParams tm cols)).2.2.2.1 + (Scanner.cellFold (inHeadStep 1 2 (succTrans tm (windowParams tm cols)).2.2.2.1) cols + (succParamsCodec tm.Q kk).width (true, true) w) := by + rw [windowParams, headScanner, + Scanner.prefixed_run _ _ _ _ _ _ cols (succParamsCodec_width_pos tm) w, + Scanner.mainRun_eq_cellFold] + +/-! ## The state checks + +Unlike the window and head checks, these read both registers during the parameter phase — a state +field is a constant number of cells — so the check lives entirely in the accumulated table and the +per-cell state is trivial. -/ + +/-- The width a state check scans: enough for the parameter block and for a state field. -/ +noncomputable def stateWidth (tm : NTM kk) : ℕ := + max (succParamsCodec tm.Q kk).width (qCodec tm.Q).width + +/-- What a state check has accumulated. -/ +abbrev StateAcc (tm : NTM kk) : Type := + Fin (stateWidth tm + 1) × (Fin 2 → Fin (stateWidth tm) → Bool) + +/-- The state a state check has read off the code's register. -/ +noncomputable def stateOfTable (tm : NTM kk) (a : StateAcc tm) : tm.Q := + (qCodec tm.Q).ofTable (tableSlice a.2 1 (qCodec tm.Q).width (le_max_right _ _)) + +/-- The parameters a state check has read. -/ +noncomputable def paramsOfStateTable (tm : NTM kk) (a : StateAcc tm) : SuccParams tm.Q kk := + (succParamsCodec tm.Q kk).ofTable + (tableSlice a.2 0 (succParamsCodec tm.Q kk).width (le_max_left _ _)) + +/-- **The state checker.** With `isNew = false` it checks the old code's state against the guessed +one; with `isNew = true`, the new code's state against the one the transition produces. -/ +noncomputable def stateScanner (tm : NTM kk) (isNew : Bool) : Scanner 1 := + Scanner.prefixed (stateWidth tm) (StateAcc tm) Unit + (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 2 (stateWidth tm) (fun t => t)) + (fun _ => ()) + (fun _ t _ => t) + (fun a _ => decide (stateOfTable tm a = + if isNew then succState tm (paramsOfStateTable tm a) else (paramsOfStateTable tm a).q)) + +/-- The table a state check accumulates from given tapes. -/ +noncomputable def stateTable (tm : NTM kk) (cols : ℕ → Fin 2 → Γ) : StateAcc tm := + Scanner.auxRun (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 2 (stateWidth tm) (fun t => t)) cols (stateWidth tm) + +theorem stateWidth_pos (tm : NTM kk) : 0 < stateWidth tm := + lt_of_lt_of_le (succParamsCodec_width_pos tm) (le_max_left _ _) + +set_option maxHeartbeats 1000000 in +/-- **What a state checker computes.** -/ +theorem stateScanner_run (tm : NTM kk) (isNew : Bool) (cols : ℕ → Fin 2 → Γ) : + (stateScanner tm isNew).emit ((stateScanner tm isNew).run cols (stateWidth tm)) + = decide (stateOfTable tm (stateTable tm cols) = + if isNew then succState tm (paramsOfStateTable tm (stateTable tm cols)) + else (paramsOfStateTable tm (stateTable tm cols)).q) := by + have h := Scanner.prefixed_run (α := StateAcc tm) (τ := Unit) (stateWidth tm) + (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 2 (stateWidth tm) (fun t => t)) (fun _ => ()) (fun _ t _ => t) + (fun a _ => decide (stateOfTable tm a = + if isNew then succState tm (paramsOfStateTable tm a) else (paramsOfStateTable tm a).q)) + cols (stateWidth_pos tm) 0 + rw [stateTable, stateScanner] + exact h + +/-! ## When the simulated input head is at the marker + +A machine cannot keep its own input head on cell zero: reading `▷` forces that head right on every +step. But it need not — a simulated head at cell zero reads `▷`, which the code's own head field +already says. So the input symbol is checked against the tape only when the head field is nonzero; +when it is zero the check is on the parameter register alone. -/ + +/-- The scan that decides whether a code's input-head field is zero: every bit of the field is a +zero. -/ +noncomputable def headZeroScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (hd : Fin (jj + 1)) : + Scanner jj := + ((Scanner.isConst jj hd Γ.zero).after (succParamsCodec tm.Q kk).width).upTo + ((succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width) + +/-- A string of zeros has value zero. -/ +theorem binValLE_replicate_false : ∀ ℓ : ℕ, binValLE (List.replicate ℓ false) = 0 := by + intro ℓ + induction ℓ with + | zero => rfl + | succ ℓ ih => + rw [List.replicate_succ, binValLE, ih] + rfl + +/-- A fixed-width encoding is all zeros exactly when it encodes zero. -/ +theorem bitsOfLenLE_all_false_iff (ℓ v : ℕ) (hv : v < 2 ^ ℓ) : + (∀ q, (hq : q < ℓ) → + (bitsOfLenLE ℓ v)[q]'(by rw [bitsOfLenLE_length]; exact hq) = false) ↔ v = 0 := by + constructor + · intro h + have hrep : bitsOfLenLE ℓ v = List.replicate ℓ false := by + refine List.ext_getElem (by rw [bitsOfLenLE_length, List.length_replicate]) ?_ + intro q h1 h2 + rw [List.getElem_replicate] + exact h q (by rw [bitsOfLenLE_length] at h1; exact h1) + have hval := binValLE_bitsOfLenLE ℓ v hv + rw [hrep, binValLE_replicate_false] at hval + exact hval.symm + · intro h q hq + subst h + have hrep : ∀ m : ℕ, bitsOfLenLE m 0 = List.replicate m false := by + intro m + induction m with + | zero => rfl + | succ m ih => + rw [bitsOfLenLE, List.replicate_succ, ih] + rfl + have : (bitsOfLenLE ℓ 0)[q]? = some false := by + rw [hrep ℓ, List.getElem?_replicate] + rw [if_pos hq] + exact Option.some_injective _ + (by rw [← List.getElem?_eq_getElem (by rw [bitsOfLenLE_length]; exact hq), this]) + +/-- **The zero-head scan decides that the code's input head is at the marker.** -/ +theorem headZeroScanner_decides {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (hd : Fin (jj + 1)) + (cols : ℕ → Fin (jj + 1) → Γ) (len : ℕ) + (hlen : (succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width ≤ len) + (u : Fin (nn + S + 2)) + (hu : HoldsBits cols (succParamsCodec tm.Q kk).width hd ((finCodec (nn + S + 2)).enc u)) : + (headZeroScanner tm nn S hd).emit ((headZeroScanner tm nn S hd).run cols len) = true ↔ + u.val = 0 := by + rw [headZeroScanner, Scanner.isConst_range_run _ _ _ _ _ _ len hlen] + have hwidth : (finCodec (nn + S + 2)).width = bitWidth (nn + S + 2) := rfl + have hbound : u.val < 2 ^ bitWidth (nn + S + 2) := + lt_of_lt_of_le u.isLt (le_two_pow_bitWidth _) + rw [← bitsOfLenLE_all_false_iff (bitWidth (nn + S + 2)) u.val hbound] + constructor + · intro h q hq + have hcell := hu q (by rw [(finCodec (nn + S + 2)).enc_length]; exact hq) + have hz := h ((succParamsCodec tm.Q kk).width + q + 1) (by omega) (by rw [hwidth]; omega) + rw [hz] at hcell + cases hb : ((finCodec (nn + S + 2)).enc u)[q]'(by + rw [(finCodec (nn + S + 2)).enc_length]; exact hq) with + | false => exact hb + | true => + rw [hb] at hcell + exact absurd hcell.symm (fun hc => Γ.noConfusion hc) + · intro h q h1 h2 + have hq : q - (succParamsCodec tm.Q kk).width - 1 < bitWidth (nn + S + 2) := by + rw [hwidth] at h2 + omega + have hcell := hu (q - (succParamsCodec tm.Q kk).width - 1) + (by rw [(finCodec (nn + S + 2)).enc_length]; exact hq) + rw [show (succParamsCodec tm.Q kk).width + (q - (succParamsCodec tm.Q kk).width - 1) + 1 = q + by omega] at hcell + rw [hcell] + show Γ.ofBool ((bitsOfLenLE (bitWidth (nn + S + 2)) u.val)[q - + (succParamsCodec tm.Q kk).width - 1]'(by rw [bitsOfLenLE_length]; exact hq)) = Γ.zero + rw [h _ hq] + rfl + +/-- The scan that decides a code's input-head field is **not** zero. -/ +noncomputable def headNonZeroScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (hd : Fin (jj + 1)) : + Scanner jj := + ((Scanner.isNotConst jj hd Γ.zero).after (succParamsCodec tm.Q kk).width).upTo + ((succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width) + +/-- **The nonzero-head scan decides that the code's input head is off the marker.** -/ +theorem headNonZeroScanner_decides {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (hd : Fin (jj + 1)) + (cols : ℕ → Fin (jj + 1) → Γ) (len : ℕ) + (hlen : (succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width ≤ len) + (u : Fin (nn + S + 2)) + (hu : HoldsBits cols (succParamsCodec tm.Q kk).width hd ((finCodec (nn + S + 2)).enc u)) : + (headNonZeroScanner tm nn S hd).emit ((headNonZeroScanner tm nn S hd).run cols len) = true ↔ + u.val ≠ 0 := by + rw [headNonZeroScanner, Scanner.isNotConst_range_run _ _ _ _ _ _ len hlen] + have hwidth : (finCodec (nn + S + 2)).width = bitWidth (nn + S + 2) := rfl + have hbound : u.val < 2 ^ bitWidth (nn + S + 2) := + lt_of_lt_of_le u.isLt (le_two_pow_bitWidth _) + rw [← not_iff_not, not_not, ← bitsOfLenLE_all_false_iff (bitWidth (nn + S + 2)) u.val hbound] + constructor + · intro h q hq + by_contra hne + refine h ⟨(succParamsCodec tm.Q kk).width + q + 1, by omega, by rw [hwidth]; omega, ?_⟩ + have hcell := hu q (by rw [(finCodec (nn + S + 2)).enc_length]; exact hq) + rw [hcell] + show Γ.ofBool ((bitsOfLenLE (bitWidth (nn + S + 2)) u.val)[q]'(by + rw [bitsOfLenLE_length]; exact hq)) ≠ Γ.zero + cases hb : (bitsOfLenLE (bitWidth (nn + S + 2)) u.val)[q]'(by + rw [bitsOfLenLE_length]; exact hq) with + | false => exact absurd hb hne + | true => exact fun hc => Γ.noConfusion hc + · rintro h ⟨q, h1, h2, h3⟩ + have hq : q - (succParamsCodec tm.Q kk).width - 1 < bitWidth (nn + S + 2) := by + rw [hwidth] at h2 + omega + have hcell := hu (q - (succParamsCodec tm.Q kk).width - 1) + (by rw [(finCodec (nn + S + 2)).enc_length]; exact hq) + rw [show (succParamsCodec tm.Q kk).width + (q - (succParamsCodec tm.Q kk).width - 1) + 1 = q + by omega] at hcell + refine h3 ?_ + rw [hcell] + show Γ.ofBool ((bitsOfLenLE (bitWidth (nn + S + 2)) u.val)[q - + (succParamsCodec tm.Q kk).width - 1]'(by rw [bitsOfLenLE_length]; exact hq)) = Γ.zero + rw [h _ hq] + rfl + +/-! ## The direction the input head takes + +`TM.inMoveTM` reads the direction to move the input head from a single cell, because a direction +fits in one writable symbol. That cell is guessed, so a check has to pin it against the guessed +transition — and unlike every other check this one reads a raw symbol rather than a bit. -/ + +/-- What a direction check accumulates: the parameters, and the symbol it saw on the direction +register's first cell. -/ +abbrev DirAcc (tm : NTM kk) : Type := ParamAcc tm × Γ + +/-- The direction check's reader: read the parameter block, and capture the direction register's +first cell as it goes past. -/ +noncomputable def dirRead (tm : NTM kk) (a : DirAcc tm) (col : Fin 2 → Γ) : DirAcc tm := + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0) a.1 col, + if a.1.1.val = 0 then col 1 else a.2) + +/-- **The direction checker.** It accepts when the direction register's first cell names the way +the guessed transition moves the input head. -/ +noncomputable def dirScanner (tm : NTM kk) (enc : Dir3 → Γ) : Scanner 1 := + Scanner.prefixed (succParamsCodec tm.Q kk).width (DirAcc tm) Unit + ((⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false), Γ.blank) + (dirRead tm) + (fun _ => ()) + (fun _ t _ => t) + (fun a _ => decide (a.2 = enc (succTrans tm (paramsOfTable tm a.1)).2.2.2.1)) + +/-- The reader's parameter half is the ordinary parameter reader. -/ +theorem dirRead_fst (tm : NTM kk) (cols : ℕ → Fin 2 → Γ) (g₀ : Γ) (x₀ : Fin 1 → Fin _ → Bool) : + ∀ p : ℕ, (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (dirRead tm) cols p).1 + = Scanner.auxRun (⟨0, Nat.zero_lt_succ _⟩, x₀) + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0)) cols p := by + intro p + induction p with + | zero => rfl + | succ p ih => rw [Scanner.auxRun, Scanner.auxRun, dirRead, ih] + +/-- The reader's captured half is the direction register's first cell, and its counter has left +zero behind — so nothing later overwrites the capture. -/ +theorem dirRead_snd (tm : NTM kk) (cols : ℕ → Fin 2 → Γ) (g₀ : Γ) + (x₀ : Fin 1 → Fin (succParamsCodec tm.Q kk).width → Bool) : + ∀ p : ℕ, 1 ≤ p → + (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (dirRead tm) cols p).2 = cols 1 1 ∧ + (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (dirRead tm) cols p).1.1.val ≠ 0 := by + have hw := succParamsCodec_width_pos tm + intro p + induction p with + | zero => intro h; omega + | succ p ih => + intro _ + rcases Nat.eq_zero_or_pos p with hp | hp + · subst hp + constructor + · show (dirRead tm ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (cols (0 + 1))).2 = cols 1 1 + rw [dirRead] + show (if (0 : ℕ) = 0 then cols (0 + 1) 1 else g₀) = cols 1 1 + rw [if_pos rfl] + · show (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0) + (⟨0, Nat.zero_lt_succ _⟩, x₀) (cols (0 + 1))).1.val ≠ 0 + rw [Scanner.bitsStep, dif_pos (show (0 : ℕ) < (succParamsCodec tm.Q kk).width by omega)] + exact Nat.succ_ne_zero _ + · obtain ⟨ihcap, ihcnt⟩ := ih hp + constructor + · show (dirRead tm (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (dirRead tm) + cols p) (cols (p + 1))).2 = cols 1 1 + rw [dirRead] + show (if (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (dirRead tm) + cols p).1.1.val = 0 then _ else _) = cols 1 1 + rw [if_neg ihcnt] + exact ihcap + · show (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0) + (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, x₀), g₀) (dirRead tm) cols p).1 + (cols (p + 1))).1.val ≠ 0 + rw [Scanner.bitsStep] + split + · exact Nat.succ_ne_zero _ + · exact ihcnt + +/-- The parameters a direction check reads. -/ +noncomputable def dirParams (tm : NTM kk) (cols : ℕ → Fin 2 → Γ) : SuccParams tm.Q kk := + paramsOfTable tm (Scanner.auxRun (⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false) + (Scanner.bitsStep 1 (succParamsCodec tm.Q kk).width (fun _ => 0)) cols + (succParamsCodec tm.Q kk).width) + +/-- **What the direction checker computes.** -/ +theorem dirScanner_run (tm : NTM kk) (enc : Dir3 → Γ) (cols : ℕ → Fin 2 → Γ) : + (dirScanner tm enc).emit + ((dirScanner tm enc).run cols (succParamsCodec tm.Q kk).width) + = decide (cols 1 1 = enc (succTrans tm (dirParams tm cols)).2.2.2.1) := by + have h := Scanner.prefixed_run (α := DirAcc tm) (τ := Unit) (succParamsCodec tm.Q kk).width + ((⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false), Γ.blank) (dirRead tm) (fun _ => ()) + (fun _ t _ => t) + (fun a _ => decide (a.2 = enc (succTrans tm (paramsOfTable tm a.1)).2.2.2.1)) + cols (succParamsCodec_width_pos tm) 0 + have h2 : (dirScanner tm enc).emit + ((dirScanner tm enc).run cols (succParamsCodec tm.Q kk).width) + = decide ((Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false), Γ.blank) + (dirRead tm) cols (succParamsCodec tm.Q kk).width).2 + = enc (succTrans tm (paramsOfTable tm + (Scanner.auxRun ((⟨0, Nat.zero_lt_succ _⟩, fun _ _ => false), Γ.blank) + (dirRead tm) cols (succParamsCodec tm.Q kk).width).1)).2.2.2.1) := h + rw [h2, dirParams, + dirRead_fst tm cols Γ.blank (fun _ _ => false) (succParamsCodec tm.Q kk).width, + (dirRead_snd tm cols Γ.blank (fun _ _ => false) (succParamsCodec tm.Q kk).width + (succParamsCodec_width_pos tm)).1] + +/-- **The direction checker decides that the guessed direction is the one the transition +takes.** -/ +theorem dirScanner_decides (tm : NTM kk) (enc : Dir3 → Γ) (cols : ℕ → Fin 2 → Γ) + (P : SuccParams tm.Q kk) (hpar : HoldsBits cols 0 0 ((succParamsCodec tm.Q kk).enc P)) : + (dirScanner tm enc).emit + ((dirScanner tm enc).run cols (succParamsCodec tm.Q kk).width) = true ↔ + cols 1 1 = enc (succTrans tm P).2.2.2.1 := by + have hP : dirParams tm cols = P := by + have h := ofTable_of_holds_zero (succParamsCodec tm.Q kk) P cols 1 + (succParamsCodec tm.Q kk).width (fun _ => 0) 0 le_rfl (fun _ _ => false) hpar + rw [dirParams, paramsOfTable] + exact h + rw [dirScanner_run, hP, decide_eq_true_eq] + +/-! ## The symbol under the input head + +Of every field of a guessed transition, this is the one no scan can check: it has to agree with +the machine's own input tape. So it is laid out first in the parameter block, where +`TM.inMatchTM` reads it. -/ + +/-- **The parameter register opens with the guessed input symbol.** -/ +theorem inSym_cells (tm : NTM kk) {jj : ℕ} (cols : ℕ → Fin (jj + 1) → Γ) (par : Fin (jj + 1)) + (P : SuccParams tm.Q kk) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) : + cols 1 par = Γ.ofBool (gammaBits P.inSym).1 ∧ + cols 2 par = Γ.ofBool (gammaBits P.inSym).2 := by + obtain ⟨L, hcat⟩ : ∃ L, (succParamsCodec tm.Q kk).enc P = BitCodec.gamma.enc P.inSym ++ L := + ⟨_, rfl⟩ + have hlen : ((succParamsCodec tm.Q kk).enc P).length = (succParamsCodec tm.Q kk).width := + (succParamsCodec tm.Q kk).enc_length P + have hw : (succParamsCodec tm.Q kk).width = 2 + (1 + (bitWidth (Fintype.card tm.Q) + + (kk * 2 + 2))) := succParamsCodec_width tm.Q kk + have hopt : ∀ q, q < 2 → ((succParamsCodec tm.Q kk).enc P)[q]? + = (BitCodec.gamma.enc P.inSym)[q]? := by + intro q hq + rw [hcat, List.getElem?_append_left (by rw [BitCodec.gamma.enc_length]; exact hq)] + have hbit : ∀ q, (hq : q < 2) → ((succParamsCodec tm.Q kk).enc P)[q]? + = some ([(gammaBits P.inSym).1, (gammaBits P.inSym).2][q]'(by simpa using hq)) := by + intro q hq + rw [hopt q hq, gamma_enc_eq, List.getElem?_eq_getElem (by simpa using hq)] + constructor + · have hlt : 0 < ((succParamsCodec tm.Q kk).enc P).length := by rw [hlen, hw]; omega + have h := hpar 0 hlt + rw [Nat.zero_add] at h + rw [h] + refine congrArg Γ.ofBool (Option.some_injective _ ?_) + rw [← List.getElem?_eq_getElem hlt, hbit 0 (by omega)] + rfl + · have hlt : 1 < ((succParamsCodec tm.Q kk).enc P).length := by rw [hlen, hw]; omega + have h := hpar 1 hlt + rw [show (0 : ℕ) + 1 + 1 = 2 from rfl] at h + rw [h] + refine congrArg Γ.ofBool (Option.some_injective _ ?_) + rw [← List.getElem?_eq_getElem hlt, hbit 1 (by omega)] + rfl + +/-- **The input check passes when the guess is right.** The converse of +`Complexity.inSym_eq_of_inMatch`: this is what the completeness direction needs, since the +certificate names the symbol the simulated head is really over. -/ +theorem inMatchVerdict_of_inSym (tm : NTM kk) {jj : ℕ} (cols : ℕ → Fin (jj + 1) → Γ) + (par : Fin (jj + 1)) (P : SuccParams tm.Q kk) (g : Γ) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) (hin : P.inSym = g) : + TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par) = true := by + obtain ⟨h1, h2⟩ := inSym_cells tm cols par P hpar + rw [TM.inMatchVerdict, h1, h2, hin, Bool.and_eq_true, decide_eq_true_eq, decide_eq_true_eq] + exact ⟨rfl, rfl⟩ + +/-- **The input check pins the guessed input symbol.** When the machine's own input head sits +where the simulated one does, the verdict of `TM.inMatchTM` on the parameter register says exactly +that the guess was right. -/ +theorem inSym_eq_of_inMatch (tm : NTM kk) {jj : ℕ} (cols : ℕ → Fin (jj + 1) → Γ) + (par : Fin (jj + 1)) (P : SuccParams tm.Q kk) (g : Γ) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (hv : TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par) = true) : P.inSym = g := by + obtain ⟨h1, h2⟩ := inSym_cells tm cols par P hpar + rw [TM.inMatchVerdict, h1, h2, Bool.and_eq_true, decide_eq_true_eq, decide_eq_true_eq] at hv + exact gammaBits_injective (Prod.ext (ofBool_injective hv.1) (ofBool_injective hv.2)) + +/-- **The parameter register opens with two ones exactly when the guessed symbol is the +marker.** -/ +theorem parStart_iff {kk jj : ℕ} (tm : NTM kk) (cols : ℕ → Fin (jj + 1) → Γ) + (par : Fin (jj + 1)) (P : SuccParams tm.Q kk) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) : + (∀ q, 1 ≤ q → q ≤ 2 → cols q par = Γ.one) ↔ P.inSym = Γ.start := by + obtain ⟨h1, h2⟩ := inSym_cells tm cols par P hpar + constructor + · intro h + have e1 : Γ.ofBool (gammaBits P.inSym).1 = Γ.one := by rw [← h1]; exact h 1 le_rfl (by omega) + have e2 : Γ.ofBool (gammaBits P.inSym).2 = Γ.one := by rw [← h2]; exact h 2 (by omega) le_rfl + refine gammaBits_injective ?_ + refine Prod.ext ?_ ?_ + · cases hb : (gammaBits P.inSym).1 with + | true => rfl + | false => rw [hb] at e1; exact absurd e1 (fun hc => Γ.noConfusion hc) + · cases hb : (gammaBits P.inSym).2 with + | true => rfl + | false => rw [hb] at e2; exact absurd e2 (fun hc => Γ.noConfusion hc) + · intro h q hq1 hq2 + rcases Nat.lt_or_ge q 2 with hlt | hge + · rw [show q = 1 by omega, h1, h] + rfl + · rw [show q = 2 by omega, h2, h] + rfl + +/-! ## What each scanner decides -/ + +set_option maxHeartbeats 1000000 in +/-- **The window checker decides the window condition.** -/ +theorem windowScanner_decides (tm : NTM kk) (i : Fin kk) (cols : ℕ → Fin 3 → Γ) (S : ℕ) + (hd hd' : Fin (S + 1)) (cl cl' : Fin (S + 1) → Γ) + (ha : HoldsWindow cols (succParamsCodec tm.Q kk).width 1 hd cl) + (hb : HoldsWindow cols (succParamsCodec tm.Q kk).width 2 hd' cl') + (hend : markOf cols (succParamsCodec tm.Q kk).width 1 (S + 1) = false) : + (windowScanner tm i).emit ((windowScanner tm i).run cols + ((succParamsCodec tm.Q kk).width + 3 * (S + 1))) = true ↔ + (cl hd = (windowParams tm cols).wSym i ∧ + (∀ p, cl' p = if p = hd ∧ 0 < p.val then succWrite tm (windowParams tm cols) i + else cl p) ∧ + hd'.val = movedIdx (succDir tm (windowParams tm cols) i) hd.val) := by + rw [windowScanner_run] + exact blockEmit_holds cols (succParamsCodec tm.Q kk).width 1 2 hd hd' cl cl' ha hb + ((windowParams tm cols).wSym i) (succWrite tm (windowParams tm cols) i) + (succDir tm (windowParams tm cols) i) (by omega) hend + +set_option maxHeartbeats 1000000 in +/-- **The output checker decides the output-window condition.** -/ +theorem outputScanner_decides (tm : NTM kk) (cols : ℕ → Fin 3 → Γ) (S : ℕ) + (hd hd' : Fin (S + 2)) (cl cl' : Fin (S + 2) → Γ) + (ha : HoldsWindow cols (succParamsCodec tm.Q kk).width 1 hd cl) + (hb : HoldsWindow cols (succParamsCodec tm.Q kk).width 2 hd' cl') + (hend : markOf cols (succParamsCodec tm.Q kk).width 1 (S + 2) = false) : + (outputScanner tm).emit ((outputScanner tm).run cols + ((succParamsCodec tm.Q kk).width + 3 * (S + 2))) = true ↔ + (cl hd = (windowParams tm cols).oSym ∧ + (∀ p, cl' p = if p = hd ∧ 0 < p.val + then (((succTrans tm (windowParams tm cols)).2.2.1 : Γw) : Γ) else cl p) ∧ + hd'.val = movedIdx (succTrans tm (windowParams tm cols)).2.2.2.2.2 hd.val) := by + rw [outputScanner_run] + exact blockEmit_holds cols (succParamsCodec tm.Q kk).width 1 2 hd hd' cl cl' ha hb + (windowParams tm cols).oSym (((succTrans tm (windowParams tm cols)).2.2.1 : Γw) : Γ) + (succTrans tm (windowParams tm cols)).2.2.2.2.2 (by omega) hend + +set_option maxHeartbeats 1000000 in +/-- **The input-head checker decides the input-head condition.** -/ +theorem headScanner_decides (tm : NTM kk) (cols : ℕ → Fin 3 → Γ) (w u v : ℕ) + (hu : u < 2 ^ w) (hv : v < 2 ^ w) + (ha : HoldsBits (fun t => cols ((succParamsCodec tm.Q kk).width + t)) 0 1 + (bitsOfLenLE w u)) + (hb : HoldsBits (fun t => cols ((succParamsCodec tm.Q kk).width + t)) 0 2 + (bitsOfLenLE w v)) + (hleft : (succTrans tm (windowParams tm cols)).2.2.2.1 = Dir3.left → 0 < u) : + (headScanner tm).emit ((headScanner tm).run cols + ((succParamsCodec tm.Q kk).width + w)) = true ↔ + v = movedIdx (succTrans tm (windowParams tm cols)).2.2.2.1 u := by + rw [headScanner_run] + exact inHeadEmit_of_holds cols (succParamsCodec tm.Q kk).width 1 2 _ w u v hu hv ha hb hleft + +set_option maxHeartbeats 1000000 in +/-- **The state checker decides the state condition.** -/ +theorem stateScanner_decides (tm : NTM kk) (isNew : Bool) (cols : ℕ → Fin 2 → Γ) (q : tm.Q) + (h : HoldsBits cols 0 1 ((qCodec tm.Q).enc q)) : + (stateScanner tm isNew).emit ((stateScanner tm isNew).run cols (stateWidth tm)) = true ↔ + q = (if isNew then succState tm (paramsOfStateTable tm (stateTable tm cols)) + else (paramsOfStateTable tm (stateTable tm cols)).q) := by + rw [stateScanner_run, decide_eq_true_eq] + have hq : stateOfTable tm (stateTable tm cols) = q := + ofTable_of_holds_zero (qCodec tm.Q) q cols 2 (stateWidth tm) (fun t => t) 1 + (le_max_right _ _) _ h + rw [hq] + +/-! ## The checks as machines + +Each check is `TM.checkTM` of its scanner: the scanner names the columns it reads, so the checked +registers need not be adjacent and no check needs a private copy of them. The checks never consult +the guess tape — they are built on the register tapes alone, and the guess tape is added once, at +the very end, by `TM.liftLast`, which is where their `TM.GuessProtocol` comes from. Only the +stages that *write* guesses carry advancing states. + +`Complexity.windowScanner_decides` and its siblings are stated about the three columns a check +reads, which is exactly the restriction `TM.checkTM_hoareTime` leaves in its postcondition, so +they apply to a full-width check unchanged. -/ + +/-! ## Combining the verdicts + +One scan over every tape, looking only at the result registers' first cells. No placement, so the +registers need not be adjacent. -/ + +/-- The machine that combines the verdicts. -/ +noncomputable def combineTM (N : ℕ) (P : Fin (N + 1) → Bool) : TM (N + 2) := + TM.twoPassTM (Scanner.andFirst N P) + +/-- **The combining machine's contract.** -/ +theorem combineTM_hoareTime (N : ℕ) (P : Fin (N + 1) → Bool) (cells : Fin (N + 1) → ℕ → Γ) + (len : ℕ) (inp₀ out₀ res₀ : Tape) (hok : TM.ScanOk inp₀ res₀ out₀) + (ht : TM.ScanTape cells len) : + (combineTM N P).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) res₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) + (res₀.write (Γ.ofBool ((Scanner.andFirst N P).emit + ((Scanner.andFirst N P).run (TM.scanCol cells) len))))) + (2 * len + 3) := + TM.twoPassTM_hoareTime (Scanner.andFirst N P) cells len inp₀ out₀ res₀ hok ht + +/-- **The bit the combining machine writes**: whether every designated register said yes. -/ +theorem combineTM_verdict (N : ℕ) (P : Fin (N + 1) → Bool) (cells : Fin (N + 1) → ℕ → Γ) + (len : ℕ) (hlen : 0 < len) : + (Scanner.andFirst N P).emit ((Scanner.andFirst N P).run (TM.scanCol cells) len) = true ↔ + ∀ i, P i = true → cells i 1 = Γ.one := + Scanner.andFirst_run N P (TM.scanCol cells) len hlen + +/-! ## The equality and increment checks + +The walk may keep a configuration as well as step it, and keeping is register equality — decided +by the comparison scanner, one register pair at a time. A counter advances the same way: the next +value is guessed into a second register and `Complexity.Scanner.plusOne` checks it. Both scanners +already take arbitrary register indices at any width, so neither needs `TM.checkTM`. -/ + +/-! ## One walk step, as a single scan + +A machine has one result tape, so the checks of a walk step run together: one automaton whose +state is the tuple of theirs, each component frozen at its own length by +`Complexity.Scanner.upTo` and reading its own registers through +`Complexity.Scanner.comap`. -/ + +/-- The columns a window check reads: the parameter block, then the old and new windows. -/ +def windowCols {kk jj : ℕ} (par : Fin (jj + 1)) (Ra Rb : CodeRegs kk jj) (i : Fin kk) : + Fin 3 → Fin (jj + 1) := + fun c => if c.val = 0 then par else if c.val = 1 then Ra.wk i else Rb.wk i + +/-- The columns the output-window check reads. -/ +def outputCols {kk jj : ℕ} (par : Fin (jj + 1)) (Ra Rb : CodeRegs kk jj) : + Fin 3 → Fin (jj + 1) := + fun c => if c.val = 0 then par else if c.val = 1 then Ra.ot else Rb.ot + +/-- The columns the input-head check reads. -/ +def headCols {kk jj : ℕ} (par : Fin (jj + 1)) (Ra Rb : CodeRegs kk jj) : + Fin 3 → Fin (jj + 1) := + fun c => if c.val = 0 then par else if c.val = 1 then Ra.hd else Rb.hd + +/-- The columns a state check reads. -/ +def stateCols {kk jj : ℕ} (par : Fin (jj + 1)) (R : CodeRegs kk jj) : Fin 2 → Fin (jj + 1) := + fun c => if c.val = 0 then par else R.st + +/-- The width of block `p` in the walk's layout: the field's own width, and for every register +but the state's the parameter-block padding in front of it. -/ +noncomputable def blockLen {kk : ℕ} (tm : NTM kk) (nn S : ℕ) (p : ℕ) : ℕ := + if p = 0 then codeWidthRaw tm nn S 0 + else (succParamsCodec tm.Q kk).width + (codeWidthRaw tm nn S p + 1) + +theorem codeBlockScan_length {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (p : ℕ) : + (codeBlockScan tm x S a p).length = blockLen tm x.length S p := by + rw [codeBlockScan, blockLen] + split_ifs with h + · exact codeBlock_length tm x S a 0 + · rw [List.length_append, List.length_replicate, List.length_append, codeBlock_length] + rfl + +/-- The scan that decides that two register tuples hold the same code: one comparison per block, +each frozen at that block's width. -/ +noncomputable def eqScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (j j' : ℕ → Fin (jj + 1)) : + Scanner jj := + Scanner.all (kk + 3) (fun p => + (Scanner.eq jj (j p.val) (j' p.val)).upTo (blockLen tm nn S p.val)) + +/-- A length that covers every check of a walk step. -/ +noncomputable def walkScanLen {kk : ℕ} (tm : NTM kk) (nn S : ℕ) : ℕ := + (succParamsCodec tm.Q kk).width + (qCodec tm.Q).width + (finCodec (nn + S + 2)).width + + stateWidth tm + 3 * (S + 2) + (S + 1) * 3 + (S + 2) * 3 + +theorem blockLen_le {kk : ℕ} (tm : NTM kk) (nn S p : ℕ) : + blockLen tm nn S p ≤ walkScanLen tm nn S := by + simp only [blockLen, walkScanLen, codeWidthRaw] + split_ifs <;> omega + +theorem succParamsCodec_width_le_walkScanLen {kk : ℕ} (tm : NTM kk) (nn S : ℕ) : + (succParamsCodec tm.Q kk).width ≤ walkScanLen tm nn S := by + rw [walkScanLen] + omega + +theorem one_le_walkScanLen {kk : ℕ} (tm : NTM kk) (nn S : ℕ) : 1 ≤ walkScanLen tm nn S := by + have := succParamsCodec_width_pos tm + have := succParamsCodec_width_le_walkScanLen tm nn S + omega + +theorem headField_le_walkScanLen {kk : ℕ} (tm : NTM kk) (nn S : ℕ) : + (succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width ≤ walkScanLen tm nn S := by + rw [walkScanLen] + omega + +theorem two_le_walkScanLen {kk : ℕ} (tm : NTM kk) (nn S : ℕ) : 2 ≤ walkScanLen tm nn S := by + have h1 := succParamsCodec_width_pos tm + have h2 := headField_le_walkScanLen tm nn S + have h3 : 0 < (finCodec (nn + S + 2)).width := by + show 0 < bitWidth (nn + S + 2) + have := le_two_pow_bitWidth (nn + S + 2) + by_contra hc + have hz : bitWidth (nn + S + 2) = 0 := by omega + rw [hz] at this + simp at this + omega + +/-- The scan that checks the guessed input symbol, conditional on where the simulated head is: +against the parameter register alone when the head is at the marker, and against the machine's own +input tape — through `TM.inMatchTM`'s verdict — when it is not. -/ +noncomputable def inSymScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par hd res : Fin (jj + 1)) : Scanner jj := + Scanner.or + (Scanner.all 2 (fun p => if p.val = 0 then headZeroScanner tm nn S hd + else (Scanner.isConst jj par Γ.one).upTo 2)) + (Scanner.all 2 (fun p => if p.val = 0 then headNonZeroScanner tm nn S hd + else (Scanner.isConst jj res Γ.one).upTo 1)) + +/-- **The equality scan decides that two guesses are the same code.** -/ +theorem eqScanner_decides {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (j j' : ℕ → Fin (jj + 1)) (a b : Code tm.Q kk x.length S) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S b p)) + (hv : (eqScanner tm x.length S j j').emit + ((eqScanner tm x.length S j j').run cols (walkScanLen tm x.length S)) = true) : + a = b := by + rw [eqScanner, Scanner.all_emit_run] at hv + have hblk : ∀ p, p < kk + 3 → codeBlockScan tm x S a p = codeBlockScan tm x S b p := by + intro p hp + have h := hv ⟨p, hp⟩ + rw [Scanner.upTo_emit_run _ (Scanner.rightOnly_eq jj (j p) (j' p)) _ _ + (blockLen_le tm x.length S p)] at h + refine (eq_run_of_holds cols (j p) (j' p) _ _ ?_ (ha p hp) (hb p hp)).mp ?_ + · rw [codeBlockScan_length, codeBlockScan_length] + · rwa [codeBlockScan_length] + have hfield : ∀ p, p < kk + 3 → codeBlock tm x S a p = codeBlock tm x S b p := by + intro p hp + have h := hblk p hp + rw [codeBlockScan, codeBlockScan] at h + by_cases h0 : p = 0 + · subst h0 + rwa [if_pos rfl, if_pos rfl] at h + · rw [if_neg h0, if_neg h0] at h + exact List.append_cancel_right (List.append_cancel_left h) + have hst : a.1 = b.1 := by + have h := hfield 0 (by omega) + rw [codeBlock_st, codeBlock_st] at h + exact (qCodec tm.Q).enc_injective h + have hhd : a.2.1 = b.2.1 := by + have h := hfield 1 (by omega) + rw [codeBlock_hd, codeBlock_hd] at h + exact (finCodec (x.length + S + 2)).enc_injective h + have hwk : a.2.2.1 = b.2.2.1 := by + funext i + have h := hfield (i.val + 2) (by omega) + rw [codeBlock_wk, codeBlock_wk] at h + exact (tapeCodec (S + 1)).enc_injective h + have hot : a.2.2.2 = b.2.2.2 := by + have h := hfield (kk + 2) (by omega) + rw [codeBlock_ot, codeBlock_ot] at h + exact (tapeCodec (S + 2)).enc_injective h + exact Prod.ext hst (Prod.ext hhd (Prod.ext hwk hot)) + +/-- **The equality scan accepts two guesses of the same code.** -/ +theorem eqScanner_accepts {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (j j' : ℕ → Fin (jj + 1)) (a : Code tm.Q kk x.length S) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S a p)) : + (eqScanner tm x.length S j j').emit + ((eqScanner tm x.length S j j').run cols (walkScanLen tm x.length S)) = true := by + rw [eqScanner, Scanner.all_emit_run] + intro p + rw [Scanner.upTo_emit_run _ (Scanner.rightOnly_eq jj (j p.val) (j' p.val)) _ _ + (blockLen_le tm x.length S p.val)] + have h := (eq_run_of_holds cols (j p.val) (j' p.val) (codeBlockScan tm x S a p.val) + (codeBlockScan tm x S a p.val) rfl (ha p.val p.isLt) (hb p.val p.isLt)).mpr rfl + rwa [codeBlockScan_length] at h + +/-- **The input-symbol scan decides the guessed symbol.** -/ +theorem inSymScanner_decides {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par hd res : Fin (jj + 1)) (P : SuccParams tm.Q kk) + (a : Code tm.Q kk x.length S) (g : Γ) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (hhd : HoldsBits cols (succParamsCodec tm.Q kk).width hd + ((finCodec (x.length + S + 2)).enc a.2.1)) + (hres : cols 1 res = Γ.ofBool (TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par))) + (hg : a.2.1.val ≠ 0 → g = inSymOf tm x S a) + (hv : (inSymScanner tm x.length S par hd res).emit + ((inSymScanner tm x.length S par hd res).run cols (walkScanLen tm x.length S)) = true) : + P.inSym = inSymOf tm x S a := by + rw [inSymScanner, Scanner.or_emit_run] at hv + rcases hv with h | h + · rw [Scanner.all_emit_run] at h + have h0 := h ⟨0, by omega⟩ + have h1 := h ⟨1, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0)] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0))] at h1 + have hzero : a.2.1.val = 0 := + (headZeroScanner_decides tm x.length S hd cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhd).mp h0 + have hstart : P.inSym = Γ.start := + (parStart_iff tm cols par P hpar).mp + ((Scanner.isConst_upTo_run jj par Γ.one cols 2 (walkScanLen tm x.length S) + (two_le_walkScanLen tm x.length S)).mp h1) + rw [hstart, inSymOf, hzero] + exact (Tape.init_cells_zero _).symm + · rw [Scanner.all_emit_run] at h + have h0 := h ⟨0, by omega⟩ + have h1 := h ⟨1, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0)] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0))] at h1 + have hne : a.2.1.val ≠ 0 := + (headNonZeroScanner_decides tm x.length S hd cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhd).mp h0 + have hone : cols 1 res = Γ.one := + (Scanner.isConst_cell jj res Γ.one cols (walkScanLen tm x.length S) + (by have := two_le_walkScanLen tm x.length S; omega)).mp h1 + have hverdict : TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par) = true := by + rw [hres] at hone + cases hc : TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par) with + | false => rw [hc] at hone; exact absurd hone (fun hz => Γ.noConfusion hz) + | true => rfl + rw [inSym_eq_of_inMatch tm cols par P g hpar hverdict] + exact hg hne + +/-- **The input-symbol scan accepts a correct guess.** -/ +theorem inSymScanner_accepts {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par hd res : Fin (jj + 1)) (P : SuccParams tm.Q kk) + (a : Code tm.Q kk x.length S) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (hhd : HoldsBits cols (succParamsCodec tm.Q kk).width hd + ((finCodec (x.length + S + 2)).enc a.2.1)) + (hin : P.inSym = inSymOf tm x S a) + (hres : a.2.1.val ≠ 0 → cols 1 res = Γ.one) : + (inSymScanner tm x.length S par hd res).emit + ((inSymScanner tm x.length S par hd res).run cols (walkScanLen tm x.length S)) = true := by + rw [inSymScanner, Scanner.or_emit_run] + by_cases hz : a.2.1.val = 0 + · refine Or.inl ?_ + rw [Scanner.all_emit_run] + intro p + by_cases hp : p.val = 0 + · rw [if_pos hp] + exact (headZeroScanner_decides tm x.length S hd cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhd).mpr hz + · rw [if_neg hp] + refine (Scanner.isConst_upTo_run jj par Γ.one cols 2 (walkScanLen tm x.length S) + (two_le_walkScanLen tm x.length S)).mpr ?_ + refine (parStart_iff tm cols par P hpar).mpr ?_ + rw [hin, inSymOf, hz] + exact Tape.init_cells_zero _ + · refine Or.inr ?_ + rw [Scanner.all_emit_run] + intro p + by_cases hp : p.val = 0 + · rw [if_pos hp] + exact (headNonZeroScanner_decides tm x.length S hd cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhd).mpr hz + · rw [if_neg hp] + exact (Scanner.isConst_cell jj res Γ.one cols (walkScanLen tm x.length S) + (one_le_walkScanLen tm x.length S)).mpr (hres hz) + +/-- The scan that decides a successor step: one check per work window, the output window, the +input head, and the two state fields — all against the parameters in the same register. -/ +noncomputable def succScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (par : Fin (jj + 1)) + (Ra Rb : CodeRegs kk jj) : Scanner jj := + Scanner.all (kk + 4) (fun p => + if h : p.val < kk then + ((windowScanner tm ⟨p.val, h⟩).comap (windowCols par Ra Rb ⟨p.val, h⟩)).upTo + ((succParamsCodec tm.Q kk).width + 3 * (S + 1)) + else if p.val = kk then + ((outputScanner tm).comap (outputCols par Ra Rb)).upTo + ((succParamsCodec tm.Q kk).width + 3 * (S + 2)) + else if p.val = kk + 1 then + ((headScanner tm).comap (headCols par Ra Rb)).upTo + ((succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width) + else if p.val = kk + 2 then + ((stateScanner tm false).comap (stateCols par Ra)).upTo (stateWidth tm) + else ((stateScanner tm true).comap (stateCols par Rb)).upTo (stateWidth tm)) + +/-- **The parameters a check reads depend only on the register it reads them from.** Every check +of a walk step reads the same parameter register, so they all work against the same guessed +transition — which is what lets one guess serve five checks. -/ +theorem windowParams_congr {kk : ℕ} (tm : NTM kk) (cols cols' : ℕ → Fin 3 → Γ) + (h : ∀ q, cols q 0 = cols' q 0) : windowParams tm cols = windowParams tm cols' := by + rw [windowParams, windowParams, + Scanner.auxRun_bitsStep_congr (fun _ => 0) cols cols' (fun q _ => h q) _ + (succParamsCodec tm.Q kk).width] + +/-- **Both readers of the parameter register read the same parameters.** The window, output and +input-head checks read the guessed transition with one reader; the state checks read it with +another, over a wider block. When the register holds an encoding, the two agree — which is what +lets the state checks be checks against the same guess as the rest. -/ +theorem params_of_holds {kk : ℕ} (tm : NTM kk) (P : SuccParams tm.Q kk) + (colsW : ℕ → Fin 3 → Γ) (colsS : ℕ → Fin 2 → Γ) + (hW : HoldsBits colsW 0 0 ((succParamsCodec tm.Q kk).enc P)) + (hS : HoldsBits colsS 0 0 ((succParamsCodec tm.Q kk).enc P)) : + windowParams tm colsW = P ∧ paramsOfStateTable tm (stateTable tm colsS) = P := by + constructor + · have h := ofTable_of_holds_zero (succParamsCodec tm.Q kk) P colsW 1 + (succParamsCodec tm.Q kk).width (fun _ => 0) 0 le_rfl (fun _ _ => false) hW + rw [windowParams, paramsOfTable] + exact h + · have h := ofTable_of_holds_zero (succParamsCodec tm.Q kk) P colsS 2 (stateWidth tm) + (fun t => t) 0 (le_max_left _ _) (fun _ _ => false) hS + rw [paramsOfStateTable, stateTable] + exact h + +/-- **Every check of a walk step reads the same parameters.** -/ +theorem walkParams_eq {kk jj : ℕ} (tm : NTM kk) (par : Fin (jj + 1)) (Ra Rb : CodeRegs kk jj) + (cols : ℕ → Fin (jj + 1) → Γ) (i : Fin kk) : + windowParams tm (fun q c => cols q (windowCols par Ra Rb i c)) + = windowParams tm (fun q c => cols q (outputCols par Ra Rb c)) ∧ + windowParams tm (fun q c => cols q (windowCols par Ra Rb i c)) + = windowParams tm (fun q c => cols q (headCols par Ra Rb c)) := + ⟨windowParams_congr tm _ _ (fun _ => rfl), windowParams_congr tm _ _ (fun _ => rfl)⟩ + +/-- **A successor scan's verdict is the verdict of each of its checks.** Each component reads its +own registers, over its own cells, exactly as it would have alone. -/ +theorem succScanner_verdicts {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) (par : Fin (jj + 1)) + (Ra Rb : CodeRegs kk jj) (cols : ℕ → Fin (jj + 1) → Γ) + (hv : (succScanner tm nn S par Ra Rb).emit + ((succScanner tm nn S par Ra Rb).run cols (walkScanLen tm nn S)) = true) : + (∀ i, (windowScanner tm i).emit ((windowScanner tm i).run + (fun q c => cols q (windowCols par Ra Rb i c)) + ((succParamsCodec tm.Q kk).width + 3 * (S + 1))) = true) ∧ + (outputScanner tm).emit ((outputScanner tm).run + (fun q c => cols q (outputCols par Ra Rb c)) + ((succParamsCodec tm.Q kk).width + 3 * (S + 2))) = true ∧ + (headScanner tm).emit ((headScanner tm).run + (fun q c => cols q (headCols par Ra Rb c)) + ((succParamsCodec tm.Q kk).width + (finCodec (nn + S + 2)).width)) = true ∧ + (stateScanner tm false).emit ((stateScanner tm false).run + (fun q c => cols q (stateCols par Ra c)) (stateWidth tm)) = true ∧ + (stateScanner tm true).emit ((stateScanner tm true).run + (fun q c => cols q (stateCols par Rb c)) (stateWidth tm)) = true := by + rw [succScanner, Scanner.all_emit_run] at hv + have hcomp : ∀ {jd : ℕ} (T : Scanner jd) (f : Fin (jd + 1) → Fin (jj + 1)) (w : ℕ), + (∀ s c, T.stepL s c = s) → w ≤ walkScanLen tm nn S → + ((T.comap f).upTo w).emit (((T.comap f).upTo w).run cols (walkScanLen tm nn S)) = true → + T.emit (T.run (fun q c => cols q (f c)) w) = true := by + intro jd T f w hT hw h + rw [Scanner.upTo_emit_run _ (Scanner.rightOnly_comap hT f) w _ hw, + Scanner.comap_emit, Scanner.comap_run] at h + exact h + refine ⟨fun i => ?_, ?_, ?_, ?_, ?_⟩ + · have h := hv ⟨i.val, by omega⟩ + rw [dif_pos i.isLt, show (⟨i.val, i.isLt⟩ : Fin kk) = i from Fin.ext rfl] at h + exact hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) h + · have h := hv ⟨kk, by omega⟩ + rw [dif_neg (by exact Nat.lt_irrefl kk), if_pos (rfl : kk = kk)] at h + exact hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) h + · have h := hv ⟨kk + 1, by omega⟩ + rw [dif_neg (by exact Nat.not_lt.mpr (Nat.le_succ kk)), + if_neg (by exact Nat.succ_ne_self kk), if_pos (rfl : kk + 1 = kk + 1)] at h + exact hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) h + · have h := hv ⟨kk + 2, by omega⟩ + rw [dif_neg (by exact Nat.not_lt.mpr (Nat.le_add_right kk 2)), + if_neg (by exact (by omega : kk + 2 ≠ kk)), + if_neg (by exact (by omega : kk + 2 ≠ kk + 1)), + if_pos (rfl : kk + 2 = kk + 2)] at h + exact hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) h + · have h := hv ⟨kk + 3, by omega⟩ + rw [dif_neg (by exact Nat.not_lt.mpr (Nat.le_add_right kk 3)), + if_neg (by exact (by omega : kk + 3 ≠ kk)), + if_neg (by exact (by omega : kk + 3 ≠ kk + 1)), + if_neg (by exact (by omega : kk + 3 ≠ kk + 2))] at h + exact hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) h + +/-- **The successor scan accepts a genuine successor.** The converse of +`Complexity.succScanner_decides`: when the registers really do hold a code and the code the +transition makes of it, every check passes. This is the direction a completeness proof needs — it +says the right guess exists. -/ +theorem succScanner_accepts {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par : Fin (jj + 1)) (Ra Rb : CodeRegs kk jj) + (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (ha : HoldsCodeScan tm x S cols Ra a) (hb : HoldsCodeScan tm x S cols Rb b) + (hendW : ∀ i, markOf (fun q c => cols q (windowCols par Ra Rb i c)) + (succParamsCodec tm.Q kk).width 1 (S + 1) = false) + (hendO : markOf (fun q c => cols q (outputCols par Ra Rb c)) + (succParamsCodec tm.Q kk).width 1 (S + 2) = false) + (hq : a.1 = P.q) (hstate : b.1 = succState tm P) + (hwsym : ∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) + (hosym : a.2.2.2.2 a.2.2.2.1 = P.oSym) + (hhead : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val) + (hwork : ∀ i, (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val ∧ + ∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) + (hout : b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) + (hleft : (succTrans tm P).2.2.2.1 = Dir3.left → 0 < a.2.1.val) : + (succScanner tm x.length S par Ra Rb).emit + ((succScanner tm x.length S par Ra Rb).run cols (walkScanLen tm x.length S)) = true := by + obtain ⟨hast, hahd, hawk, haot⟩ := ha + obtain ⟨hbst, hbhd, hbwk, hbot⟩ := hb + have hPo : windowParams tm (fun q c => cols q (outputCols par Ra Rb c)) = P := + (params_of_holds tm P (fun q c => cols q (outputCols par Ra Rb c)) + (fun q c => cols q (stateCols par Ra c)) hpar hpar).1 + have hPsa : paramsOfStateTable tm + (stateTable tm (fun q c => cols q (stateCols par Ra c))) = P := + (params_of_holds tm P (fun q c => cols q (outputCols par Ra Rb c)) + (fun q c => cols q (stateCols par Ra c)) hpar hpar).2 + have hPsb : paramsOfStateTable tm + (stateTable tm (fun q c => cols q (stateCols par Rb c))) = P := + (params_of_holds tm P (fun q c => cols q (outputCols par Ra Rb c)) + (fun q c => cols q (stateCols par Rb c)) hpar hpar).2 + have hPw : ∀ i : Fin kk, + windowParams tm (fun q c => cols q (windowCols par Ra Rb i c)) = P := by + intro i + rw [windowParams_congr tm (fun q c => cols q (windowCols par Ra Rb i c)) + (fun q c => cols q (outputCols par Ra Rb c)) (fun _ => rfl)] + exact hPo + have hPh : windowParams tm (fun q c => cols q (headCols par Ra Rb c)) = P := by + rw [windowParams_congr tm (fun q c => cols q (headCols par Ra Rb c)) + (fun q c => cols q (outputCols par Ra Rb c)) (fun _ => rfl)] + exact hPo + rw [succScanner, Scanner.all_emit_run] + intro p + have hcomp : ∀ {jd : ℕ} (T : Scanner jd) (f : Fin (jd + 1) → Fin (jj + 1)) (wid : ℕ), + (∀ s c, T.stepL s c = s) → wid ≤ walkScanLen tm x.length S → + T.emit (T.run (fun q c => cols q (f c)) wid) = true → + ((T.comap f).upTo wid).emit (((T.comap f).upTo wid).run cols + (walkScanLen tm x.length S)) = true := by + intro jd T f wid hT hwid h + rw [Scanner.upTo_emit_run _ (Scanner.rightOnly_comap hT f) wid _ hwid, + Scanner.comap_emit, Scanner.comap_run] + exact h + by_cases hpk : p.val < kk + · rw [dif_pos hpk] + refine hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) ?_ + refine (windowScanner_decides tm ⟨p.val, hpk⟩ _ S (a.2.2.1 ⟨p.val, hpk⟩).1 + (b.2.2.1 ⟨p.val, hpk⟩).1 (a.2.2.1 ⟨p.val, hpk⟩).2 (b.2.2.1 ⟨p.val, hpk⟩).2 + (hawk ⟨p.val, hpk⟩) (hbwk ⟨p.val, hpk⟩) (hendW ⟨p.val, hpk⟩)).mpr ?_ + rw [hPw ⟨p.val, hpk⟩] + exact ⟨hwsym _, (hwork _).2, (hwork _).1⟩ + · rw [dif_neg hpk] + by_cases hpo : p.val = kk + · rw [if_pos hpo] + refine hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) ?_ + refine (outputScanner_decides tm _ S a.2.2.2.1 b.2.2.2.1 a.2.2.2.2 b.2.2.2.2 + haot hbot hendO).mpr ?_ + rw [hPo] + exact ⟨hosym, hout.2, hout.1⟩ + · rw [if_neg hpo] + by_cases hph : p.val = kk + 1 + · rw [if_pos hph] + refine hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) ?_ + refine (headScanner_decides tm _ (bitWidth (x.length + S + 2)) a.2.1.val b.2.1.val + (lt_of_lt_of_le a.2.1.isLt (le_two_pow_bitWidth _)) + (lt_of_lt_of_le b.2.1.isLt (le_two_pow_bitWidth _)) + hahd.shift hbhd.shift (by rw [hPh]; exact hleft)).mpr ?_ + rw [hPh] + exact hhead + · rw [if_neg hph] + by_cases hps : p.val = kk + 2 + · rw [if_pos hps] + refine hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) ?_ + refine (stateScanner_decides tm false _ a.1 hast).mpr ?_ + rw [hPsa, if_neg (by simp)] + exact hq + · rw [if_neg hps] + refine hcomp _ _ _ (fun _ _ => rfl) (by rw [walkScanLen]; omega) ?_ + refine (stateScanner_decides tm true _ b.1 hbst).mpr ?_ + rw [hPsb, if_pos rfl] + exact hstate + +/-- **The successor scan decides a successor step.** Given that the parameter register holds a +guessed transition, the scan's verdict says exactly that the second code is what that transition +makes of the first. What the scan cannot see is left to the caller: the symbol under the +simulated input head, which the machine reads from its own input tape, and that the step stays +inside the space window. -/ +theorem succScanner_decides {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par : Fin (jj + 1)) (Ra Rb : CodeRegs kk jj) + (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (ha : HoldsCodeScan tm x S cols Ra a) (hb : HoldsCodeScan tm x S cols Rb b) + (hne : a.1 ≠ tm.qhalt) + (hendW : ∀ i, markOf (fun q c => cols q (windowCols par Ra Rb i c)) + (succParamsCodec tm.Q kk).width 1 (S + 1) = false) + (hendO : markOf (fun q c => cols q (outputCols par Ra Rb c)) + (succParamsCodec tm.Q kk).width 1 (S + 2) = false) + (hin : P.inSym = inSymOf tm x S a) + (hv : (succScanner tm x.length S par Ra Rb).emit + ((succScanner tm x.length S par Ra Rb).run cols (walkScanLen tm x.length S)) = true) : + b ∈ NTM.codeSucc tm x S a ∧ + b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val := by + obtain ⟨vwork, vout, vhead, vsta, vstb⟩ := + succScanner_verdicts tm x.length S par Ra Rb cols hv + -- Reading `▷` forces the input head right, so a left move means it was not at the marker. + have hleft : (succTrans tm P).2.2.2.1 = Dir3.left → 0 < a.2.1.val := by + intro hd + by_contra hzero + have h0 : a.2.1.val = 0 := by omega + have hstart : P.inSym = Γ.start := by + rw [hin, inSymOf, h0] + exact Tape.init_cells_zero _ + have hright := (tm.δ_right_of_start P.beta P.q P.inSym P.wSym P.oSym).1 hstart + rw [succTrans] at hd + rw [hd] at hright + exact Dir3.noConfusion hright + obtain ⟨hast, hahd, hawk, haot⟩ := ha + obtain ⟨hbst, hbhd, hbwk, hbot⟩ := hb + have hPo : windowParams tm (fun q c => cols q (outputCols par Ra Rb c)) = P := + (params_of_holds tm P (fun q c => cols q (outputCols par Ra Rb c)) + (fun q c => cols q (stateCols par Ra c)) hpar hpar).1 + have hPsa : paramsOfStateTable tm + (stateTable tm (fun q c => cols q (stateCols par Ra c))) = P := + (params_of_holds tm P (fun q c => cols q (outputCols par Ra Rb c)) + (fun q c => cols q (stateCols par Ra c)) hpar hpar).2 + have hPsb : paramsOfStateTable tm + (stateTable tm (fun q c => cols q (stateCols par Rb c))) = P := + (params_of_holds tm P (fun q c => cols q (outputCols par Ra Rb c)) + (fun q c => cols q (stateCols par Rb c)) hpar hpar).2 + have hq : a.1 = P.q := by + have h := (stateScanner_decides tm false (fun q c => cols q (stateCols par Ra c)) a.1 + hast).mp vsta + rwa [hPsa, if_neg (by simp)] at h + have hstate : b.1 = succState tm P := by + have h := (stateScanner_decides tm true (fun q c => cols q (stateCols par Rb c)) b.1 + hbst).mp vstb + rwa [hPsb, if_pos rfl] at h + have hwork : ∀ i, ((a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) ∧ + (∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) ∧ + (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val := by + intro i + have h := (windowScanner_decides tm i (fun q c => cols q (windowCols par Ra Rb i c)) S + (a.2.2.1 i).1 (b.2.2.1 i).1 (a.2.2.1 i).2 (b.2.2.1 i).2 (hawk i) (hbwk i) + (hendW i)).mp (vwork i) + rwa [windowParams_congr tm (fun q c => cols q (windowCols par Ra Rb i c)) + (fun q c => cols q (outputCols par Ra Rb c)) (fun _ => rfl), hPo] at h + have hout : (a.2.2.2.2 a.2.2.2.1 = P.oSym) ∧ + (∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) ∧ + b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val := by + have h := (outputScanner_decides tm (fun q c => cols q (outputCols par Ra Rb c)) S + a.2.2.2.1 b.2.2.2.1 a.2.2.2.2 b.2.2.2.2 haot hbot hendO).mp vout + rwa [hPo] at h + have hpar' : windowParams tm (fun q c => cols q (headCols par Ra Rb c)) = P := by + rw [windowParams_congr tm (fun q c => cols q (headCols par Ra Rb c)) + (fun q c => cols q (outputCols par Ra Rb c)) (fun _ => rfl)] + exact hPo + have hhead : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val := by + have h := (headScanner_decides tm (fun q c => cols q (headCols par Ra Rb c)) + (bitWidth (x.length + S + 2)) a.2.1.val b.2.1.val + (lt_of_lt_of_le a.2.1.isLt (le_two_pow_bitWidth _)) + (lt_of_lt_of_le b.2.1.isLt (le_two_pow_bitWidth _)) + hahd.shift hbhd.shift (by rw [hpar']; exact hleft)).mp vhead + rwa [hpar'] at h + -- The new code's fields are bounded by their own types, so the step stays in the window. + have hclampIn : movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ≤ x.length + S + 1 := by + rw [← hhead] + exact Nat.lt_succ_iff.mp b.2.1.isLt + have hclampW : ∀ i, movedIdx (succDir tm P i) (a.2.2.1 i).1.val ≤ S := by + intro i + rw [← (hwork i).2.2] + exact Nat.lt_succ_iff.mp (b.2.2.1 i).1.isLt + have hclampO : movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ≤ S + 1 := by + rw [← hout.2.2] + exact Nat.lt_succ_iff.mp b.2.2.2.1.isLt + exact ⟨mem_codeSucc_of_checks tm x S a b P hne hq hin (fun i => (hwork i).1) hout.1 + hclampIn hclampW hclampO hstate hhead + (fun i => ⟨(hwork i).2.2, (hwork i).2.1⟩) ⟨hout.2.2, hout.2.1⟩, hhead⟩ + +/-- The columns the direction check reads: the parameter block, then the direction register. -/ +def dirCols {jj : ℕ} (par dr : Fin (jj + 1)) : Fin 2 → Fin (jj + 1) := + fun c => if c.val = 0 then par else dr + +/-- The counter check of a walk step: the counter either stays as it was or advances by one. +Only the second step of a pair advances it, so that the counter names the loop's iteration. -/ +noncomputable def counterStepScanner {jj : ℕ} (cntOld cntNew : Fin (jj + 1)) (wc : ℕ) + (advance : Bool) : Scanner jj := + if advance then (Scanner.plusOne jj cntOld cntNew).upTo wc + else (Scanner.eq jj cntOld cntNew).upTo wc + +theorem rightOnly_plusOne (jj : ℕ) (a b : Fin (jj + 1)) : + Scanner.RightOnly (Scanner.plusOne jj a b) := fun _ _ => rfl + +/-- **The counter check decides what it should.** -/ +theorem counterStepScanner_decides {jj : ℕ} (cntOld cntNew : Fin (jj + 1)) (wc len : ℕ) + (advance : Bool) (hw : wc ≤ len) (cols : ℕ → Fin (jj + 1) → Γ) (u v : ℕ) + (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hold : HoldsBits cols 0 cntOld (bitsOfLenLE wc u)) + (hnew : HoldsBits cols 0 cntNew (bitsOfLenLE wc v)) + (hverdict : (counterStepScanner cntOld cntNew wc advance).emit + ((counterStepScanner cntOld cntNew wc advance).run cols len) = true) : + if advance then v = u + 1 else u = v := by + rw [counterStepScanner] at hverdict + cases advance with + | true => + rw [if_pos rfl, Scanner.upTo_emit_run _ (rightOnly_plusOne jj cntOld cntNew) wc len hw] + at hverdict + exact (plusOne_of_holds cols cntOld cntNew wc u v hu hv hold hnew).mp hverdict + | false => + rw [if_neg (by simp), Scanner.upTo_emit_run _ (Scanner.rightOnly_eq jj cntOld cntNew) wc len + hw] at hverdict + show u = v + have hbits := (eq_run_of_holds cols cntOld cntNew (bitsOfLenLE wc u) (bitsOfLenLE wc v) + (by rw [bitsOfLenLE_length, bitsOfLenLE_length]) hold hnew).mp + (by rw [bitsOfLenLE_length]; exact hverdict) + have := congrArg binValLE hbits + rwa [binValLE_bitsOfLenLE wc u hu, binValLE_bitsOfLenLE wc v hv] at this + +/-- An encoding of directions in two guessed cells that `TM.inMoveTM` can read back. A guessed +cell holds a bit, so one cell cannot name one of three directions; the first cell says whether to +move at all and the second which way. -/ +structure DirCodec where + /-- Whether the direction moves the head. -/ + encMove : Dir3 → Γ + /-- Which way it moves, when it does. -/ + enc : Dir3 → Γ + /-- And how to read the pair back. -/ + dec : Γ → Γ → Dir3 + /-- Reading back what was written gives the direction again. -/ + dec_enc : ∀ d, dec (encMove d) (enc d) = d + /-- Both cells hold bits, so a guess can write them. -/ + encMove_bit : ∀ d, encMove d = Γ.zero ∨ encMove d = Γ.one + /-- And likewise the direction cell. -/ + enc_bit : ∀ d, enc d = Γ.zero ∨ enc d = Γ.one + +/-- The direction codec: the first cell is `1` exactly when the head moves, the second `1` for +right and `0` for left. -/ +def dirCodec : DirCodec where + encMove d := match d with + | .stay => Γ.zero + | _ => Γ.one + enc d := match d with + | .left => Γ.zero + | _ => Γ.one + dec m g := if m = Γ.one then (if g = Γ.one then .right else .left) else .stay + dec_enc d := by cases d <;> rfl + encMove_bit d := by cases d <;> simp + enc_bit d := by cases d <;> simp + +/-- **A bit-valued cell reads back as itself.** -/ +theorem ofBool_decide_one {g : Γ} (h : g = Γ.zero ∨ g = Γ.one) : + Γ.ofBool (decide (g = Γ.one)) = g := by + rcases h with h | h <;> rw [h] <;> rfl + +/-- The direction that takes `max h 1` to `max (movedIdx d h) 1`. -/ +def adjustedDir (d : Dir3) (h : ℕ) : Dir3 := + if h = 0 then Dir3.stay else if movedIdx d h = 0 then Dir3.stay else d + +/-- The scan that pins the direction register, conditional on both head fields being off the +marker. -/ +noncomputable def dirCheckScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par mv dr hdOld hdNew : Fin (jj + 1)) (dc : DirCodec) : Scanner jj := + Scanner.or + (Scanner.all 3 (fun p => if p.val = 0 then + Scanner.or (headZeroScanner tm nn S hdOld) (headZeroScanner tm nn S hdNew) + else if p.val = 1 then (Scanner.isConst jj mv (dc.encMove Dir3.stay)).upTo 1 + else (Scanner.isConst jj dr (dc.enc Dir3.stay)).upTo 1)) + (Scanner.all 4 (fun p => if p.val = 0 then headNonZeroScanner tm nn S hdOld + else if p.val = 1 then headNonZeroScanner tm nn S hdNew + else if p.val = 2 then + ((dirScanner tm dc.encMove).comap (dirCols par mv)).upTo (succParamsCodec tm.Q kk).width + else ((dirScanner tm dc.enc).comap (dirCols par dr)).upTo (succParamsCodec tm.Q kk).width)) + +/-- **The direction check pins the register to the direction the machine must actually take.** -/ +theorem dirCheckScanner_decides {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr hdOld hdNew : Fin (jj + 1)) (dc : DirCodec) + (P : SuccParams tm.Q kk) (a b : Code tm.Q kk x.length S) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (hhdOld : HoldsBits cols (succParamsCodec tm.Q kk).width hdOld + ((finCodec (x.length + S + 2)).enc a.2.1)) + (hhdNew : HoldsBits cols (succParamsCodec tm.Q kk).width hdNew + ((finCodec (x.length + S + 2)).enc b.2.1)) + (hmove : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val) + (hv : (dirCheckScanner tm x.length S par mv dr hdOld hdNew dc).emit + ((dirCheckScanner tm x.length S par mv dr hdOld hdNew dc).run cols + (walkScanLen tm x.length S)) = true) : + cols 1 mv = dc.encMove (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val) ∧ + cols 1 dr = dc.enc (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val) := by + have hzO := headZeroScanner_decides tm x.length S hdOld cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhdOld + have hzN := headZeroScanner_decides tm x.length S hdNew cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) b.2.1 hhdNew + have hnO := headNonZeroScanner_decides tm x.length S hdOld cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhdOld + have hnN := headNonZeroScanner_decides tm x.length S hdNew cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) b.2.1 hhdNew + rw [dirCheckScanner, Scanner.or_emit_run] at hv + have hlen2 : 1 ≤ walkScanLen tm x.length S := by + have := two_le_walkScanLen tm x.length S + omega + rcases hv with h | h + · rw [Scanner.all_emit_run] at h + have h0 := h ⟨0, by omega⟩ + have h1 := h ⟨1, by omega⟩ + have h2 := h ⟨2, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0), Scanner.or_emit_run] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0)), if_pos (rfl : (1 : ℕ) = 1)] at h1 + rw [if_neg (by exact (by omega : (2 : ℕ) ≠ 0)), + if_neg (by exact (by omega : (2 : ℕ) ≠ 1))] at h2 + have hstay : adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val = Dir3.stay := by + rw [adjustedDir] + rcases h0 with hz | hz + · rw [if_pos (hzO.mp hz)] + · by_cases ha : a.2.1.val = 0 + · rw [if_pos ha] + · rw [if_neg ha, if_pos (by rw [← hmove]; exact hzN.mp hz)] + rw [hstay] + exact ⟨(Scanner.isConst_cell jj mv (dc.encMove Dir3.stay) cols + (walkScanLen tm x.length S) hlen2).mp h1, + (Scanner.isConst_cell jj dr (dc.enc Dir3.stay) cols + (walkScanLen tm x.length S) hlen2).mp h2⟩ + · rw [Scanner.all_emit_run] at h + have h0 := h ⟨0, by omega⟩ + have h1 := h ⟨1, by omega⟩ + have h2 := h ⟨2, by omega⟩ + have h3 := h ⟨3, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0)] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0)), if_pos (rfl : (1 : ℕ) = 1)] at h1 + rw [if_neg (by exact (by omega : (2 : ℕ) ≠ 0)), + if_neg (by exact (by omega : (2 : ℕ) ≠ 1)), if_pos (rfl : (2 : ℕ) = 2), + Scanner.upTo_emit_run _ (Scanner.rightOnly_comap (fun _ _ => rfl) (dirCols par mv)) + _ _ (succParamsCodec_width_le_walkScanLen tm x.length S), + Scanner.comap_emit, Scanner.comap_run] at h2 + rw [if_neg (by exact (by omega : (3 : ℕ) ≠ 0)), + if_neg (by exact (by omega : (3 : ℕ) ≠ 1)), + if_neg (by exact (by omega : (3 : ℕ) ≠ 2)), + Scanner.upTo_emit_run _ (Scanner.rightOnly_comap (fun _ _ => rfl) (dirCols par dr)) + _ _ (succParamsCodec_width_le_walkScanLen tm x.length S), + Scanner.comap_emit, Scanner.comap_run] at h3 + have hdir : adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val = (succTrans tm P).2.2.2.1 := by + rw [adjustedDir, if_neg (hnO.mp h0), if_neg (by rw [← hmove]; exact hnN.mp h1)] + rw [hdir] + exact ⟨(dirScanner_decides tm dc.encMove (fun q c => cols q (dirCols par mv c)) P hpar).mp h2, + (dirScanner_decides tm dc.enc (fun q c => cols q (dirCols par dr c)) P hpar).mp h3⟩ + +/-- **The direction check accepts the direction the machine must take.** -/ +theorem dirCheckScanner_accepts {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr hdOld hdNew : Fin (jj + 1)) (dc : DirCodec) + (P : SuccParams tm.Q kk) (a b : Code tm.Q kk x.length S) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (hhdOld : HoldsBits cols (succParamsCodec tm.Q kk).width hdOld + ((finCodec (x.length + S + 2)).enc a.2.1)) + (hhdNew : HoldsBits cols (succParamsCodec tm.Q kk).width hdNew + ((finCodec (x.length + S + 2)).enc b.2.1)) + (hmove : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val) + (hmv : cols 1 mv = dc.encMove (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val)) + (hdr : cols 1 dr = dc.enc (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val)) : + (dirCheckScanner tm x.length S par mv dr hdOld hdNew dc).emit + ((dirCheckScanner tm x.length S par mv dr hdOld hdNew dc).run cols + (walkScanLen tm x.length S)) = true := by + have hlen1 : 1 ≤ walkScanLen tm x.length S := one_le_walkScanLen tm x.length S + have hzO := headZeroScanner_decides tm x.length S hdOld cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhdOld + have hzN := headZeroScanner_decides tm x.length S hdNew cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) b.2.1 hhdNew + have hnO := headNonZeroScanner_decides tm x.length S hdOld cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) a.2.1 hhdOld + have hnN := headNonZeroScanner_decides tm x.length S hdNew cols (walkScanLen tm x.length S) + (headField_le_walkScanLen tm x.length S) b.2.1 hhdNew + rw [dirCheckScanner, Scanner.or_emit_run] + by_cases hz : a.2.1.val = 0 ∨ b.2.1.val = 0 + · have hstay : adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val = Dir3.stay := by + rw [adjustedDir] + rcases hz with hz | hz + · rw [if_pos hz] + · by_cases ha : a.2.1.val = 0 + · rw [if_pos ha] + · rw [if_neg ha, if_pos (by rw [← hmove]; exact hz)] + refine Or.inl ?_ + rw [Scanner.all_emit_run] + intro p + by_cases hp0 : p.val = 0 + · rw [if_pos hp0, Scanner.or_emit_run] + rcases hz with hz | hz + · exact Or.inl (hzO.mpr hz) + · exact Or.inr (hzN.mpr hz) + · rw [if_neg hp0] + by_cases hp1 : p.val = 1 + · rw [if_pos hp1] + exact (Scanner.isConst_cell jj mv (dc.encMove Dir3.stay) cols + (walkScanLen tm x.length S) hlen1).mpr (by rw [hmv, hstay]) + · rw [if_neg hp1] + exact (Scanner.isConst_cell jj dr (dc.enc Dir3.stay) cols + (walkScanLen tm x.length S) hlen1).mpr (by rw [hdr, hstay]) + · have hzA : a.2.1.val ≠ 0 := fun hc => hz (Or.inl hc) + have hzB : b.2.1.val ≠ 0 := fun hc => hz (Or.inr hc) + have hdir : adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val = (succTrans tm P).2.2.2.1 := by + rw [adjustedDir, if_neg hzA, if_neg (by rw [← hmove]; exact hzB)] + refine Or.inr ?_ + rw [Scanner.all_emit_run] + intro p + by_cases hp0 : p.val = 0 + · rw [if_pos hp0] + exact hnO.mpr hzA + · rw [if_neg hp0] + by_cases hp1 : p.val = 1 + · rw [if_pos hp1] + exact hnN.mpr hzB + · rw [if_neg hp1] + by_cases hp2 : p.val = 2 + · rw [if_pos hp2, Scanner.upTo_emit_run _ + (Scanner.rightOnly_comap (fun _ _ => rfl) (dirCols par mv)) + _ _ (succParamsCodec_width_le_walkScanLen tm x.length S), + Scanner.comap_emit, Scanner.comap_run] + refine (dirScanner_decides tm dc.encMove (fun q c => cols q (dirCols par mv c)) P + hpar).mpr ?_ + show cols 1 mv = _ + rw [hmv, hdir] + · rw [if_neg hp2, Scanner.upTo_emit_run _ + (Scanner.rightOnly_comap (fun _ _ => rfl) (dirCols par dr)) + _ _ (succParamsCodec_width_le_walkScanLen tm x.length S), + Scanner.comap_emit, Scanner.comap_run] + refine (dirScanner_decides tm dc.enc (fun q c => cols q (dirCols par dr c)) P + hpar).mpr ?_ + show cols 1 dr = _ + rw [hdr, hdir] + +/-- The code half of a walk step's scan. -/ +noncomputable def walkCodeScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par mv dr res : Fin (jj + 1)) (dc : DirCodec) (j j' : ℕ → Fin (jj + 1)) : Scanner jj := + Scanner.or + (Scanner.all 3 (fun p => if p.val = 0 then eqScanner tm nn S j j' + else if p.val = 1 then (Scanner.isConst jj mv (dc.encMove Dir3.stay)).upTo 1 + else (Scanner.isConst jj dr (dc.enc Dir3.stay)).upTo 1)) + (Scanner.all 3 (fun p => if p.val = 0 then + succScanner tm nn S par (codeRegsOf j) (codeRegsOf j') + else if p.val = 1 then + dirCheckScanner tm nn S par mv dr (codeRegsOf (kk := kk) j).hd + (codeRegsOf (kk := kk) j').hd dc + else inSymScanner tm nn S par (codeRegsOf (kk := kk) j).hd res)) + + +/-- **The counter check accepts the move it is meant to.** -/ +theorem counterStepScanner_accepts {jj : ℕ} (cntOld cntNew : Fin (jj + 1)) (wc len : ℕ) + (advance : Bool) (hw : wc ≤ len) (cols : ℕ → Fin (jj + 1) → Γ) (u v : ℕ) + (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hold : HoldsBits cols 0 cntOld (bitsOfLenLE wc u)) + (hnew : HoldsBits cols 0 cntNew (bitsOfLenLE wc v)) + (hmove : if advance then v = u + 1 else u = v) : + (counterStepScanner cntOld cntNew wc advance).emit + ((counterStepScanner cntOld cntNew wc advance).run cols len) = true := by + rw [counterStepScanner] + cases advance with + | true => + rw [if_pos rfl, Scanner.upTo_emit_run _ (rightOnly_plusOne jj cntOld cntNew) wc len hw] + exact (plusOne_of_holds cols cntOld cntNew wc u v hu hv hold hnew).mpr (by + simpa using hmove) + | false => + rw [if_neg (by simp), Scanner.upTo_emit_run _ (Scanner.rightOnly_eq jj cntOld cntNew) wc len + hw] + have huv : u = v := by simpa using hmove + subst huv + have h := (eq_run_of_holds cols cntOld cntNew (bitsOfLenLE wc u) (bitsOfLenLE wc u) + rfl hold hnew).mpr rfl + rwa [bitsOfLenLE_length] at h + +/-- **The code half of a walk step's scan decides a walk step, and says how the input head +moves.** The symbol under the simulated input head is not scanned but read from the machine's own +input tape by `TM.inMatchTM`, whose verdict the scan requires on register `res`; `hg` is the +invariant that the machine's input head sits where the simulated one does. -/ +theorem walkCodeScanner_decides {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res : Fin (jj + 1)) (dc : DirCodec) + (j j' : ℕ → Fin (jj + 1)) (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) (g : Γ) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S b p)) + (hne : a.1 ≠ tm.qhalt) + (hres : cols 1 res = Γ.ofBool (TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par))) + (hg : a.2.1.val ≠ 0 → g = inSymOf tm x S a) + (hv : (walkCodeScanner tm x.length S par mv dr res dc j j').emit + ((walkCodeScanner tm x.length S par mv dr res dc j j').run cols + (walkScanLen tm x.length S)) = true) : + (b = a ∧ cols 1 mv = dc.encMove Dir3.stay ∧ cols 1 dr = dc.enc Dir3.stay) ∨ + (b ∈ NTM.codeSucc tm x S a ∧ + b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ∧ + cols 1 mv = dc.encMove (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val) ∧ + cols 1 dr = dc.enc (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val)) := by + have hendW : ∀ i : Fin kk, markOf (fun q c => + cols q (windowCols par (codeRegsOf (kk := kk) j) (codeRegsOf (kk := kk) j') i c)) + (succParamsCodec tm.Q kk).width 1 (S + 1) = false := by + intro i + exact markOf_end tm x S a (i.val + 2) (S + 1) (by omega) + (by + rw [codeBlock_wk, (tapeCodec (S + 1)).enc_length] + show (S + 1) * 3 = 3 * (S + 1) + omega) + cols (j (i.val + 2)) + (ha (i.val + 2) (by omega)) + have hendO : markOf (fun q c => cols q + (outputCols par (codeRegsOf (kk := kk) j) (codeRegsOf (kk := kk) j') c)) + (succParamsCodec tm.Q kk).width 1 (S + 2) = false := + markOf_end tm x S a (kk + 2) (S + 2) (by omega) + (by + rw [codeBlock_ot, (tapeCodec (S + 2)).enc_length] + show (S + 2) * 3 = 3 * (S + 2) + omega) cols (j (kk + 2)) + (ha (kk + 2) (by omega)) + rw [walkCodeScanner, Scanner.or_emit_run] at hv + rcases hv with h | h + · rw [Scanner.all_emit_run] at h + have h0 := h ⟨0, by omega⟩ + have h1 := h ⟨1, by omega⟩ + have h2 := h ⟨2, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0)] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0)), if_pos (rfl : (1 : ℕ) = 1)] at h1 + rw [if_neg (by exact (by omega : (2 : ℕ) ≠ 0)), + if_neg (by exact (by omega : (2 : ℕ) ≠ 1))] at h2 + exact Or.inl ⟨(eqScanner_decides tm x S cols j j' a b ha hb h0).symm, + (Scanner.isConst_cell jj mv (dc.encMove Dir3.stay) cols (walkScanLen tm x.length S) + (one_le_walkScanLen tm x.length S)).mp h1, + (Scanner.isConst_cell jj dr (dc.enc Dir3.stay) cols (walkScanLen tm x.length S) + (one_le_walkScanLen tm x.length S)).mp h2⟩ + · rw [Scanner.all_emit_run] at h + have h0 := h ⟨0, by omega⟩ + have h1 := h ⟨1, by omega⟩ + have h2 := h ⟨2, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0)] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0)), if_pos (rfl : (1 : ℕ) = 1)] at h1 + rw [if_neg (by exact (by omega : (2 : ℕ) ≠ 0)), + if_neg (by exact (by omega : (2 : ℕ) ≠ 1))] at h2 + have hin : P.inSym = inSymOf tm x S a := + inSymScanner_decides tm x S cols par (codeRegsOf j).hd res P a g hpar + (holdsCodeScan_of_blocks tm x S cols j a ha).2.1 hres hg h2 + obtain ⟨hsucc, hmove⟩ := succScanner_decides tm x S cols par (codeRegsOf j) (codeRegsOf j') + a b P hpar (holdsCodeScan_of_blocks tm x S cols j a ha) + (holdsCodeScan_of_blocks tm x S cols j' b hb) hne hendW hendO hin h0 + obtain ⟨hmvc, hdrc⟩ := dirCheckScanner_decides tm x S cols par mv dr (codeRegsOf j).hd + (codeRegsOf j').hd dc P a b hpar (holdsCodeScan_of_blocks tm x S cols j a ha).2.1 + (holdsCodeScan_of_blocks tm x S cols j' b hb).2.1 hmove h1 + exact Or.inr ⟨hsucc, hmove, hmvc, hdrc⟩ + +/-- **The walk-step scan accepts a step that stays put.** -/ +theorem walkCodeScanner_accepts_stay {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res : Fin (jj + 1)) (dc : DirCodec) + (j j' : ℕ → Fin (jj + 1)) (a : Code tm.Q kk x.length S) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S a p)) + (hmv : cols 1 mv = dc.encMove Dir3.stay) (hdr : cols 1 dr = dc.enc Dir3.stay) : + (walkCodeScanner tm x.length S par mv dr res dc j j').emit + ((walkCodeScanner tm x.length S par mv dr res dc j j').run cols + (walkScanLen tm x.length S)) = true := by + rw [walkCodeScanner, Scanner.or_emit_run] + refine Or.inl ?_ + rw [Scanner.all_emit_run] + intro p + by_cases hp : p.val = 0 + · rw [if_pos hp] + exact eqScanner_accepts tm x S cols j j' a ha hb + · rw [if_neg hp] + by_cases hp1 : p.val = 1 + · rw [if_pos hp1] + exact (Scanner.isConst_cell jj mv (dc.encMove Dir3.stay) cols (walkScanLen tm x.length S) + (one_le_walkScanLen tm x.length S)).mpr hmv + · rw [if_neg hp1] + exact (Scanner.isConst_cell jj dr (dc.enc Dir3.stay) cols (walkScanLen tm x.length S) + (one_le_walkScanLen tm x.length S)).mpr hdr + +/-- **The walk-step scan accepts a step that advances.** -/ +theorem walkCodeScanner_accepts_succ {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res : Fin (jj + 1)) (dc : DirCodec) + (j j' : ℕ → Fin (jj + 1)) (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S b p)) + (hq : a.1 = P.q) (hstate : b.1 = succState tm P) + (hwsym : ∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) + (hosym : a.2.2.2.2 a.2.2.2.1 = P.oSym) + (hhead : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val) + (hwork : ∀ i, (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val ∧ + ∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) + (hout : b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) + (hleft : (succTrans tm P).2.2.2.1 = Dir3.left → 0 < a.2.1.val) + (hdr : (dirCheckScanner tm x.length S par mv dr (codeRegsOf (kk := kk) j).hd + (codeRegsOf (kk := kk) j').hd dc).emit + ((dirCheckScanner tm x.length S par mv dr (codeRegsOf (kk := kk) j).hd + (codeRegsOf (kk := kk) j').hd dc).run cols (walkScanLen tm x.length S)) = true) + (hres : (inSymScanner tm x.length S par (codeRegsOf (kk := kk) j).hd res).emit + ((inSymScanner tm x.length S par (codeRegsOf (kk := kk) j).hd res).run cols + (walkScanLen tm x.length S)) = true) : + (walkCodeScanner tm x.length S par mv dr res dc j j').emit + ((walkCodeScanner tm x.length S par mv dr res dc j j').run cols + (walkScanLen tm x.length S)) = true := by + have hendW : ∀ i : Fin kk, markOf (fun q c => + cols q (windowCols par (codeRegsOf (kk := kk) j) (codeRegsOf (kk := kk) j') i c)) + (succParamsCodec tm.Q kk).width 1 (S + 1) = false := by + intro i + exact markOf_end tm x S a (i.val + 2) (S + 1) (by omega) + (by + rw [codeBlock_wk, (tapeCodec (S + 1)).enc_length] + show (S + 1) * 3 = 3 * (S + 1) + omega) + cols (j (i.val + 2)) (ha (i.val + 2) (by omega)) + have hendO : markOf (fun q c => cols q + (outputCols par (codeRegsOf (kk := kk) j) (codeRegsOf (kk := kk) j') c)) + (succParamsCodec tm.Q kk).width 1 (S + 2) = false := + markOf_end tm x S a (kk + 2) (S + 2) (by omega) + (by + rw [codeBlock_ot, (tapeCodec (S + 2)).enc_length] + show (S + 2) * 3 = 3 * (S + 2) + omega) cols (j (kk + 2)) (ha (kk + 2) (by omega)) + rw [walkCodeScanner, Scanner.or_emit_run] + refine Or.inr ?_ + rw [Scanner.all_emit_run] + intro p + by_cases hp0 : p.val = 0 + · rw [if_pos hp0] + exact succScanner_accepts tm x S cols par (codeRegsOf j) (codeRegsOf j') a b P hpar + (holdsCodeScan_of_blocks tm x S cols j a ha) (holdsCodeScan_of_blocks tm x S cols j' b hb) + hendW hendO hq hstate hwsym hosym hhead hwork hout hleft + · rw [if_neg hp0] + by_cases hp1 : p.val = 1 + · rw [if_pos hp1] + exact hdr + · rw [if_neg hp1] + exact hres + +/-- **One walk step, as a single scan.** Either the guessed code repeats the old one and the +input head is told to stay, or it is a successor and the input head is told to move the way the +transition does. The direction is part of the step because the machine's own input head tracks the +simulated one — `TM.inMoveTM` reads exactly the cell this check pins. -/ +noncomputable def walkStepScanner {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (j j' : ℕ → Fin (jj + 1)) : Scanner jj := + Scanner.all 2 (fun p => if p.val = 0 then walkCodeScanner tm nn S par mv dr res dc j j' + else counterStepScanner cntOld cntNew wc advance) + +/-- **The walk-step scan decides a step of the walk, how the input head moves, and what the +counter does.** -/ +theorem walkStepScanner_decides {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) + (advance : Bool) (dc : DirCodec) (j j' : ℕ → Fin (jj + 1)) + (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) (g : Γ) (u v : ℕ) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S b p)) + (hne : a.1 ≠ tm.qhalt) + (hres : cols 1 res = Γ.ofBool (TM.inMatchVerdict gammaBits g (cols 1 par) (cols 2 par))) + (hg : a.2.1.val ≠ 0 → g = inSymOf tm x S a) + (hwc : wc ≤ walkScanLen tm x.length S) (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hcntOld : HoldsBits cols 0 cntOld (bitsOfLenLE wc u)) + (hcntNew : HoldsBits cols 0 cntNew (bitsOfLenLE wc v)) + (hverdict : (walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').emit + ((walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').run cols + (walkScanLen tm x.length S)) = true) : + ((b = a ∧ cols 1 mv = dc.encMove Dir3.stay ∧ cols 1 dr = dc.enc Dir3.stay) ∨ + (b ∈ NTM.codeSucc tm x S a ∧ + b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ∧ + cols 1 mv = dc.encMove (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val) ∧ + cols 1 dr = dc.enc (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val))) ∧ + (if advance then v = u + 1 else u = v) := by + rw [walkStepScanner, Scanner.all_emit_run] at hverdict + have h0 := hverdict ⟨0, by omega⟩ + have h1 := hverdict ⟨1, by omega⟩ + rw [if_pos (rfl : (0 : ℕ) = 0)] at h0 + rw [if_neg (by exact (by omega : (1 : ℕ) ≠ 0))] at h1 + exact ⟨walkCodeScanner_decides tm x S cols par mv dr res dc j j' a b P g hpar ha hb hne hres hg + h0, + counterStepScanner_decides cntOld cntNew wc (walkScanLen tm x.length S) advance hwc cols u v + hu hv hcntOld hcntNew h1⟩ + +/-- **The walk-step scan accepts a genuine step.** -/ +theorem walkStepScanner_accepts {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) + (advance : Bool) (dc : DirCodec) (j j' : ℕ → Fin (jj + 1)) + (hwc : wc ≤ walkScanLen tm x.length S) (u v : ℕ) (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hold : HoldsBits cols 0 cntOld (bitsOfLenLE wc u)) + (hnew : HoldsBits cols 0 cntNew (bitsOfLenLE wc v)) + (hmove : if advance then v = u + 1 else u = v) + (hcode : (walkCodeScanner tm x.length S par mv dr res dc j j').emit + ((walkCodeScanner tm x.length S par mv dr res dc j j').run cols + (walkScanLen tm x.length S)) = true) : + (walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').emit + ((walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').run cols + (walkScanLen tm x.length S)) = true := by + rw [walkStepScanner, Scanner.all_emit_run] + intro p + by_cases hp : p.val = 0 + · rw [if_pos hp] + exact hcode + · rw [if_neg hp] + exact counterStepScanner_accepts cntOld cntNew wc (walkScanLen tm x.length S) advance hwc + cols u v hu hv hold hnew hmove + +/-! ## The check phase + +The input check and the scan, in sequence: the check leaves its verdict on a register, and the +scan — which reads every register — takes that verdict into account along with everything else. -/ + +/-- The registers after the input check: only the verdict register changes. -/ +noncomputable def checkedCells {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) (par res : Fin (jj + 1)) + (g : Γ) : Fin (jj + 1) → ℕ → Γ := + Function.update cells res + (Function.update (cells res) 1 + (Γ.ofBool (TM.inMatchVerdict gammaBits g (cells par 1) (cells par 2)))) + +@[simp] theorem checkedCells_ne {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) + (par res : Fin (jj + 1)) (g : Γ) (i : Fin (jj + 1)) (hi : i ≠ res) : + checkedCells cells par res g i = cells i := by + rw [checkedCells, Function.update_of_ne hi] + +@[simp] theorem checkedCells_res {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) + (par res : Fin (jj + 1)) (g : Γ) : + checkedCells cells par res g res 1 + = Γ.ofBool (TM.inMatchVerdict gammaBits g (cells par 1) (cells par 2)) := by + rw [checkedCells, Function.update_self, Function.update_self] + +/-- **The input check leaves the scan well formed.** It writes one bit on the verdict register, +which is never the ruler. -/ +theorem scanTape_checked {jj : ℕ} {cells : Fin (jj + 1) → ℕ → Γ} {len : ℕ} + (h : TM.ScanTape cells len) (par res : Fin (jj + 1)) (hres : res ≠ 0) (g : Γ) : + TM.ScanTape (checkedCells cells par res g) len where + start i := by + by_cases hi : i = res + · subst hi + rw [checkedCells, Function.update_self, Function.update_of_ne (by omega)] + exact h.start i + · rw [checkedCells_ne cells par res g i hi] + exact h.start i + ne_start i q hq := by + by_cases hi : i = res + · subst hi + by_cases hq1 : q = 1 + · subst hq1 + rw [checkedCells_res] + cases TM.inMatchVerdict gammaBits g (cells par 1) (cells par 2) <;> + exact fun hc => Γ.noConfusion hc + · rw [checkedCells, Function.update_self, Function.update_of_ne hq1] + exact h.ne_start i q hq + · rw [checkedCells_ne cells par res g i hi] + exact h.ne_start i q hq + ne_blank q h1 h2 := by + rw [checkedCells_ne cells par res g 0 (fun hc => hres hc.symm)] + exact h.ne_blank q h1 h2 + blank := by + rw [checkedCells_ne cells par res g 0 (fun hc => hres hc.symm)] + exact h.blank + +/-- **A register other than the verdict's survives the input check.** -/ +theorem checked_cell {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) (par res : Fin (jj + 1)) (g : Γ) + (r : Fin (jj + 1)) (hr : r ≠ res) (q : ℕ) : checkedCells cells par res g r q = cells r q := by + rw [checkedCells_ne cells par res g r hr] + +/-- **And so does what it holds.** -/ +theorem holdsBits_checked {jj : ℕ} {cells : Fin (jj + 1) → ℕ → Γ} {par res : Fin (jj + 1)} + {g : Γ} {r : Fin (jj + 1)} (hr : r ≠ res) {off : ℕ} {bits : List Bool} + (h : HoldsBits (fun q i => cells i q) off r bits) : + HoldsBits (fun q i => checkedCells cells par res g i q) off r bits := by + intro q hq + show checkedCells cells par res g r _ = _ + rw [checked_cell cells par res g r hr] + exact h q hq + +/-- **The check phase's contract.** -/ +theorem checkPhase_hoareTime {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) + (cells : Fin (jj + 1) → ℕ → Γ) (len : ℕ) (inp₀ out₀ resT : Tape) + (hok : TM.ScanOk inp₀ resT out₀) (ht : TM.ScanTape cells len) + (hresSI : resT.StartInvariant) (hresH : 1 ≤ resT.head) + (hpr : par ≠ res) + (ht' : TM.ScanTape (checkedCells cells par res inp₀.read) len) : + (TM.seqTM (TM.inMatchTM gammaBits par.castSucc res.castSucc) + (TM.twoPassTM (walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew))).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) resT) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, checkedCells cells par res inp₀.read i⟩ : Tape)) + (resT.write (Γ.ofBool ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).emit + ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).run + (TM.scanCol (checkedCells cells par res inp₀.read)) len))))) + (2 + 1 + (2 * len + 3)) := by + classical + set W₀ : Fin (jj + 2) → Tape := Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) resT with hW₀ + have hWcast : ∀ i : Fin (jj + 1), W₀ i.castSucc = (⟨1, cells i⟩ : Tape) := by + intro i + rw [hW₀, Fin.snoc_castSucc] + have hWlast : W₀ (Fin.last (jj + 1)) = resT := by rw [hW₀, Fin.snoc_last] + have hinv : ∀ i, (W₀ i).StartInvariant := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hWlast]; exact hresSI + · intro q + rw [hWcast q] + exact ⟨ht.start q, fun p hp => ht.ne_start q p hp⟩ + have hh : ∀ i, 1 ≤ (W₀ i).head := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hWlast]; exact hresH + · intro q + rw [hWcast q] + have hmatch := TM.inMatchTM_hoareTime gammaBits par.castSucc res.castSucc + (by + intro hc + exact hpr (Fin.castSucc_injective _ hc)) + inp₀ out₀ W₀ hinv hh hok.inp hok.out (by rw [hWcast par]) (by rw [hWcast res]) + have hmatch' : (TM.inMatchTM gammaBits par.castSucc res.castSucc).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ i, i ≠ res.castSucc → work i = W₀ i) ∧ + work res.castSucc = TM.inMatchRes gammaBits inp₀.read ((W₀ par.castSucc).cells 1) + ((W₀ par.castSucc).cells 2) (W₀ res.castSucc)) 2 := + hmatch.consequence (fun _ _ _ h => ⟨h.1, h.2.2, h.2.1⟩) (fun _ _ _ h => h) le_rfl + have hmid : ∀ (inp : Tape) (work : Fin (jj + 2) → Tape) (out : Tape), + (inp = inp₀ ∧ out = out₀ ∧ + (∀ i, i ≠ res.castSucc → work i = W₀ i) ∧ + work res.castSucc = TM.inMatchRes gammaBits inp₀.read ((W₀ par.castSucc).cells 1) + ((W₀ par.castSucc).cells 2) (W₀ res.castSucc)) → + (TM.transitionInput inp = inp₀ ∧ TM.transitionTape out = out₀ ∧ + (fun i => TM.transitionTape (work i)) + = Fin.snoc (fun i => (⟨1, checkedCells cells par res inp₀.read i⟩ : Tape)) resT) := by + rintro inp work out ⟨rfl, rfl, hother, hres⟩ + have hnew : ∀ i, work i = (Fin.snoc + (fun i => (⟨1, checkedCells cells par res inp.read i⟩ : Tape)) resT + : Fin (jj + 2) → Tape) i := by + intro i + refine Fin.lastCases ?_ ?_ i + · have hne : (Fin.last (jj + 1) : Fin (jj + 2)) ≠ res.castSucc := by + intro hc + have hv := congrArg Fin.val hc + have h1 : (Fin.last (jj + 1) : Fin (jj + 2)).val = jj + 1 := rfl + have h2 : (res.castSucc : Fin (jj + 2)).val = res.val := rfl + have := res.isLt + omega + rw [hother _ hne, hWlast, Fin.snoc_last] + · intro q + by_cases hq : q = res + · subst hq + rw [hres, hWcast q, hWcast par, Fin.snoc_castSucc, TM.inMatchRes, checkedCells, + Function.update_self] + · rw [hother _ (fun hc => hq (Fin.castSucc_injective _ hc)), hWcast q, + Fin.snoc_castSucc, checkedCells, Function.update_of_ne hq] + refine ⟨TM.transitionInput_eq_self hok.inp, TM.transitionTape_eq_self hok.out, ?_⟩ + funext i + rw [hnew i] + refine TM.transitionTape_eq_self ?_ + refine Fin.lastCases ?_ ?_ i + · rw [Fin.snoc_last] + exact hresSI.read_ne_start hresH + · intro q + rw [Fin.snoc_castSucc] + exact fun hc => ht'.ne_start q 1 le_rfl hc + exact TM.seqTM_hoareTime _ _ hmatch' hmid + (TM.twoPassTM_hoareTime (walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew) + (checkedCells cells par res inp₀.read) len inp₀ out₀ resT hok ht') + +/-- The guess-free half of a walk step: check the guessed input symbol against the machine's own +input tape, run the walk-step scan, and move the input head by the direction the scan pinned. The +verdict is left on the result register, where the step's last stage conjoins it into the +accumulator. -/ +noncomputable def walkCheckTM {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) : TM (jj + 2) := + TM.seqTM + (TM.seqTM (TM.inMatchTM gammaBits par.castSucc res.castSucc) + (TM.twoPassTM (walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew))) + (TM.inMoveTM dc.dec mv.castSucc dr.castSucc) + +/-- **The guess-free part of a walk step.** The input check, the scan, and the move of the input +head. -/ +theorem checkMove_hoareTime {kk jj : ℕ} (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (cells : Fin (jj + 1) → ℕ → Γ) (len : ℕ) + (inp₀ out₀ resT : Tape) (hok : TM.ScanOk inp₀ resT out₀) (ht : TM.ScanTape cells len) + (hresSI : resT.StartInvariant) (hresH : 1 ≤ resT.head) (hpr : par ≠ res) + (ht' : TM.ScanTape (checkedCells cells par res inp₀.read) len) : + (walkCheckTM tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) resT) + (fun inp work out => + inp = inp₀.move (dc.dec (checkedCells cells par res inp₀.read mv 1) + (checkedCells cells par res inp₀.read dr 1)) ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, checkedCells cells par res inp₀.read i⟩ : Tape)) + (resT.write (Γ.ofBool ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).emit + ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).run + (TM.scanCol (checkedCells cells par res inp₀.read)) len))))) + (2 + 1 + (2 * len + 3) + 1 + 1) := by + classical + set v : Bool := (walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).emit + ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).run + (TM.scanCol (checkedCells cells par res inp₀.read)) len) with hvdef + set W₁ : Fin (jj + 2) → Tape := + Fin.snoc (fun i => (⟨1, checkedCells cells par res inp₀.read i⟩ : Tape)) + (resT.write (Γ.ofBool v)) with hW₁ + have hW₁cast : ∀ i : Fin (jj + 1), + W₁ i.castSucc = (⟨1, checkedCells cells par res inp₀.read i⟩ : Tape) := by + intro i + rw [hW₁, Fin.snoc_castSucc] + have hW₁last : W₁ (Fin.last (jj + 1)) = resT.write (Γ.ofBool v) := by rw [hW₁, Fin.snoc_last] + have hresW : (resT.write (Γ.ofBool v)).StartInvariant := by + have := hresSI.write (Γw.ofBool v) + rwa [Γw.ofBool_toΓ] at this + have hresWh : 1 ≤ (resT.write (Γ.ofBool v)).head := by rw [Tape.write_head]; exact hresH + have hinv₁ : ∀ i, (W₁ i).StartInvariant := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hW₁last]; exact hresW + · intro q + rw [hW₁cast q] + exact ⟨ht'.start q, fun p hp => ht'.ne_start q p hp⟩ + have hh₁ : ∀ i, 1 ≤ (W₁ i).head := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hW₁last]; exact hresWh + · intro q + rw [hW₁cast q] + have hns : ∀ i, (W₁ i).read ≠ Γ.start := fun i => (hinv₁ i).read_ne_start (hh₁ i) + have hmove := TM.inMoveTM_hoareTime dc.dec mv.castSucc dr.castSucc inp₀ out₀ W₁ hinv₁ hh₁ + hok.inp hok.out + have hmove' : (TM.inMoveTM dc.dec mv.castSucc dr.castSucc).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₁) + (fun inp work out => + inp = inp₀.move (dc.dec (checkedCells cells par res inp₀.read mv 1) + (checkedCells cells par res inp₀.read dr 1)) ∧ out = out₀ ∧ + work = W₁) 1 := by + exact hmove.consequence (fun _ _ _ h => ⟨h.1, h.2.2, h.2.1⟩) + (fun _ _ _ h => ⟨by rw [h.1, hW₁cast dr, hW₁cast mv]; rfl, h.2.2, h.2.1⟩) le_rfl + refine TM.seqTM_hoareTime _ _ + (checkPhase_hoareTime tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew cells len + inp₀ out₀ resT hok ht hresSI hresH hpr ht') ?_ hmove' + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨TM.transitionInput_eq_self hok.inp, TM.transitionTape_eq_self hok.out, ?_⟩ + funext i + exact TM.transitionTape_eq_self (hns i) + +/-- The registers after the scan's verdict is copied onto the accumulator. -/ +noncomputable def verdictCells {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) (acc : Fin (jj + 1)) + (v : Bool) : Fin (jj + 1) → ℕ → Γ := + Function.update cells acc (Function.update (cells acc) 1 (Γ.ofBool v)) + +@[simp] theorem verdictCells_self {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) + (acc : Fin (jj + 1)) (v : Bool) : verdictCells cells acc v acc 1 = Γ.ofBool v := by + rw [verdictCells, Function.update_self, Function.update_self] + +@[simp] theorem verdictCells_ne {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) + (acc : Fin (jj + 1)) (v : Bool) (i : Fin (jj + 1)) (hi : i ≠ acc) : + verdictCells cells acc v i = cells i := by + rw [verdictCells, Function.update_of_ne hi] + +/-- **The accumulator reads one exactly when the scan accepted.** This is the cell the loop's +test looks at. -/ +theorem verdictCells_acc_one {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) + (acc : Fin (jj + 1)) (v : Bool) : + verdictCells cells acc v acc 1 = Γ.one ↔ v = true := by + rw [verdictCells_self] + cases v + · exact ⟨fun h => absurd h (fun hc => Γ.noConfusion hc), fun h => absurd h (by simp)⟩ + · exact ⟨fun _ => rfl, fun _ => rfl⟩ + +/-! ## One walk step, as a machine + +Guess the next code (and the transition, and the direction), rewind the guessed registers, check +the guessed input symbol against the machine's own input tape, run the walk-step scan, and move +the input head. The guess tape is last; everything after the guess stage is guess-free and lifted +past it. -/ + +/-- One walk step as a machine: guess every register, hold the enclosing loops' `r` tapes still, +check and move, and conjoin the verdict into the accumulator. -/ +noncomputable def walkStepTM {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg : ℕ → Fin (jj + 2 + r + 1)) (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) : + TM (jj + 2 + r + 1) := + TM.seqTM (TM.guessStageTM guessReg w t targets) + (TM.seqTM + (TM.liftLast (TM.liftMany + (walkCheckTM tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew) r)) + (TM.andCellTM (Fin.castAdd r (Fin.last (jj + 1))).castSucc accIdx)) + +/-- **The contract of a walk step.** Guess every register, then check, move, and record. The +guessed tapes are named by `TM.guessBlocksTapes`; what they contain is the caller's business, and +`Complexity.walkStepScanner_decides` is what turns the resulting verdict into a step of the walk. +The accumulator is not a register — no guess can reach it — and it only ever loses its one, which +is what makes a single failed check final in a loop that cannot stop early. -/ +theorem walkStepTM_hoareTime {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg : ℕ → Fin (jj + 2 + r + 1)) (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) (hnodup : targets.Nodup) + (hall : ∀ i : Fin (jj + 2), Fin.castAdd r i ∈ targets) + (haux : ∀ c : Fin r, Fin.natAdd (jj + 2) c ∉ targets) + (hauxG : ∀ p c, p < t → guessReg p ≠ (Fin.natAdd (jj + 2) c).castSucc) + (haccReg : ∀ i : Fin (jj + 2), accIdx ≠ (Fin.castAdd r i).castSucc) + (haccLast : accIdx ≠ Fin.last (jj + 2 + r)) + (hj : ∀ p, guessReg p ≠ Fin.last (jj + 2 + r)) (B : ℕ) (hB : 1 ≤ B) + (inp₀ out₀ : Tape) (W₀ : Fin (jj + 2 + r + 1) → Tape) + (hinpSI : inp₀.StartInvariant) (houtSI : out₀.StartInvariant) + (hinp : inp₀.read ≠ Γ.start) (hout : out₀.read ≠ Γ.start) + (hinvW : ∀ i, (W₀ i).StartInvariant) (hhW : ∀ i, 1 ≤ (W₀ i).head) + (hinj : ∀ p q, p < t → q < t → guessReg p = guessReg q → p = q) + (hbound : ∀ i, i ∈ targets → + (TM.guessBlocksTapes guessReg w t W₀ i.castSucc).head ≤ B) + (len : ℕ) + (hok : TM.ScanOk (TM.parkTape inp₀) + (⟨1, (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r (Fin.last (jj + 1))).castSucc).cells⟩ : Tape) + (TM.parkTape out₀)) + (ht : TM.ScanTape (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ (Fin.castAdd r i.castSucc).castSucc).cells) len) + (hpr : par ≠ res) + (ht' : TM.ScanTape (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read) len) + (hmoved : ((TM.parkTape inp₀).move (dc.dec (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read mv 1) (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read dr 1))).read ≠ Γ.start) : + (walkStepTM r tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew guessReg w t + targets accIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => + work (Fin.last (jj + 2 + r)) + = TM.guessBlocksTapes guessReg w t W₀ (Fin.last (jj + 2 + r)) ∧ + (∀ c : Fin r, (Fin.natAdd (jj + 2) c).castSucc ≠ accIdx → + work (Fin.natAdd (jj + 2) c).castSucc = W₀ (Fin.natAdd (jj + 2) c).castSucc) ∧ + inp = (TM.parkTape inp₀).move (dc.dec (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read mv 1) (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read dr 1)) ∧ + out = TM.parkTape out₀ ∧ + (∀ i : Fin (jj + 2), work (Fin.castAdd r i).castSucc = + (Fin.snoc (fun i : Fin (jj + 1) => + (⟨1, checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read i⟩ : Tape)) + ((⟨1, (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r (Fin.last (jj + 1))).castSucc).cells⟩ : Tape).write + (Γ.ofBool ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).emit + ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).run + (TM.scanCol (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read)) len)))) : Fin (jj + 2) → Tape) i) ∧ + work accIdx = ⟨(W₀ accIdx).head, Function.update (W₀ accIdx).cells (W₀ accIdx).head + (if (walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew).emit + ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew).run + (TM.scanCol (checkedCells (fun i : Fin (jj + 1) => + (TM.guessBlocksTapes guessReg w t W₀ + (Fin.castAdd r i.castSucc).castSucc).cells) par res + (TM.parkTape inp₀).read)) len) = true ∧ (W₀ accIdx).read = Γ.one + then Γ.one else Γ.zero)⟩) + (TM.guessBlocksTime w t + 1 + (1 + 1 + (targets.length * (B + 3) + 1)) + 1 + + (2 + 1 + (2 * len + 3) + 1 + 1 + 1 + 1)) := by + classical + set G := TM.guessBlocksTapes guessReg w t W₀ with hG + set cells : Fin (jj + 1) → ℕ → Γ := + fun i => (G (Fin.castAdd r i.castSucc).castSucc).cells with hcells + set resT : Tape := ⟨1, (G (Fin.castAdd r (Fin.last (jj + 1))).castSucc).cells⟩ with hresT + obtain ⟨ginv, ghh, -, -, -⟩ := TM.guessBlocksTapes_spec guessReg hj w t W₀ hinvW hhW hinj + have hstage := TM.guessStageTM_hoareTime guessReg hj w t targets hnodup B hB inp₀ out₀ W₀ + hinpSI houtSI hinp hout hinvW hhW hinj hbound + have hresSI : resT.StartInvariant := + ⟨(ginv ((Fin.castAdd r (Fin.last (jj + 1))).castSucc)).1, + fun q hq => (ginv ((Fin.castAdd r (Fin.last (jj + 1))).castSucc)).2 q hq⟩ + have hD := checkMove_hoareTime tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew cells len (TM.parkTape inp₀) (TM.parkTape out₀) resT hok ht hresSI le_rfl hpr ht' + set v : Bool := (walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc + jold jnew).emit + ((walkStepScanner tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew).run + (TM.scanCol (checkedCells cells par res (TM.parkTape inp₀).read)) len) with hvdef + set W₁ : Fin (jj + 2) → Tape := + Fin.snoc (fun i : Fin (jj + 1) => + (⟨1, checkedCells cells par res (TM.parkTape inp₀).read i⟩ : Tape)) + (resT.write (Γ.ofBool v)) with hW₁ + set movedInp : Tape := (TM.parkTape inp₀).move + (dc.dec (checkedCells cells par res (TM.parkTape inp₀).read mv 1) + (checkedCells cells par res (TM.parkTape inp₀).read dr 1)) with hmovedInp + have hGns : ∀ i, (G i).read ≠ Γ.start := fun i => (ginv i).read_ne_start (ghh i) + have hGaux : ∀ c : Fin r, G (Fin.natAdd (jj + 2) c).castSucc + = W₀ (Fin.natAdd (jj + 2) c).castSucc := by + intro c + refine (TM.guessBlocksTapes_spec guessReg hj w t W₀ hinvW hhW hinj).2.2.2.1 + _ (fun hc => ?_) (fun p hp hc => hauxG p c hp hc.symm) + exact absurd (congrArg Fin.val hc) (by simp [Fin.natAdd]; omega) + have hresW : (resT.write (Γ.ofBool v)).StartInvariant := by + have := hresSI.write (Γw.ofBool v) + rwa [Γw.ofBool_toΓ] at this + have hW₁inv : ∀ i, (W₁ i).StartInvariant := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hW₁, Fin.snoc_last] + exact hresW + · intro q + rw [hW₁, Fin.snoc_castSucc] + exact ⟨ht'.start q, fun p hp => ht'.ne_start q p hp⟩ + have hW₁head : ∀ i, 1 ≤ (W₁ i).head := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hW₁, Fin.snoc_last] + show 1 ≤ (resT.write (Γ.ofBool v)).head + rw [Tape.write_head] + · intro q + rw [hW₁, Fin.snoc_castSucc] + have hand : (TM.andCellTM (Fin.castAdd r (Fin.last (jj + 1))).castSucc accIdx).HoareTime + (fun inp work out => + work (Fin.last (jj + 2 + r)) = G (Fin.last (jj + 2 + r)) ∧ + (∀ c : Fin r, + work (Fin.natAdd (jj + 2) c).castSucc = W₀ (Fin.natAdd (jj + 2) c).castSucc) ∧ + inp = movedInp ∧ out = TM.parkTape out₀ ∧ + (∀ i : Fin (jj + 2), work (Fin.castAdd r i).castSucc = W₁ i)) + (fun inp work out => + work (Fin.last (jj + 2 + r)) = G (Fin.last (jj + 2 + r)) ∧ + (∀ c : Fin r, (Fin.natAdd (jj + 2) c).castSucc ≠ accIdx → + work (Fin.natAdd (jj + 2) c).castSucc = W₀ (Fin.natAdd (jj + 2) c).castSucc) ∧ + inp = movedInp ∧ out = TM.parkTape out₀ ∧ + (∀ i : Fin (jj + 2), work (Fin.castAdd r i).castSucc = W₁ i) ∧ + work accIdx = ⟨(W₀ accIdx).head, Function.update (W₀ accIdx).cells (W₀ accIdx).head + (if v = true ∧ (W₀ accIdx).read = Γ.one then Γ.one else Γ.zero)⟩) + 1 := by + rintro inp work out ⟨hglast, hgaux, rfl, rfl, hregs⟩ + have hidx : ∀ P : Fin (jj + 2 + r + 1) → Prop, P (Fin.last (jj + 2 + r)) → + (∀ i : Fin (jj + 2), P (Fin.castAdd r i).castSucc) → + (∀ c : Fin r, P (Fin.natAdd (jj + 2) c).castSucc) → ∀ i, P i := by + intro P hlastP hregP hauxP i + refine Fin.lastCases hlastP ?_ i + intro k + exact Fin.addCases (fun i => hregP i) (fun c => hauxP c) k + have hacc : work accIdx = W₀ accIdx := by + refine hidx (fun i => i = accIdx → work i = W₀ i) ?_ ?_ ?_ accIdx rfl + · exact fun hc => absurd hc.symm haccLast + · exact fun i hc => absurd hc.symm (haccReg i) + · exact fun c _ => hgaux c + have hinv' : ∀ i, (work i).StartInvariant := by + refine hidx _ ?_ ?_ ?_ + · rw [hglast]; exact ginv _ + · intro i; rw [hregs i]; exact hW₁inv i + · intro c; rw [hgaux c]; exact hinvW _ + have hh' : ∀ i, 1 ≤ (work i).head := by + refine hidx _ ?_ ?_ ?_ + · rw [hglast]; exact ghh _ + · intro i; rw [hregs i]; exact hW₁head i + · intro c; rw [hgaux c]; exact hhW _ + obtain ⟨c', tt, htt, hreach, hhalt, hin', hout', hother', hacc'⟩ := + TM.andCellTM_hoareTime (Fin.castAdd r (Fin.last (jj + 1))).castSucc accIdx + movedInp (TM.parkTape out₀) work hinv' hh' hmoved + (TM.parkTape_parked houtSI).read_ne_start movedInp work (TM.parkTape out₀) + ⟨rfl, rfl, rfl⟩ + have hsrcRead : (work (Fin.castAdd r (Fin.last (jj + 1))).castSucc).read = Γ.ofBool v := by + rw [hregs (Fin.last (jj + 1)), hW₁, Fin.snoc_last] + show (resT.write (Γ.ofBool v)).read = _ + rw [Tape.write, if_neg (show resT.head ≠ 0 by rw [hresT]; exact one_ne_zero)] + show Function.update resT.cells resT.head (Γ.ofBool v) resT.head = _ + rw [Function.update_self] + refine ⟨c', tt, htt, hreach, hhalt, ?_, ?_, hin', hout', ?_, ?_⟩ + · rw [hother' _ (Ne.symm haccLast), hglast] + · intro c hc + rw [hother' _ hc, hgaux c] + · intro i + rw [hother' _ (fun hcc => haccReg i hcc.symm), hregs i] + · rw [hacc', hacc, hsrcRead] + have hcond : (Γ.ofBool v = Γ.one) ↔ (v = true) := by + cases v <;> simp [Γ.ofBool] + simp only [hcond] + have hmany := TM.liftMany_hoareTime _ hD r + (fun c => W₀ (Fin.natAdd (jj + 2) c).castSucc) + (fun c => (hinvW _).read_ne_start (hhW _)) + have hlift := TM.liftLast_hoareTime _ hmany (G (Fin.last (jj + 2 + r))) + (hGns (Fin.last (jj + 2 + r))) + refine TM.seqTM_hoareTime _ _ hstage ?_ (TM.seqTM_hoareTime _ _ hlift ?_ hand) + · rintro inp work out ⟨hlast, hinpP, hwork, houtP⟩ + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · show TM.transitionTape (work (Fin.last (jj + 2 + r))) = G (Fin.last (jj + 2 + r)) + rw [hlast] + exact TM.transitionTape_eq_self (hGns _) + · intro c + show TM.transitionTape (work (Fin.natAdd (jj + 2) c).castSucc) = _ + have hc : work (Fin.natAdd (jj + 2) c).castSucc + = TM.parkTape (G (Fin.natAdd (jj + 2) c).castSucc) := by + have := congrFun hwork (Fin.natAdd (jj + 2) c) + rw [this, if_neg (haux c)] + rw [hc, hGaux c, TM.parkTape_eq_self (hhW _)] + exact TM.transitionTape_eq_self ((hinvW _).read_ne_start (hhW _)) + · rw [hinpP] + exact TM.transitionInput_eq_self (TM.parkTape_parked hinpSI).read_ne_start + · rw [houtP] + exact TM.transitionTape_eq_self (TM.parkTape_parked houtSI).read_ne_start + · funext i + show TM.transitionTape (work (Fin.castAdd r i).castSucc) = _ + have hi : work (Fin.castAdd r i).castSucc + = (⟨1, (G (Fin.castAdd r i).castSucc).cells⟩ : Tape) := by + have := congrFun hwork (Fin.castAdd r i) + rw [this, if_pos (hall i)] + rw [hi, TM.transitionTape_eq_self (by + show (⟨1, (G (Fin.castAdd r i).castSucc).cells⟩ : Tape).read ≠ Γ.start + exact fun hc => (ginv (Fin.castAdd r i).castSucc).2 1 le_rfl hc)] + refine Fin.lastCases ?_ ?_ i + · rw [Fin.snoc_last] + · intro q + rw [Fin.snoc_castSucc] + · rintro inp work out ⟨hlast, hgaux, hin, hout', hregs⟩ + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · show TM.transitionTape (work (Fin.last (jj + 2 + r))) = _ + rw [hlast] + exact TM.transitionTape_eq_self (hGns _) + · intro c + have h : work (Fin.natAdd (jj + 2) c).castSucc = W₀ (Fin.natAdd (jj + 2) c).castSucc := + hgaux c + show TM.transitionTape (work (Fin.natAdd (jj + 2) c).castSucc) = _ + rw [h] + exact TM.transitionTape_eq_self ((hinvW _).read_ne_start (hhW _)) + · rw [hin] + exact TM.transitionInput_eq_self hmoved + · rw [hout'] + exact TM.transitionTape_eq_self (TM.parkTape_parked houtSI).read_ne_start + · intro i + have h : work (Fin.castAdd r i).castSucc = W₁ i := congrFun hregs i + show TM.transitionTape (work (Fin.castAdd r i).castSucc) = _ + rw [h] + exact TM.transitionTape_eq_self ((hW₁inv i).read_ne_start (hW₁head i)) +/-- Its advancing states: only the guess stage consumes guesses. -/ +noncomputable def walkStepAdv {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg : ℕ → Fin (jj + 2 + r + 1)) (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) : + (walkStepTM r tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew guessReg w t + targets accIdx).Q → Bool := + TM.seqAdv (TM.seqAdv (TM.guessBlocksAdv guessReg w t) (fun _ => false)) + (TM.seqAdv (fun _ => false) (fun _ => false)) + +/-- **A walk step respects the guess protocol.** Only the guess stage advances the guess head; the +checks and the input-head move never consult it. -/ +theorem guessProtocol_walkStepTM {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) (advance : Bool) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg : ℕ → Fin (jj + 2 + r + 1)) (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) + (haccLast : accIdx ≠ Fin.last (jj + 2 + r)) : + TM.GuessProtocol + (walkStepTM r tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew guessReg w t + targets accIdx) + (walkStepAdv r tm nn S par mv dr res cntOld cntNew wc advance dc jold jnew guessReg w t + targets accIdx) := + TM.guessProtocol_seqTM (TM.guessProtocol_guessStageTM guessReg w t targets) + (TM.guessProtocol_seqTM (TM.guessProtocol_liftLast _) + (TM.guessProtocol_andCellTM _ accIdx (by + intro hc + have hv := congrArg Fin.val hc + have h1 : ((Fin.castAdd r (Fin.last (jj + 1))).castSucc + : Fin (jj + 2 + r + 1)).val = jj + 1 := rfl + have h2 : (Fin.last (jj + 2 + r) : Fin (jj + 2 + r + 1)).val = jj + 2 + r := rfl + omega) haccLast)) + +/-! ## The loop's test + +`TM.loopTM` decides whether to continue by reading cell one of the **output** tape, while a scan +writes its verdict to a work register. So a test is a scan followed by +`TM.writeOutputBitTM`, which publishes that register's bit on the output tape. The walk's test +compares the counter against the register holding the target count. -/ + +/-- **What the test decides**: the counter and the target agree over the counter's width. -/ +theorem counterTest_verdict {jj : ℕ} (cnt target : Fin (jj + 1)) (wc len : ℕ) (hw : wc ≤ len) + (cols : ℕ → Fin (jj + 1) → Γ) : + ((Scanner.eq jj cnt target).upTo wc).emit + (((Scanner.eq jj cnt target).upTo wc).run cols len) = true ↔ + ∀ q, 1 ≤ q → q ≤ wc → cols q cnt = cols q target := by + rw [Scanner.upTo_emit_run _ (Scanner.rightOnly_eq jj cnt target) wc len hw] + show (Scanner.eq jj cnt target).run cols wc = true ↔ _ + rw [Scanner.eq_run] + +/-- **The counter and the target agree exactly when they hold the same number.** -/ +theorem counterTest_decides {jj : ℕ} (cnt target : Fin (jj + 1)) (wc len : ℕ) (hw : wc ≤ len) + (cols : ℕ → Fin (jj + 1) → Γ) (u v : ℕ) (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hcnt : HoldsBits cols 0 cnt (bitsOfLenLE wc u)) + (htar : HoldsBits cols 0 target (bitsOfLenLE wc v)) : + ((Scanner.eq jj cnt target).upTo wc).emit + (((Scanner.eq jj cnt target).upTo wc).run cols len) = true ↔ u = v := by + rw [counterTest_verdict cnt target wc len hw cols] + constructor + · intro h + have hbits : bitsOfLenLE wc u = bitsOfLenLE wc v := by + refine List.ext_getElem (by rw [bitsOfLenLE_length, bitsOfLenLE_length]) ?_ + intro q h1 h2 + have hq : q < wc := by rw [bitsOfLenLE_length] at h1; exact h1 + have hc := h (q + 1) (by omega) (by omega) + rw [show q + 1 = 0 + q + 1 by omega, hcnt q h1, htar q h2] at hc + exact ofBool_injective hc + have := congrArg binValLE hbits + rwa [binValLE_bitsOfLenLE wc u hu, binValLE_bitsOfLenLE wc v hv] at this + · intro h q h1 h2 + subst h + have hq : q - 1 < wc := by omega + have hc := hcnt (q - 1) (by rw [bitsOfLenLE_length]; exact hq) + have ht := htar (q - 1) (by rw [bitsOfLenLE_length]; exact hq) + rw [Nat.zero_add, show q - 1 + 1 = q by omega] at hc ht + rw [hc, ht] + +/-- The loop's test: stop when the counter reaches its target, or when a check has failed. A +failed check leaves the loop early, with the counter short of its target, and the comparison +afterwards rejects. -/ +noncomputable def loopTestScanner {jj : ℕ} (cnt target acc : Fin (jj + 1)) (wc : ℕ) : + Scanner jj := + Scanner.or ((Scanner.eq jj cnt target).upTo wc) ((Scanner.isNotConst jj acc Γ.one).upTo 1) + +/-- **What the loop's test decides.** -/ +theorem loopTestScanner_verdict {jj : ℕ} (cnt target acc : Fin (jj + 1)) (wc len : ℕ) + (hw : wc ≤ len) (h1 : 1 ≤ len) (cols : ℕ → Fin (jj + 1) → Γ) : + (loopTestScanner cnt target acc wc).emit + ((loopTestScanner cnt target acc wc).run cols len) = true ↔ + ((∀ q, 1 ≤ q → q ≤ wc → cols q cnt = cols q target) ∨ cols 1 acc ≠ Γ.one) := by + rw [loopTestScanner, Scanner.or_emit_run, counterTest_verdict cnt target wc len hw cols, + Scanner.isNotConst_cell jj acc Γ.one cols len h1] + +/-- **When the checks have passed, the loop stops exactly when the counter reaches its +target.** -/ +theorem loopTestScanner_decides {jj : ℕ} (cnt target acc : Fin (jj + 1)) (wc len : ℕ) + (hw : wc ≤ len) (h1 : 1 ≤ len) (cols : ℕ → Fin (jj + 1) → Γ) (u v : ℕ) + (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hcnt : HoldsBits cols 0 cnt (bitsOfLenLE wc u)) + (htgt : HoldsBits cols 0 target (bitsOfLenLE wc v)) + (hacc : cols 1 acc = Γ.one) : + (loopTestScanner cnt target acc wc).emit + ((loopTestScanner cnt target acc wc).run cols len) = true ↔ u = v := by + rw [loopTestScanner_verdict cnt target acc wc len hw h1 cols] + constructor + · rintro (hall | hne) + · exact (counterTest_decides cnt target wc len hw cols u v hu hv hcnt htgt).mp + ((counterTest_verdict cnt target wc len hw cols).mpr hall) + · exact absurd hacc hne + · intro huv + refine Or.inl ((counterTest_verdict cnt target wc len hw cols).mp ?_) + exact (counterTest_decides cnt target wc len hw cols u v hu hv hcnt htgt).mpr huv + +/-- **A failed check stops the loop.** -/ +theorem loopTestScanner_of_fail {jj : ℕ} (cnt target acc : Fin (jj + 1)) (wc len : ℕ) + (hw : wc ≤ len) (h1 : 1 ≤ len) (cols : ℕ → Fin (jj + 1) → Γ) + (hacc : cols 1 acc ≠ Γ.one) : + (loopTestScanner cnt target acc wc).emit + ((loopTestScanner cnt target acc wc).run cols len) = true := + (loopTestScanner_verdict cnt target acc wc len hw h1 cols).mpr (Or.inr hacc) + +/-- The loop's test as a machine: the comparison, then the verdict published where `TM.loopTM` +reads it. -/ +noncomputable def loopTestTM {jj : ℕ} (cnt target acc : Fin (jj + 1)) (wc : ℕ) : TM (jj + 2) := + TM.seqTM (TM.twoPassTM (loopTestScanner cnt target acc wc)) + (TM.writeOutputBitTM (Fin.last (jj + 1))) + +/-- **A published test's contract.** The scan runs, and the publish step puts its verdict where +`TM.loopTM` looks for it: cell one of the output tape. -/ +theorem publishTestTM_hoareTime {jj : ℕ} (Sc : Scanner jj) (len : ℕ) + (cells : Fin (jj + 1) → ℕ → Γ) (inp₀ out₀ resT : Tape) + (hok : TM.ScanOk inp₀ resT out₀) (ht : TM.ScanTape cells len) + (hinpP : TM.Parked inp₀) (houtP : TM.Parked out₀) (hresSI : resT.StartInvariant) + (hresH : resT.head = 1) : + (TM.seqTM (TM.twoPassTM Sc) (TM.writeOutputBitTM (Fin.last (jj + 1)))).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) resT) + (fun inp work out => inp = inp₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) + (resT.write (Γ.ofBool (Sc.emit (Sc.run (TM.scanCol cells) len)))) ∧ + out = out₀.write (Γ.ofBool (Sc.emit (Sc.run (TM.scanCol cells) len)))) + (2 * len + 3 + 1 + 1) := by + classical + set v : Bool := Sc.emit (Sc.run (TM.scanCol cells) len) with hv + set W₁ : Fin (jj + 2) → Tape := + Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) (resT.write (Γ.ofBool v)) with hW₁ + have hW₁cast : ∀ i : Fin (jj + 1), W₁ i.castSucc = (⟨1, cells i⟩ : Tape) := by + intro i + rw [hW₁, Fin.snoc_castSucc] + have hW₁last : W₁ (Fin.last (jj + 1)) = resT.write (Γ.ofBool v) := by rw [hW₁, Fin.snoc_last] + have hresW : (resT.write (Γ.ofBool v)).StartInvariant := by + have := hresSI.write (Γw.ofBool v) + rwa [Γw.ofBool_toΓ] at this + have hparked : ∀ i, TM.Parked (W₁ i) := by + intro i + refine Fin.lastCases ?_ ?_ i + · rw [hW₁last] + exact ⟨by rw [Tape.write_head, hresH], fun q hq => hresW.2 q hq⟩ + · intro q + rw [hW₁cast q] + exact ⟨le_rfl, fun p hp => ht.ne_start q p hp⟩ + have hread : (W₁ (Fin.last (jj + 1))).read = Γ.ofBool v := by + rw [hW₁last, Tape.read, Tape.write_head, hresH, Tape.write, if_neg (by rw [hresH]; omega), + hresH] + show Function.update resT.cells 1 (Γ.ofBool v) 1 = _ + rw [Function.update_self] + have hpub := TM.writeOutputBitTM_hoareTime_frame (Fin.last (jj + 1)) inp₀ W₁ out₀ + hinpP hparked houtP + have hpub' : (TM.writeOutputBitTM (Fin.last (jj + 1))).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₁) + (fun inp work out => inp = inp₀ ∧ work = W₁ ∧ out = out₀.write (Γ.ofBool v)) 1 := by + refine hpub.consequence (fun _ _ _ h => ⟨h.1, h.2.2, h.2.1⟩) (fun _ _ _ h => ?_) le_rfl + refine ⟨h.1, h.2.1, ?_⟩ + rw [h.2.2, hread] + cases v <;> rfl + refine TM.seqTM_hoareTime _ _ + (TM.twoPassTM_hoareTime Sc cells len inp₀ out₀ resT hok ht) + ?_ hpub' + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨TM.transitionInput_eq_self hinpP.read_ne_start, + TM.transitionTape_eq_self houtP.read_ne_start, ?_⟩ + funext i + exact TM.transitionTape_eq_self (hparked i).read_ne_start + +/-! ## The walk, as a machine + +A walk step guesses *every* register — that uniformity is what makes the guess stage's output +match the scan's precondition — so the register holding the old code is overwritten each +iteration, and nothing would pin it to the previous iteration's new code. Rather than copy a +register, the loop's body runs **two** steps with the roles swapped: the first carries the code +from `jold` to `jnew`, the second from `jnew` back to `jold`. After an iteration the code is where +it started. + +Walks of even length lose nothing, because a step may leave the code alone: a walk of any shorter +length is one of these padded with stays. + +The loop below is built on `TM.loopTM`, whose test channel is the *output* tape. That is fine for +reasoning about the walk in isolation, but the machine `NL_subset_coNL_of_counting` asks for must +be a transducer, and `TM.loopTM` rewinds the output tape. The final assembly therefore drives the +same body with `TM.binaryForTM`, whose counter and limit live on binary work tapes and which +`IsTransducer.binaryForTM` shows to be output-safe. -/ + +/-- The body of the walk: two steps, with the code's registers — and the counter's — swapping +roles. Only the second step advances the counter, so it names the loop's iteration. -/ +noncomputable def walkPairTM {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cnt cnt' : Fin (jj + 1)) (wc : ℕ) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg guessReg' : ℕ → Fin (jj + 2 + r + 1)) + (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) : TM (jj + 2 + r + 1) := + TM.seqTM + (walkStepTM r tm nn S par mv dr res cnt cnt' wc false dc jold jnew guessReg w t targets + accIdx) + (walkStepTM r tm nn S par mv dr res cnt' cnt wc false dc jnew jold guessReg' w t targets + accIdx) + +/-- Its advancing states. -/ +noncomputable def walkPairAdv {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cnt cnt' : Fin (jj + 1)) (wc : ℕ) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg guessReg' : ℕ → Fin (jj + 2 + r + 1)) + (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) : + (walkPairTM r tm nn S par mv dr res cnt cnt' wc dc jold jnew guessReg guessReg' w t + targets accIdx).Q → + Bool := + TM.seqAdv + (walkStepAdv r tm nn S par mv dr res cnt cnt' wc false dc jold jnew guessReg w t targets + accIdx) + (walkStepAdv r tm nn S par mv dr res cnt' cnt wc false dc jnew jold guessReg' w t targets + accIdx) + +/-- **The paired step respects the guess protocol.** -/ +theorem guessProtocol_walkPairTM {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cnt cnt' : Fin (jj + 1)) (wc : ℕ) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg guessReg' : ℕ → Fin (jj + 2 + r + 1)) + (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) + (haccLast : accIdx ≠ Fin.last (jj + 2 + r)) : + TM.GuessProtocol + (walkPairTM r tm nn S par mv dr res cnt cnt' wc dc jold jnew guessReg guessReg' w t + targets accIdx) + (walkPairAdv r tm nn S par mv dr res cnt cnt' wc dc jold jnew guessReg guessReg' w t + targets accIdx) := + TM.guessProtocol_seqTM + (guessProtocol_walkStepTM r tm nn S par mv dr res cnt cnt' wc false dc jold jnew guessReg + w t targets accIdx haccLast) + (guessProtocol_walkStepTM r tm nn S par mv dr res cnt' cnt wc false dc jnew jold guessReg' + w t targets accIdx haccLast) + +/-- **The walk as a machine**: paired steps, counted by the loop driver's own binary counter. +`TM.binaryForTM` is output-safe, which `TM.loopTM` — whose test channel is the output tape — is +not, and the whole machine has to be a transducer. -/ +noncomputable def walkLoopTM {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cnt cnt' : Fin (jj + 1)) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg guessReg' : ℕ → Fin (jj + 2 + r + 1)) (w : ℕ → ℕ) + (t wc : ℕ) (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) + (counterIdx limitIdx : Fin (jj + 2 + r + 1)) : TM (jj + 2 + r + 1) := + TM.binaryForTM + (walkPairTM r tm nn S par mv dr res cnt cnt' wc dc jold jnew guessReg guessReg' w t + targets accIdx) + counterIdx limitIdx + +/-- **The walk respects the guess protocol.** Only the body's guess stage advances the guess +head; the loop driver rewrites every tape it does not own and holds its head still. -/ +theorem guessProtocol_walkLoopTM {kk jj : ℕ} (r : ℕ) (tm : NTM kk) (nn S : ℕ) + (par mv dr res cnt cnt' : Fin (jj + 1)) (dc : DirCodec) + (jold jnew : ℕ → Fin (jj + 1)) (guessReg guessReg' : ℕ → Fin (jj + 2 + r + 1)) (w : ℕ → ℕ) + (t wc : ℕ) (targets : List (Fin (jj + 2 + r))) (accIdx : Fin (jj + 2 + r + 1)) + (counterIdx limitIdx : Fin (jj + 2 + r + 1)) + (haccLast : accIdx ≠ Fin.last (jj + 2 + r)) + (hcounter : counterIdx ≠ Fin.last (jj + 2 + r)) + (hlimit : limitIdx ≠ Fin.last (jj + 2 + r)) : + TM.GuessProtocol + (walkLoopTM r tm nn S par mv dr res cnt cnt' dc jold jnew guessReg guessReg' w t wc targets + accIdx counterIdx limitIdx) + (TM.binaryForAdv + (walkPairAdv r tm nn S par mv dr res cnt cnt' wc dc jold jnew guessReg guessReg' w t + targets accIdx) + counterIdx limitIdx) := + TM.guessProtocol_binaryForTM + (guessProtocol_walkPairTM r tm nn S par mv dr res cnt cnt' wc dc jold jnew guessReg guessReg' + w t targets accIdx haccLast) counterIdx limitIdx hcounter hlimit + +/-- **A walk taken two steps at a time reaches everything a walk of any shorter length does.** +The machine's loop body is a pair of steps, so its walks have even length; padding with steps that +stay put covers the rest. -/ +theorem mem_reachCodes_of_pairWalk {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q kk x.length S) (N i : ℕ) (hi : i ≤ 2 * N) + (f : ℕ → Code tm.Q kk x.length S) (h0 : f 0 = a₀) + (hstep : ∀ j < i, f (j + 1) = f j ∨ f (j + 1) ∈ NTM.codeSucc tm x S (f j)) : + f i ∈ NTM.reachCodes tm x S a₀ (2 * N) := + NTM.reachCodes_mono a₀ hi (mem_reachCodes_of_walk tm x S a₀ i f h0 hstep) + +/-! ## The input head follows the simulated one + +`TM.inMoveTM` moves the machine's own input head by the direction the walk step's check pinned. +That direction is the one the simulated transition takes, and a tape's head moves exactly as +`Complexity.movedIdx` says — including at the left marker, where both a leftward move and +`movedIdx` stay put. -/ + +/-- **A tape's head moves as `Complexity.movedIdx` says.** -/ +theorem move_head_eq_movedIdx (t : Tape) (d : Dir3) : (t.move d).head = movedIdx d t.head := by + cases d <;> rfl + +/-- **The input head lands where the code says.** -/ +theorem move_head_of_dir (t : Tape) (C : DirCodec) (d : Dir3) (m g : Γ) + (hm : m = C.encMove d) (hg : g = C.enc d) : + (t.move (C.dec m g)).head = movedIdx d t.head := by + rw [hm, hg, C.dec_enc, move_head_eq_movedIdx] + +/-- **A walk step's scan accepts a step that stays put.** -/ +theorem walkStepScanner_accepts_stay {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) + (advance : Bool) (dc : DirCodec) (j j' : ℕ → Fin (jj + 1)) + (a : Code tm.Q kk x.length S) (u v : ℕ) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S a p)) + (hmv : cols 1 mv = dc.encMove Dir3.stay) (hdr : cols 1 dr = dc.enc Dir3.stay) + (hwc : wc ≤ walkScanLen tm x.length S) (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hcntOld : HoldsBits cols 0 cntOld (bitsOfLenLE wc u)) + (hcntNew : HoldsBits cols 0 cntNew (bitsOfLenLE wc v)) + (hmove : if advance then v = u + 1 else u = v) : + (walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').emit + ((walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').run cols + (walkScanLen tm x.length S)) = true := + walkStepScanner_accepts tm x S cols par mv dr res cntOld cntNew wc advance dc j j' + hwc u v hu hv hcntOld hcntNew hmove + (walkCodeScanner_accepts_stay tm x S cols par mv dr res dc j j' a ha hb hmv hdr) + +/-- **A walk step's scan accepts a genuine advancing step.** Everything the checks need is +supplied: the registers' contents, the direction cells, the counter's move, and the input check's +verdict. -/ +theorem walkStepScanner_accepts_succ {kk jj : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cols : ℕ → Fin (jj + 1) → Γ) (par mv dr res cntOld cntNew : Fin (jj + 1)) (wc : ℕ) + (advance : Bool) (dc : DirCodec) (j j' : ℕ → Fin (jj + 1)) + (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) (u v : ℕ) + (hpar : HoldsBits cols 0 par ((succParamsCodec tm.Q kk).enc P)) + (ha : ∀ p, p < kk + 3 → HoldsBits cols 0 (j p) (codeBlockScan tm x S a p)) + (hb : ∀ p, p < kk + 3 → HoldsBits cols 0 (j' p) (codeBlockScan tm x S b p)) + (hq : a.1 = P.q) (hstate : b.1 = succState tm P) + (hwsym : ∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = P.wSym i) + (hosym : a.2.2.2.2 a.2.2.2.1 = P.oSym) + (hhead : b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val) + (hwork : ∀ i, (b.2.2.1 i).1.val = movedIdx (succDir tm P i) (a.2.2.1 i).1.val ∧ + ∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val then succWrite tm P i + else (a.2.2.1 i).2 p) + (hout : b.2.2.2.1.val = movedIdx (succTrans tm P).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm P).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) + (hleft : (succTrans tm P).2.2.2.1 = Dir3.left → 0 < a.2.1.val) + (hmv : cols 1 mv = dc.encMove (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val)) + (hdr : cols 1 dr = dc.enc (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val)) + (hin : P.inSym = inSymOf tm x S a) + (hres : a.2.1.val ≠ 0 → cols 1 res = Γ.one) + (hwc : wc ≤ walkScanLen tm x.length S) (hu : u < 2 ^ wc) (hv : v < 2 ^ wc) + (hcntOld : HoldsBits cols 0 cntOld (bitsOfLenLE wc u)) + (hcntNew : HoldsBits cols 0 cntNew (bitsOfLenLE wc v)) + (hmove : if advance then v = u + 1 else u = v) : + (walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').emit + ((walkStepScanner tm x.length S par mv dr res cntOld cntNew wc advance dc j j').run cols + (walkScanLen tm x.length S)) = true := by + refine walkStepScanner_accepts tm x S cols par mv dr res cntOld cntNew wc advance dc j j' + hwc u v hu hv hcntOld hcntNew hmove ?_ + refine walkCodeScanner_accepts_succ tm x S cols par mv dr res dc j j' a b P hpar ha hb hq + hstate hwsym hosym hhead hwork hout hleft ?_ ?_ + · exact dirCheckScanner_accepts tm x S cols par mv dr (codeRegsOf j).hd (codeRegsOf j').hd dc + P a b hpar (holdsCodeScan_of_blocks tm x S cols j a ha).2.1 + (holdsCodeScan_of_blocks tm x S cols j' b hb).2.1 hhead hmv hdr + · exact inSymScanner_accepts tm x S cols par (codeRegsOf j).hd res P a hpar + (holdsCodeScan_of_blocks tm x S cols j a ha).2.1 hin hres + +/-! ## The ruler register + +A two-pass scan turns around when it meets a blank on register `0`, so that register fixes the +scan's length: it must carry non-blank symbols for exactly as many cells as the scan is to read, +and a blank immediately after. The guess writes it like any other register — a block of ones as +wide as `Complexity.walkScanLen` — which is why register `0` of the layout is a ruler and the +code's registers start at one. -/ + +/-- The ruler register's contents: ones for the length of the scan. -/ +def rulerBlock (len : ℕ) : List Bool := List.replicate len true + +@[simp] theorem rulerBlock_length (len : ℕ) : (rulerBlock len).length = len := + List.length_replicate + +theorem rulerBlock_getElem (len q : ℕ) (hq : q < len) : (rulerBlock len)[q]'(by simpa using hq) + = true := by + show (List.replicate len true)[q]'(by simpa using hq) = true + simp + +/-- **A register of ones as long as the scan makes the scan well formed.** The blank just past the +ruler is what stops the rightward pass; it is not written by the guess, so it is the one thing a +caller must know about the tape rather than about the guess. -/ +theorem scanTape_of_ruler {jj : ℕ} (cells : Fin (jj + 1) → ℕ → Γ) (len : ℕ) + (hstart : ∀ i, cells i 0 = Γ.start) (hne : ∀ i q, 1 ≤ q → cells i q ≠ Γ.start) + (hruler : ∀ q, 1 ≤ q → q ≤ len → cells 0 q = Γ.one) + (hblank : cells 0 (len + 1) = Γ.blank) : TM.ScanTape cells len where + start := hstart + ne_start := hne + ne_blank q h1 h2 := by + rw [hruler q h1 h2] + exact fun hc => Γ.noConfusion hc + blank := hblank + +/-- **A register holding the ruler block is a ruler.** -/ +theorem ruler_of_holds {jj : ℕ} (cols : ℕ → Fin (jj + 1) → Γ) (r : Fin (jj + 1)) (len : ℕ) + (h : HoldsBits cols 0 r (rulerBlock len)) : ∀ q, 1 ≤ q → q ≤ len → cols q r = Γ.one := by + intro q h1 h2 + have hq : q - 1 < len := by omega + have hc := h (q - 1) (by simpa using hq) + rw [Nat.zero_add, show q - 1 + 1 = q by omega, rulerBlock_getElem len (q - 1) hq] at hc + exact hc + +/-! ## Moving a head that is pinned away from the marker + +The machine's input head sits at `max h 1`, so it must move by the direction that takes +`max h 1` to `max h' 1` — which is the simulated direction only when both `h` and `h'` are off the +marker, and "stay" otherwise. Both conditions are fields of the two codes, so both are decided by +the same scan. -/ + +/-- **The adjusted direction moves a pinned head to where it should be.** -/ +theorem move_adjusted (t : Tape) (d : Dir3) (h : ℕ) (ht : t.head = max h 1) : + (t.move (adjustedDir d h)).head = max (movedIdx d h) 1 := by + rw [move_head_eq_movedIdx, ht, adjustedDir] + by_cases h0 : h = 0 + · rw [if_pos h0, h0] + cases d <;> simp [movedIdx] + · rw [if_neg h0] + by_cases h1 : movedIdx d h = 0 + · rw [if_pos h1, h1] + cases d <;> simp only [movedIdx] at h1 ⊢ <;> omega + · rw [if_neg h1] + cases d <;> simp only [movedIdx] at h1 ⊢ <;> omega + +/-- **One walk step carries the input head to where the next code says.** Whichever branch the +step took, the direction register holds `Complexity.adjustedDir` of the step's direction, and a +head parked at `max h 1` lands parked at `max h' 1`. -/ +theorem move_of_walkStep (C : DirCodec) (t : Tape) (h h' : ℕ) (d : Dir3) (m g : Γ) + (ht : t.head = max h 1) (hm : m = C.encMove (adjustedDir d h)) + (hg : g = C.enc (adjustedDir d h)) (hh' : h' = movedIdx d h) : + t.move (C.dec m g) = ⟨max h' 1, t.cells⟩ := by + refine Tape.ext ?_ (Tape.move_cells t _) + rw [hm, hg, C.dec_enc, hh'] + exact move_adjusted t d h ht + +/-- **A step that stays put leaves the input head where it was.** -/ +theorem move_of_walkStay (C : DirCodec) (t : Tape) (h : ℕ) (m g : Γ) + (ht : t.head = max h 1) (hm : m = C.encMove Dir3.stay) (hg : g = C.enc Dir3.stay) : + t.move (C.dec m g) = ⟨max h 1, t.cells⟩ := by + have hstay : adjustedDir Dir3.stay h = Dir3.stay := by + rw [adjustedDir] + split_ifs <;> rfl + refine move_of_walkStep C t h h Dir3.stay m g ht ?_ ?_ rfl + · rw [hm, hstay] + · rw [hg, hstay] + +/-- **What one walk step establishes about the tapes.** Either branch of the step leaves the +input head parked where the new code says, and the code itself is one step of the walk. -/ +theorem walkStep_transports (C : DirCodec) {kk : ℕ} {tm : NTM kk} {x : List Bool} {S : ℕ} + (a b : Code tm.Q kk x.length S) (P : SuccParams tm.Q kk) (t : Tape) (m g : Γ) + (ht : t.head = max a.2.1.val 1) + (hstep : (b = a ∧ m = C.encMove Dir3.stay ∧ g = C.enc Dir3.stay) ∨ + (b ∈ NTM.codeSucc tm x S a ∧ + b.2.1.val = movedIdx (succTrans tm P).2.2.2.1 a.2.1.val ∧ + m = C.encMove (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val) ∧ + g = C.enc (adjustedDir (succTrans tm P).2.2.2.1 a.2.1.val))) : + (b = a ∨ b ∈ NTM.codeSucc tm x S a) ∧ t.move (C.dec m g) = ⟨max b.2.1.val 1, t.cells⟩ := by + rcases hstep with ⟨hba, hm, hg⟩ | ⟨hsucc, hmove, hm, hg⟩ + · refine ⟨Or.inl hba, ?_⟩ + rw [hba] + exact move_of_walkStay C t a.2.1.val m g ht hm hg + · exact ⟨Or.inr hsucc, move_of_walkStep C t a.2.1.val b.2.1.val + (succTrans tm P).2.2.2.1 m g ht hm hg hmove⟩ + +/-! ## The fields of a genuine successor + +The completeness direction starts from a walk that really happens and must produce the guesses +that make every check pass. `Complexity.paramsOf` names the transition a code takes on a given +choice, and its fields are what the checks compare against. -/ + +/-- **A genuine successor's fields are what the checks want.** The clamps are the space +discipline: the step must stay inside the window, which is where the codes live. -/ +theorem succ_fields_of_eq {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a b : Code tm.Q kk x.length S) (β : Bool) (hb : b = succCode tm x S β a) + (hin : movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.1 a.2.1.val ≤ x.length + S + 1) + (hw : ∀ i, movedIdx (succDir tm (paramsOf tm x S a β) i) (a.2.2.1 i).1.val ≤ S) + (ho : movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.2.2 a.2.2.2.1.val ≤ S + 1) : + a.1 = (paramsOf tm x S a β).q ∧ + b.1 = succState tm (paramsOf tm x S a β) ∧ + (∀ i, (a.2.2.1 i).2 (a.2.2.1 i).1 = (paramsOf tm x S a β).wSym i) ∧ + a.2.2.2.2 a.2.2.2.1 = (paramsOf tm x S a β).oSym ∧ + b.2.1.val = movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.1 a.2.1.val ∧ + (∀ i, (b.2.2.1 i).1.val = movedIdx (succDir tm (paramsOf tm x S a β) i) + (a.2.2.1 i).1.val ∧ + ∀ p, (b.2.2.1 i).2 p = if p = (a.2.2.1 i).1 ∧ 0 < p.val + then succWrite tm (paramsOf tm x S a β) i else (a.2.2.1 i).2 p) ∧ + (b.2.2.2.1.val = movedIdx (succTrans tm (paramsOf tm x S a β)).2.2.2.2.2 a.2.2.2.1.val ∧ + ∀ p, b.2.2.2.2 p = if p = a.2.2.2.1 ∧ 0 < p.val + then (((succTrans tm (paramsOf tm x S a β)).2.2.1 : Γw) : Γ) else a.2.2.2.2 p) := by + obtain ⟨hstate, hhead, hwork, hout⟩ := + (eq_succCode_iff tm x S a b β hin hw ho).mp hb + exact ⟨rfl, hstate, fun i => rfl, rfl, hhead, hwork, hout⟩ + +/-- **The input symbol a genuine successor's parameters name.** -/ +theorem succ_inSym {kk : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (a : Code tm.Q kk x.length S) (β : Bool) : + (paramsOf tm x S a β).inSym = inSymOf tm x S a := rfl + +/-! ## The walk's register layout + +Every register the walk uses is guessed, so the layout has to name them all and say how wide each +block is. The roles are: the ruler that fixes the scan's length, the parameter block, the +direction cell, the input check's verdict, the accumulator the loop's test reads, the two counter +registers, the target the counter is compared against, and the two code register tuples. -/ + +/-- The role a guessed block plays in the walk. -/ +inductive BlockRole (kk : ℕ) where + /-- The ruler that fixes the scan's length. -/ + | ruler + /-- The guessed transition's parameters. -/ + | par + /-- Whether the input head is to move at all. -/ + | mv + /-- Which way it is to move. -/ + | dr + /-- The input check's verdict. -/ + | res + /-- The accumulator the loop's test reads. -/ + | acc + /-- The counter. -/ + | cnt + /-- The counter's partner. -/ + | cnt' + /-- The target the counter is compared against. -/ + | target + /-- Block `p` of the first code tuple. -/ + | codeA (p : ℕ) + /-- Block `p` of the second. -/ + | codeB (p : ℕ) + deriving DecidableEq + +/-- Which register plays which role in the walk, and that the roles are distinct. -/ +structure WalkLayout (kk jj : ℕ) where + /-- What each block is for. -/ + role : ℕ → BlockRole kk + /-- The block index of each register: block `p` is written to register `reg p`. -/ + reg : ℕ → Fin (jj + 1) + /-- The number of blocks, one per register. -/ + blocks : ℕ + /-- Distinct blocks go to distinct registers. -/ + reg_inj : ∀ p q, p < blocks → q < blocks → reg p = reg q → p = q + /-- The ruler's block. -/ + rulerIdx : ℕ + /-- The parameter block's. -/ + parIdx : ℕ + /-- The move cell's. -/ + mvIdx : ℕ + /-- The direction cell's. -/ + drIdx : ℕ + /-- The input check's verdict register. -/ + resIdx : ℕ + /-- The accumulator the loop's test reads. -/ + accIdx : ℕ + /-- The counter, and the register it swaps with. -/ + cntIdx : ℕ + /-- The other counter register. -/ + cnt'Idx : ℕ + /-- The target the counter is compared against. -/ + targetIdx : ℕ + /-- The first code tuple's blocks, `kk + 3` of them. -/ + codeAIdx : ℕ → ℕ + /-- The second code tuple's blocks. -/ + codeBIdx : ℕ → ℕ + /-- How many blocks come before the two code tuples: the scan's scratch. A step guesses the + scratch and one code tuple, and leaves the other tuple where the previous step put it — which is + what chains the walk. -/ + scratch : ℕ + /-- The old code's blocks follow the scratch. -/ + codeA_eq : ∀ p, p < kk + 3 → codeAIdx p = scratch + p + /-- The new code's follow those. -/ + codeB_eq : ∀ p, p < kk + 3 → codeBIdx p = scratch + (kk + 3) + p + /-- And nothing follows them. -/ + blocks_eq : blocks = scratch + (kk + 3) + (kk + 3) + /-- The ruler is register zero, where a scan looks for its length. -/ + ruler_zero : reg rulerIdx = 0 + /-- The ruler is scratch. -/ + ruler_scratch : rulerIdx < scratch + /-- So is the parameter block. -/ + par_scratch : parIdx < scratch + /-- So is the move cell. -/ + mv_scratch : mvIdx < scratch + /-- So is the direction cell. -/ + dr_scratch : drIdx < scratch + /-- So is the verdict register. -/ + res_scratch : resIdx < scratch + /-- So is the accumulator. -/ + acc_scratch : accIdx < scratch + /-- So is the counter. -/ + cnt_scratch : cntIdx < scratch + /-- So is its partner. -/ + cnt'_scratch : cnt'Idx < scratch + /-- So is the target. -/ + target_scratch : targetIdx < scratch + /-- The roles agree with the indices. -/ + role_ruler : role rulerIdx = BlockRole.ruler + /-- The parameter block's role. -/ + role_par : role parIdx = BlockRole.par + /-- The move cell's. -/ + role_mv : role mvIdx = BlockRole.mv + /-- The direction cell's. -/ + role_dr : role drIdx = BlockRole.dr + /-- The verdict register's. -/ + role_res : role resIdx = BlockRole.res + /-- The accumulator's. -/ + role_acc : role accIdx = BlockRole.acc + /-- The counter's. -/ + role_cnt : role cntIdx = BlockRole.cnt + /-- Its partner's. -/ + role_cnt' : role cnt'Idx = BlockRole.cnt' + /-- The target's. -/ + role_target : role targetIdx = BlockRole.target + /-- Each code block's. -/ + role_codeA : ∀ p, p < kk + 3 → role (codeAIdx p) = BlockRole.codeA p + /-- And the other tuple's. -/ + role_codeB : ∀ p, p < kk + 3 → role (codeBIdx p) = BlockRole.codeB p + +namespace WalkLayout + +variable {kk jj : ℕ} (L : WalkLayout kk jj) + +/-- The ruler is a block. -/ +theorem ruler_lt : L.rulerIdx < L.blocks := by + rw [L.blocks_eq]; have := L.ruler_scratch; omega + +/-- The parameter block is a block. -/ +theorem par_lt : L.parIdx < L.blocks := by + rw [L.blocks_eq]; have := L.par_scratch; omega + +/-- The move cell is a block. -/ +theorem mv_lt : L.mvIdx < L.blocks := by + rw [L.blocks_eq]; have := L.mv_scratch; omega + +/-- The direction cell is a block. -/ +theorem dr_lt : L.drIdx < L.blocks := by + rw [L.blocks_eq]; have := L.dr_scratch; omega + +/-- The verdict register is a block. -/ +theorem res_lt : L.resIdx < L.blocks := by + rw [L.blocks_eq]; have := L.res_scratch; omega + +/-- The accumulator is a block. -/ +theorem acc_lt : L.accIdx < L.blocks := by + rw [L.blocks_eq]; have := L.acc_scratch; omega + +/-- The counter is a block. -/ +theorem cnt_lt : L.cntIdx < L.blocks := by + rw [L.blocks_eq]; have := L.cnt_scratch; omega + +/-- So is its partner. -/ +theorem cnt'_lt : L.cnt'Idx < L.blocks := by + rw [L.blocks_eq]; have := L.cnt'_scratch; omega + +/-- So is the target. -/ +theorem target_lt : L.targetIdx < L.blocks := by + rw [L.blocks_eq]; have := L.target_scratch; omega + +/-- So is each of the old code's blocks. -/ +theorem codeA_lt : ∀ p, p < kk + 3 → L.codeAIdx p < L.blocks := by + intro p hp + rw [L.codeA_eq p hp, L.blocks_eq] + omega + +/-- And each of the new code's. -/ +theorem codeB_lt : ∀ p, p < kk + 3 → L.codeBIdx p < L.blocks := by + intro p hp + rw [L.codeB_eq p hp, L.blocks_eq] + omega + +/-- **The blocks one step of the pair guesses**: the scratch, and one code tuple. The first step +of a pair writes the new code's blocks and leaves the old code's registers alone; the second does +the reverse. That is what chains a walk — the check of each step compares its guess against what +the previous step really left behind — and what returns every code to its own registers after a +pair. -/ +def stepIdx (second : Bool) (p : ℕ) : ℕ := + if p < L.scratch then p else if second then p else p + (kk + 3) + +/-- How many blocks a step guesses. -/ +def stepBlocks : ℕ := L.scratch + (kk + 3) + +/-- A step's blocks are blocks. -/ +theorem stepIdx_lt (second : Bool) (p : ℕ) (hp : p < L.stepBlocks) : + L.stepIdx second p < L.blocks := by + rw [stepIdx, blocks_eq] + rw [stepBlocks] at hp + split <;> [omega; (split <;> omega)] + +/-- A step guesses each of its blocks once. -/ +theorem stepIdx_inj (second : Bool) : ∀ p q, p < L.stepBlocks → q < L.stepBlocks → + L.stepIdx second p = L.stepIdx second q → p = q := by + intro p q hp hq h + rw [stepIdx, stepIdx] at h + split at h <;> split at h <;> first | omega | (split at h <;> omega) + +/-- The second step of a pair guesses the old code's blocks. -/ +theorem stepIdx_codeA (p : ℕ) (hp : p < kk + 3) : + L.stepIdx true (L.scratch + p) = L.codeAIdx p := by + rw [stepIdx, if_neg (by omega), if_pos rfl, L.codeA_eq p hp] + +/-- The first step guesses the new code's. -/ +theorem stepIdx_codeB (p : ℕ) (hp : p < kk + 3) : + L.stepIdx false (L.scratch + p) = L.codeBIdx p := by + rw [stepIdx, if_neg (by omega), if_neg (by simp), L.codeB_eq p hp] + omega + +/-- The first step guesses none of the old code's blocks. -/ +theorem stepIdx_ne_codeA (p q : ℕ) (_hp : p < L.stepBlocks) (hq : q < kk + 3) : + L.stepIdx false p ≠ L.codeAIdx q := by + rw [stepIdx, L.codeA_eq q hq] + split <;> [omega; (rw [if_neg (by simp)]; omega)] + +/-- The second guesses none of the new code's. -/ +theorem stepIdx_ne_codeB (p q : ℕ) (hp : p < L.stepBlocks) (hq : q < kk + 3) : + L.stepIdx true p ≠ L.codeBIdx q := by + rw [stepIdx, L.codeB_eq q hq] + rw [stepBlocks] at hp + split <;> [omega; (rw [if_pos rfl]; omega)] + +/-- The parameter register. -/ +def par : Fin (jj + 1) := L.reg L.parIdx + +/-- The move register. -/ +def mv : Fin (jj + 1) := L.reg L.mvIdx + +/-- The direction register. -/ +def dr : Fin (jj + 1) := L.reg L.drIdx + +/-- The input check's verdict register. -/ +def res : Fin (jj + 1) := L.reg L.resIdx + +/-- The accumulator. -/ +def acc : Fin (jj + 1) := L.reg L.accIdx + +/-- The counter. -/ +def cnt : Fin (jj + 1) := L.reg L.cntIdx + +/-- The counter's partner. -/ +def cnt' : Fin (jj + 1) := L.reg L.cnt'Idx + +/-- The target. -/ +def target : Fin (jj + 1) := L.reg L.targetIdx + +/-- The first code tuple's registers. -/ +def codeA : ℕ → Fin (jj + 1) := fun p => L.reg (L.codeAIdx p) + +/-- The second code tuple's registers. -/ +def codeB : ℕ → Fin (jj + 1) := fun p => L.reg (L.codeBIdx p) + +/-- **Blocks with different roles live in different registers.** -/ +theorem reg_ne {p q : ℕ} (hp : p < L.blocks) (hq : q < L.blocks) (h : L.role p ≠ L.role q) : + L.reg p ≠ L.reg q := by + intro hc + exact h (by rw [L.reg_inj p q hp hq hc]) + +/-- The verdict register is not a code register. -/ +theorem codeA_ne_res {r : ℕ} (hr : r < kk + 3) : L.codeA r ≠ L.res := + L.reg_ne (L.codeA_lt r hr) L.res_lt (by + rw [L.role_codeA r hr, L.role_res] + exact fun hc => by simp at hc) + +/-- Nor is the other tuple's. -/ +theorem codeB_ne_res {r : ℕ} (hr : r < kk + 3) : L.codeB r ≠ L.res := + L.reg_ne (L.codeB_lt r hr) L.res_lt (by + rw [L.role_codeB r hr, L.role_res] + exact fun hc => by simp at hc) + +/-- Nor the parameter block. -/ +theorem par_ne_res : L.par ≠ L.res := + L.reg_ne L.par_lt L.res_lt (by + rw [L.role_par, L.role_res] + exact fun hc => by simp at hc) + +/-- Nor the move cell. -/ +theorem mv_ne_res : L.mv ≠ L.res := + L.reg_ne L.mv_lt L.res_lt (by + rw [L.role_mv, L.role_res] + exact fun hc => by simp at hc) + +/-- Nor the direction cell. -/ +theorem dr_ne_res : L.dr ≠ L.res := + L.reg_ne L.dr_lt L.res_lt (by + rw [L.role_dr, L.role_res] + exact fun hc => by simp at hc) + +/-- Nor either counter. -/ +theorem cnt_ne_res : L.cnt ≠ L.res := + L.reg_ne L.cnt_lt L.res_lt (by + rw [L.role_cnt, L.role_res] + exact fun hc => by simp at hc) + +/-- Nor the counter's partner. -/ +theorem cnt'_ne_res : L.cnt' ≠ L.res := + L.reg_ne L.cnt'_lt L.res_lt (by + rw [L.role_cnt', L.role_res] + exact fun hc => by simp at hc) + +end WalkLayout + +/-- The widths the layout's blocks are guessed at. A block of width `n` writes `n + 1` bits, so a +one-cell register — the direction, a verdict — has width zero. -/ +structure WalkWidths (kk jj : ℕ) (tm : NTM kk) (nn S wc : ℕ) extends WalkLayout kk jj where + /-- How wide each block is guessed. -/ + width : ℕ → ℕ + /-- The ruler spans the whole scan. -/ + width_ruler : width toWalkLayout.rulerIdx = walkScanLen tm nn S - 1 + /-- The parameter block spans a transition's parameters. -/ + width_par : width toWalkLayout.parIdx = (succParamsCodec tm.Q kk).width - 1 + /-- Whether to move is one cell. -/ + width_mv : width toWalkLayout.mvIdx = 0 + /-- A direction is one cell. -/ + width_dr : width toWalkLayout.drIdx = 0 + /-- So is a verdict. -/ + width_res : width toWalkLayout.resIdx = 0 + /-- And so is the accumulator. -/ + width_acc : width toWalkLayout.accIdx = 0 + /-- The counters and the target span the counter's width. -/ + width_cnt : width toWalkLayout.cntIdx = wc - 1 + /-- The counter's partner is the same width. -/ + width_cnt' : width toWalkLayout.cnt'Idx = wc - 1 + /-- And so is the target. -/ + width_target : width toWalkLayout.targetIdx = wc - 1 + /-- A code's blocks are as wide as the walk's layout says. -/ + width_codeA : ∀ p, p < kk + 3 → width (toWalkLayout.codeAIdx p) = codeWidthScan tm nn S p + /-- And the other tuple's the same. -/ + width_codeB : ∀ p, p < kk + 3 → width (toWalkLayout.codeBIdx p) = codeWidthScan tm nn S p + +/-- **How wide that block is guessed.** Both steps of a pair guess the same widths — a code's two +tuples are laid out alike — so one width function serves both, and the guess stream advances by +the same amount at every stage. -/ +def stepWidth {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} (L : WalkWidths kk jj tm nn S wc) + (p : ℕ) : ℕ := + L.width (L.toWalkLayout.stepIdx true p) + +/-- A scratch block is guessed at its own width. -/ +theorem stepWidth_scratch {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (p : ℕ) (hp : p < L.toWalkLayout.scratch) : + stepWidth L p = L.width p := by + rw [stepWidth, WalkLayout.stepIdx, if_pos hp] + +/-- A code block is guessed at the code's width. -/ +theorem stepWidth_code {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (p : ℕ) (hp : p < kk + 3) : + stepWidth L (L.toWalkLayout.scratch + p) = codeWidthScan tm nn S p := by + rw [stepWidth, L.toWalkLayout.stepIdx_codeA p hp, L.width_codeA p hp] + +/-- **The first step of a pair guesses its blocks at those same widths.** -/ +theorem width_stepIdx_false {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (p : ℕ) (hp : p < L.toWalkLayout.stepBlocks) : + L.width (L.toWalkLayout.stepIdx false p) = stepWidth L p := by + by_cases hs : p < L.toWalkLayout.scratch + · rw [stepWidth, WalkLayout.stepIdx, WalkLayout.stepIdx, if_pos hs, if_pos hs] + · have hp' : p - L.toWalkLayout.scratch < kk + 3 := by + rw [WalkLayout.stepBlocks] at hp + omega + have hpe : p = L.toWalkLayout.scratch + (p - L.toWalkLayout.scratch) := by omega + rw [hpe, L.toWalkLayout.stepIdx_codeB _ hp', L.width_codeB _ hp', + stepWidth_code L _ hp'] + +/-- **What one stage of the walk must guess**: the ruler, the transition's parameters, the two +direction cells, the counters and the target, and the two code tuples. Everything else is a +verdict register, whose guessed value is overwritten before it is read. -/ +noncomputable def stageBits {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) : ℕ → ℕ → Bool := + fun p q => + match L.toWalkLayout.role p with + | BlockRole.ruler => true + | BlockRole.par => ((succParamsCodec tm.Q kk).enc P).getD q false + | BlockRole.mv => decide (dc.encMove d = Γ.one) + | BlockRole.dr => decide (dc.enc d = Γ.one) + | BlockRole.res => false + | BlockRole.acc => accBit + | BlockRole.cnt => (bitsOfLenLE wc cOld).getD q false + | BlockRole.cnt' => (bitsOfLenLE wc cNew).getD q false + | BlockRole.target => (bitsOfLenLE wc tgt).getD q false + | BlockRole.codeA r => (codeBlockScan tm x S aOld r).getD q false + | BlockRole.codeB r => (codeBlockScan tm x S aNew r).getD q false + +/-- **The code blocks a stage guesses are the code's own.** -/ +theorem stageBits_codeA {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) (r : ℕ) (hr : r < kk + 3) (q : ℕ) : + stageBits L x dc P d cOld cNew tgt accBit aOld aNew (L.toWalkLayout.codeAIdx r) q + = (codeBlockScan tm x S aOld r).getD q false := by + rw [stageBits] + simp only [L.toWalkLayout.role_codeA r hr] + +/-- **And the other tuple's are the successor's.** -/ +theorem stageBits_codeB {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) (r : ℕ) (hr : r < kk + 3) (q : ℕ) : + stageBits L x dc P d cOld cNew tgt accBit aOld aNew (L.toWalkLayout.codeBIdx r) q + = (codeBlockScan tm x S aNew r).getD q false := by + rw [stageBits] + simp only [L.toWalkLayout.role_codeB r hr] + +/-- **The parameter block a stage guesses is the transition's encoding.** -/ +theorem stageBits_par {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) (q : ℕ) : + stageBits L x dc P d cOld cNew tgt accBit aOld aNew L.toWalkLayout.parIdx q + = ((succParamsCodec tm.Q kk).enc P).getD q false := by + rw [stageBits] + simp only [L.toWalkLayout.role_par] + +/-- **The counter a stage guesses holds its value.** -/ +theorem stageBits_cnt {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) (q : ℕ) : + stageBits L x dc P d cOld cNew tgt accBit aOld aNew L.toWalkLayout.cntIdx q + = (bitsOfLenLE wc cOld).getD q false := by + rw [stageBits] + simp only [L.toWalkLayout.role_cnt] + +/-- **And its partner the next value.** -/ +theorem stageBits_cnt' {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) (q : ℕ) : + stageBits L x dc P d cOld cNew tgt accBit aOld aNew L.toWalkLayout.cnt'Idx q + = (bitsOfLenLE wc cNew).getD q false := by + rw [stageBits] + simp only [L.toWalkLayout.role_cnt'] + +/-- **And the target its own.** -/ +theorem stageBits_target {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (P : SuccParams tm.Q kk) (d : Dir3) (cOld cNew tgt : ℕ) (accBit : Bool) + (aOld aNew : Code tm.Q kk x.length S) (q : ℕ) : + stageBits L x dc P d cOld cNew tgt accBit aOld aNew L.toWalkLayout.targetIdx q + = (bitsOfLenLE wc tgt).getD q false := by + rw [stageBits] + simp only [L.toWalkLayout.role_target] + +/-- The certificate for a whole walk: what every stage guesses, given the codes it visits, the +transitions it takes, the directions those imply and the counter values. -/ +noncomputable def walkCert {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) : ℕ → ℕ → ℕ → Bool := + fun s => stageBits L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) (f (s + 1)) + +/-- **A stage's code blocks come off the certificate as that stage's codes.** -/ +theorem walkCert_codeA {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (s r : ℕ) (hr : r < kk + 3) (q : ℕ) : + walkCert L x dc Ps ds cOlds cNews tgt f s (L.toWalkLayout.codeAIdx r) q + = (codeBlockScan tm x S (f s) r).getD q false := + stageBits_codeA L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) (f (s + 1)) r hr q + +/-- **And the other tuple's as the next code's.** -/ +theorem walkCert_codeB {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (s r : ℕ) (hr : r < kk + 3) (q : ℕ) : + walkCert L x dc Ps ds cOlds cNews tgt f s (L.toWalkLayout.codeBIdx r) q + = (codeBlockScan tm x S (f (s + 1)) r).getD q false := + stageBits_codeB L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) (f (s + 1)) r hr q + +/-- Embed a register index into the walk machine's tape set: the registers, then the scan's +result tape, then the guess tape. -/ +def walkReg {jj r : ℕ} (i : Fin (jj + 1)) : Fin (jj + 2 + r + 1) := + (Fin.castAdd r i.castSucc).castSucc + +/-- How many guess bits an iteration of the walk consumes: one stage per step, two steps to an +iteration. -/ +def walkGuessStride (w : ℕ → ℕ) (t : ℕ) : ℕ := 2 * TM.guessOffset w t + +/-- A register of the walk is never the guess tape. -/ +theorem walkReg_ne_last {jj r : ℕ} (i : Fin (jj + 1)) : walkReg i ≠ Fin.last (jj + 2 + r) := by + intro hc + have hv := congrArg Fin.val hc + have h1 : (walkReg i : Fin (jj + 2 + r + 1)).val = i.val := rfl + have h2 : (Fin.last (jj + 2 + r) : Fin (jj + 2 + r + 1)).val = jj + 2 + r := rfl + have := i.isLt + omega + +/-- **Distinct registers are distinct tapes.** -/ +theorem walkReg_inj {jj r : ℕ} {i i' : Fin (jj + 1)} + (h : (walkReg (r := r) i : Fin (jj + 2 + r + 1)) = walkReg i') : i = i' := by + have hv := congrArg Fin.val h + have h1 : (walkReg (r := r) i : Fin (jj + 2 + r + 1)).val = i.val := rfl + have h2 : (walkReg (r := r) i' : Fin (jj + 2 + r + 1)).val = i'.val := rfl + exact Fin.ext (by omega) + +/-- **The tape a step's `p`-th guessed block goes to.** -/ +def stepReg {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} (L : WalkWidths kk jj tm nn S wc) + (second : Bool) (p : ℕ) : Fin (jj + 2 + r + 1) := + walkReg (L.toWalkLayout.reg (L.toWalkLayout.stepIdx second p)) + +/-- A block's own bits fit in the width it is guessed at. -/ +theorem blockLen_le_codeWidthScan {kk : ℕ} (tm : NTM kk) (nn S r : ℕ) : + blockLen tm nn S r ≤ codeWidthScan tm nn S r + 1 := by + simp only [blockLen, codeWidthScan, codeWidth] + split_ifs <;> omega + +/-- **After a stage, each register holds the bits the certificate names for it.** -/ +theorem holdsBits_block_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (b : ℕ → ℕ → ℕ → Bool) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks b g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) + (p : ℕ) (hp : p < L.toWalkLayout.blocks) (bits : List Bool) + (hbits : ∀ q, (hq : q < bits.length) → b s p q = bits[q]) + (hlen : bits.length ≤ L.width p + 1) : + HoldsBits (fun c i => + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W i).cells c) 0 (walkReg (L.toWalkLayout.reg p)) bits := by + have hbits' := holdsBits_of_guessBlocks (fun p => walkReg (L.toWalkLayout.reg p)) + (fun p => walkReg_ne_last _) L.width L.toWalkLayout.blocks W hinv hh + (fun p q hp hq hpq => L.toWalkLayout.reg_inj p q hp hq (by + have hbeta : (walkReg (L.toWalkLayout.reg p) : Fin (jj + 2 + r + 1)).val + = (walkReg (L.toWalkLayout.reg q) : Fin (jj + 2 + r + 1)).val := congrArg Fin.val hpq + exact Fin.ext (by + have h1 : (walkReg (L.toWalkLayout.reg p) : Fin (jj + 2 + r + 1)).val + = (L.toWalkLayout.reg p).val := rfl + have h2 : (walkReg (L.toWalkLayout.reg q) : Fin (jj + 2 + r + 1)).val + = (L.toWalkLayout.reg q).val := rfl + omega))) + hr1 (b s) (TM.blocks_of_stageBlocks hs s hgf) + exact (hbits' p hp).of_isPrefix (isPrefix_ofFn _ hlen hbits) + +/-- **What a step's guess leaves on each of its own blocks.** The stage version guesses every +block; a step guesses only its own, and this says nothing about the rest — which is what lets the +other code tuple survive the step untouched. -/ +theorem holdsBits_block_of_step {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (second : Bool) + (b : ℕ → ℕ → ℕ → Bool) (g : ℕ → Bool) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks b g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L second p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) + (p : ℕ) (hp : p < L.toWalkLayout.stepBlocks) (bits : List Bool) + (hbits : ∀ q, (hq : q < bits.length) → b s p q = bits[q]) + (hlen : bits.length ≤ stepWidth L p + 1) : + HoldsBits (fun c i => + (TM.guessBlocksTapes (stepReg L second) (stepWidth L) + L.toWalkLayout.stepBlocks W i).cells c) 0 (stepReg L second p) bits := by + have hbits' := holdsBits_of_guessBlocks (stepReg L second) + (fun p => walkReg_ne_last _) (stepWidth L) L.toWalkLayout.stepBlocks W hinv hh + (fun p q hp hq hpq => L.toWalkLayout.stepIdx_inj second p q hp hq + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt second p hp) + (L.toWalkLayout.stepIdx_lt second q hq) (walkReg_inj hpq))) + hr1 (b s) (TM.blocks_of_stageBlocks hs s hgf) + exact (hbits' p hp).of_isPrefix (isPrefix_ofFn _ hlen hbits) + +/-- **The old code's registers hold the code the certificate names.** -/ +theorem holdsBits_codeA_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + ∀ r, r < kk + 3 → HoldsBits (fun c i => + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W i).cells c) 0 + (walkReg (L.toWalkLayout.codeA r)) (codeBlockScan tm x S (f s) r) := by + intro r hr + refine holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf (L.toWalkLayout.codeAIdx r) + (L.toWalkLayout.codeA_lt r hr) _ (fun q hq => ?_) ?_ + · rw [walkCert_codeA L x dc Ps ds cOlds cNews tgt f s r hr q, + List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some] + · rw [codeBlockScan_length, L.width_codeA r hr] + exact blockLen_le_codeWidthScan tm x.length S r + +/-- **The new code's registers hold the next code.** -/ +theorem holdsBits_codeB_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + ∀ r, r < kk + 3 → HoldsBits (fun c i => + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W i).cells c) 0 + (walkReg (L.toWalkLayout.codeB r)) (codeBlockScan tm x S (f (s + 1)) r) := by + intro r hr + refine holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf (L.toWalkLayout.codeBIdx r) + (L.toWalkLayout.codeB_lt r hr) _ (fun q hq => ?_) ?_ + · rw [walkCert_codeB L x dc Ps ds cOlds cNews tgt f s r hr q, + List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some] + · rw [codeBlockScan_length, L.width_codeB r hr] + exact blockLen_le_codeWidthScan tm x.length S r + +/-- **The parameter register holds the transition the certificate names.** -/ +theorem holdsBits_par_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + HoldsBits (fun c i => + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W i).cells c) 0 + (walkReg L.toWalkLayout.par) ((succParamsCodec tm.Q kk).enc (Ps s)) := by + refine holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.parIdx + L.toWalkLayout.par_lt _ (fun q hq => ?_) ?_ + · rw [walkCert, stageBits_par L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) + (f (s + 1)) q, List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some] + · rw [(succParamsCodec tm.Q kk).enc_length, L.width_par] + omega + +/-- **A counter register holds the value the certificate names.** -/ +theorem holdsBits_cnt_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + HoldsBits (fun c i => + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W i).cells c) 0 + (walkReg L.toWalkLayout.cnt) (bitsOfLenLE wc (cOlds s)) := by + refine holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.cntIdx + L.toWalkLayout.cnt_lt _ (fun q hq => ?_) ?_ + · rw [walkCert, stageBits_cnt L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) + (f (s + 1)) q, List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some] + · rw [bitsOfLenLE_length, L.width_cnt] + omega + +/-- **A one-cell register holds the symbol the certificate names.** -/ +theorem cell_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (b : ℕ → ℕ → ℕ → Bool) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks b g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) + (p : ℕ) (hp : p < L.toWalkLayout.blocks) (hw : L.width p = 0) (sym : Γ) + (hbit : sym = Γ.zero ∨ sym = Γ.one) (hcert : b s p 0 = decide (sym = Γ.one)) : + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg (L.toWalkLayout.reg p))).cells 1 = sym := by + have h := holdsBits_block_of_stage x L b g hs s W hinv hh hr1 hgf p hp + [decide (sym = Γ.one)] (fun q hq => by + have hq0 : q = 0 := by simpa using hq + subst hq0 + exact hcert) (by rw [hw]; simp) + have hc := h 0 (by simp) + have hc' : (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg (L.toWalkLayout.reg p))).cells 1 + = Γ.ofBool ([decide (sym = Γ.one)][0]'(by simp)) := hc + rw [hc'] + exact ofBool_decide_one hbit + +/-- **The move register holds what the certificate names.** -/ +theorem cell_mv_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg L.toWalkLayout.mv)).cells 1 = dc.encMove (ds s) := + cell_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.mvIdx L.toWalkLayout.mv_lt + L.width_mv _ (dc.encMove_bit (ds s)) (by + rw [walkCert, stageBits] + simp only [L.toWalkLayout.role_mv]) + +/-- **The direction register holds what the certificate names.** -/ +theorem cell_dr_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg L.toWalkLayout.dr)).cells 1 = dc.enc (ds s) := + cell_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.drIdx L.toWalkLayout.dr_lt + L.width_dr _ (dc.enc_bit (ds s)) (by + rw [walkCert, stageBits] + simp only [L.toWalkLayout.role_dr]) + +/-- **The ruler register spans the scan.** This is what makes the scan's length well defined. -/ +theorem ruler_of_stage {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + ∀ q, 1 ≤ q → q ≤ walkScanLen tm x.length S → + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg (L.toWalkLayout.reg L.toWalkLayout.rulerIdx))).cells q + = Γ.one := by + have h := holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.rulerIdx + L.toWalkLayout.ruler_lt (rulerBlock (walkScanLen tm x.length S)) (fun q hq => ?_) ?_ + · exact ruler_of_holds _ _ _ h + · rw [walkCert, stageBits] + simp only [L.toWalkLayout.role_ruler] + rw [rulerBlock_getElem _ q (by simpa using hq)] + · rw [rulerBlock_length, L.width_ruler] + have := one_le_walkScanLen tm x.length S + omega + +/-- The registers a stage leaves behind, indexed by register. -/ +noncomputable def stageCells {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (W : Fin (jj + 2 + r + 1) → Tape) : Fin (jj + 1) → ℕ → Γ := + fun i q => (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg i)).cells q + +/-- The same, as the scan sees them: indexed by cell first. -/ +noncomputable def stageCols {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (W : Fin (jj + 2 + r + 1) → Tape) : ℕ → Fin (jj + 1) → Γ := + fun q i => stageCells L W i q + +/-- **Distinct blocks are guessed into distinct tapes.** -/ +theorem walkReg_reg_inj {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) : + ∀ p q, p < L.toWalkLayout.blocks → q < L.toWalkLayout.blocks → + (walkReg (r := r) (L.toWalkLayout.reg p) : Fin (jj + 2 + r + 1)) + = walkReg (L.toWalkLayout.reg q) → p = q := by + intro p q hp hq hpq + refine L.toWalkLayout.reg_inj p q hp hq (Fin.ext ?_) + have hbeta : (walkReg (r := r) (L.toWalkLayout.reg p) : Fin (jj + 2 + r + 1)).val + = (walkReg (r := r) (L.toWalkLayout.reg q) : Fin (jj + 2 + r + 1)).val := + congrArg Fin.val hpq + have h1 : (walkReg (r := r) (L.toWalkLayout.reg p) : Fin (jj + 2 + r + 1)).val + = (L.toWalkLayout.reg p).val := rfl + have h2 : (walkReg (r := r) (L.toWalkLayout.reg q) : Fin (jj + 2 + r + 1)).val + = (L.toWalkLayout.reg q).val := rfl + omega + +/-- **A register that no block is guessed into keeps what it held.** This is what chains a walk: +the step that guesses the new code leaves the old code's registers alone, so its check compares +the guess against what the previous step really left behind, not against a fresh guess. -/ +theorem stageCells_retained {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (W : Fin (jj + 2 + r + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) (i : Fin (jj + 1)) + (hne : ∀ p, p < L.toWalkLayout.blocks → i ≠ L.toWalkLayout.reg p) : + stageCells (r := r) L W i = (W (walkReg i)).cells := by + have h := (TM.guessBlocksTapes_spec (fun p => walkReg (L.toWalkLayout.reg p)) + (fun p => walkReg_ne_last _) L.width L.toWalkLayout.blocks W hinv hh + (walkReg_reg_inj L)).2.2.2.1 (walkReg i) (walkReg_ne_last i) + (fun p hp hc => hne p hp (by + have hv := congrArg Fin.val hc + have h1 : (walkReg (r := r) i : Fin (jj + 2 + r + 1)).val = i.val := rfl + have h2 : (walkReg (r := r) (L.toWalkLayout.reg p) : Fin (jj + 2 + r + 1)).val + = (L.toWalkLayout.reg p).val := rfl + exact Fin.ext (by omega))) + funext q + show (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (walkReg i)).cells q = _ + rw [h] + +/-- The registers a step's guess leaves behind: its own blocks as the certificate names them, +every other tape exactly as it was. -/ +noncomputable def stepCells {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (second : Bool) (W : Fin (jj + 2 + r + 1) → Tape) : + Fin (jj + 1) → ℕ → Γ := + fun i q => (TM.guessBlocksTapes (stepReg L second) (stepWidth L) + L.toWalkLayout.stepBlocks W (walkReg i)).cells q + +/-- The certificate a step guesses, read through the step's own block numbering. The two codes +are given per stage, because which family is the old one alternates along a pair. -/ +noncomputable def stepCert {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (aOld aNew : ℕ → Code tm.Q kk x.length S) (second : Bool) : ℕ → ℕ → ℕ → Bool := + fun s p => stageBits L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (aOld s) (aNew s) + (L.toWalkLayout.stepIdx second p) + +/-- A scratch block keeps its own number in a step's numbering. -/ +theorem stepReg_scratch {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (second : Bool) (p : ℕ) + (hp : p < L.toWalkLayout.scratch) : + (stepReg L second p : Fin (jj + 2 + r + 1)) = walkReg (L.toWalkLayout.reg p) := by + rw [stepReg, WalkLayout.stepIdx, if_pos hp] + +/-- And so does its certificate. -/ +theorem stepCert_scratch {kk jj : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (x : List Bool) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (aOld aNew : ℕ → Code tm.Q kk x.length S) (second : Bool) (s p : ℕ) + (hp : p < L.toWalkLayout.scratch) : + stepCert L x dc Ps ds cOlds cNews tgt aOld aNew second s p + = stageBits L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (aOld s) (aNew s) p := by + rw [stepCert, WalkLayout.stepIdx, if_pos hp] + +/-- **A register no block of the step is guessed into keeps what it held.** -/ +theorem stepCells_retained {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (second : Bool) (W : Fin (jj + 2 + r + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) (i : Fin (jj + 1)) + (hne : ∀ p, p < L.toWalkLayout.stepBlocks → + (walkReg i : Fin (jj + 2 + r + 1)) ≠ stepReg L second p) : + stepCells L second W i = (W (walkReg i)).cells := by + have h := (TM.guessBlocksTapes_spec (stepReg L second) + (fun p => walkReg_ne_last _) (stepWidth L) L.toWalkLayout.stepBlocks W hinv hh + (fun p q hp hq hpq => L.toWalkLayout.stepIdx_inj second p q hp hq + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt second p hp) + (L.toWalkLayout.stepIdx_lt second q hq) (walkReg_inj hpq)))).2.2.2.1 + (walkReg i) (walkReg_ne_last i) hne + funext q + show (TM.guessBlocksTapes (stepReg L second) (stepWidth L) + L.toWalkLayout.stepBlocks W (walkReg i)).cells q = _ + rw [h] + +/-- **What a stage leaves on the parameter register, as the scan sees it.** -/ +theorem stageCols_par {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + HoldsBits (stageCols L W) 0 L.toWalkLayout.par + ((succParamsCodec tm.Q kk).enc (Ps s)) := + holdsBits_par_of_stage x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **And on the old code's registers.** -/ +theorem stageCols_codeA {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + ∀ r, r < kk + 3 → HoldsBits (stageCols L W) 0 (L.toWalkLayout.codeA r) + (codeBlockScan tm x S (f s) r) := + holdsBits_codeA_of_stage x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **And on the new code's.** -/ +theorem stageCols_codeB {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + ∀ r, r < kk + 3 → HoldsBits (stageCols L W) 0 (L.toWalkLayout.codeB r) + (codeBlockScan tm x S (f (s + 1)) r) := + holdsBits_codeB_of_stage x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **And on the counter.** -/ +theorem stageCols_cnt {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + HoldsBits (stageCols L W) 0 L.toWalkLayout.cnt (bitsOfLenLE wc (cOlds s)) := + holdsBits_cnt_of_stage x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **And on the counter's partner.** -/ +theorem stageCols_cnt' {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + HoldsBits (stageCols L W) 0 L.toWalkLayout.cnt' (bitsOfLenLE wc (cNews s)) := by + refine holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.cnt'Idx + L.toWalkLayout.cnt'_lt _ (fun q hq => ?_) ?_ + · rw [walkCert, stageBits_cnt' L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) + (f (s + 1)) q, List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some] + · rw [bitsOfLenLE_length, L.width_cnt'] + omega + +/-- **And on the target the counter is compared against.** -/ +theorem stageCols_target {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + HoldsBits (stageCols L W) 0 L.toWalkLayout.target (bitsOfLenLE wc tgt) := by + refine holdsBits_block_of_stage x L _ g hs s W hinv hh hr1 hgf L.toWalkLayout.targetIdx + L.toWalkLayout.target_lt _ (fun q hq => ?_) ?_ + · rw [walkCert, stageBits_target L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) + (f (s + 1)) q, List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some] + · rw [bitsOfLenLE_length, L.width_target] + omega + +/-- **And on the move cell.** -/ +theorem stageCols_mv {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + stageCols L W 1 L.toWalkLayout.mv = dc.encMove (ds s) := + cell_mv_of_stage x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **And on the direction cell.** -/ +theorem stageCols_dr {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + stageCols L W 1 L.toWalkLayout.dr = dc.enc (ds s) := + cell_dr_of_stage x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **What the registers hold when a stage's scan runs.** The scan cannot tell whether a register +was guessed at this stage or left behind by an earlier one, so the acceptance lemmas take this +bundle rather than the guess that produced it. -/ +structure StageCols {kk jj : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (cA cB : ℕ → Fin (jj + 1)) (cO cN : Fin (jj + 1)) + (s : ℕ) (cells : Fin (jj + 1) → ℕ → Γ) : Prop where + /-- The parameter block names the transition the step takes. -/ + par : HoldsBits (fun q i => cells i q) 0 L.toWalkLayout.par + ((succParamsCodec tm.Q kk).enc (Ps s)) + /-- The old code's registers hold the code the step starts from. -/ + codeA : ∀ p, p < kk + 3 → HoldsBits (fun q i => cells i q) 0 (cA p) + (codeBlockScan tm x S (f s) p) + /-- The new code's registers hold the code it reaches. -/ + codeB : ∀ p, p < kk + 3 → HoldsBits (fun q i => cells i q) 0 (cB p) + (codeBlockScan tm x S (f (s + 1)) p) + /-- The counter. -/ + cnt : HoldsBits (fun q i => cells i q) 0 cO (bitsOfLenLE wc (cOlds s)) + /-- Its partner, which the step compares it against. -/ + cnt' : HoldsBits (fun q i => cells i q) 0 cN (bitsOfLenLE wc (cNews s)) + /-- The target the walk is counting towards. -/ + target : HoldsBits (fun q i => cells i q) 0 L.toWalkLayout.target (bitsOfLenLE wc tgt) + /-- The move cell of the guessed direction. -/ + mv : cells L.toWalkLayout.mv 1 = dc.encMove (ds s) + /-- Its direction cell. -/ + dr : cells L.toWalkLayout.dr 1 = dc.enc (ds s) + +/-- **When the two counter registers agree, their roles can be exchanged.** The walk's counter +registers are vestigial — `TM.binaryForTM` owns the loop's index — so both steps of a pair check +only that the counter is unchanged, and it does not matter which register plays which role. -/ +theorem StageCols.swapCnt {kk jj : ℕ} {tm : NTM kk} {S wc : ℕ} {x : List Bool} + {L : WalkWidths kk jj tm x.length S wc} {dc : DirCodec} + {Ps : ℕ → SuccParams tm.Q kk} {ds : ℕ → Dir3} {cOlds cNews : ℕ → ℕ} {tgt : ℕ} + {f : ℕ → Code tm.Q kk x.length S} {cA cB : ℕ → Fin (jj + 1)} {cO cN : Fin (jj + 1)} + {s : ℕ} {cells : Fin (jj + 1) → ℕ → Γ} + (h : StageCols x L dc Ps ds cOlds cNews tgt f cA cB cO cN s cells) + (hval : cNews s = cOlds s) : + StageCols x L dc Ps ds cOlds cNews tgt f cA cB cN cO s cells where + par := h.par + codeA := h.codeA + codeB := h.codeB + cnt := by rw [← hval]; exact h.cnt' + cnt' := by rw [hval]; exact h.cnt + target := h.target + mv := h.mv + dr := h.dr + +/-- **A stage's guess establishes the bundle.** -/ +theorem stageCols_holds {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) + (hs : TM.StageBlocks L.width L.toWalkLayout.blocks + (walkCert L x dc Ps ds cOlds cNews tgt f) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.blocks → + (W (walkReg (L.toWalkLayout.reg p))).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + StageCols x L dc Ps ds cOlds cNews tgt f L.toWalkLayout.codeA L.toWalkLayout.codeB + L.toWalkLayout.cnt L.toWalkLayout.cnt' s (stageCells L W) where + par := stageCols_par x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + codeA := stageCols_codeA x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + codeB := stageCols_codeB x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + cnt := stageCols_cnt x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + cnt' := stageCols_cnt' x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + target := stageCols_target x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + mv := stageCols_mv x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + dr := stageCols_dr x L dc Ps ds cOlds cNews tgt f g hs s W hinv hh hr1 hgf + +/-- **A one-cell block of a step's guess.** -/ +theorem cell_of_step {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (second : Bool) + (b : ℕ → ℕ → ℕ → Bool) (g : ℕ → Bool) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks b g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L second p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) + (p : ℕ) (hp : p < L.toWalkLayout.stepBlocks) (hw : stepWidth L p = 0) (sym : Γ) + (hbit : sym = Γ.zero ∨ sym = Γ.one) (hcert : b s p 0 = decide (sym = Γ.one)) : + (TM.guessBlocksTapes (stepReg L second) (stepWidth L) + L.toWalkLayout.stepBlocks W (stepReg L second p)).cells 1 = sym := by + have h := holdsBits_block_of_step x L second b g hs s W hinv hh hr1 hgf p hp + [decide (sym = Γ.one)] (fun q hq => by + have hq0 : q = 0 := by simpa using hq + subst hq0 + exact hcert) (by rw [hw]; simp) + have hc := h 0 (by simp) + have hc' : (TM.guessBlocksTapes (stepReg L second) (stepWidth L) + L.toWalkLayout.stepBlocks W (stepReg L second p)).cells 1 + = Γ.ofBool ([decide (sym = Γ.one)][0]'(by simp)) := hc + rw [hc'] + exact ofBool_decide_one hbit + +/-- **What a step's registers hold when its scan runs.** The step's own blocks come from the +certificate; the other code tuple is whatever the previous step left behind, which the caller +supplies. That is the chaining — each check compares a guess against a retained code, never two +guesses against each other. -/ +theorem stepCols_holds {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f aOld aNew : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (second : Bool) + (cA cB : ℕ → Fin (jj + 1)) (s : ℕ) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks + (stepCert L x dc Ps ds cOlds cNews tgt aOld aNew second) g) + (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L second p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) + (hcB : ∀ p, p < kk + 3 → + (stepReg L second (L.toWalkLayout.scratch + p) : Fin (jj + 2 + r + 1)) = walkReg (cB p)) + (hcertB : ∀ p, p < kk + 3 → ∀ q, + stepCert L x dc Ps ds cOlds cNews tgt aOld aNew second s (L.toWalkLayout.scratch + p) q + = (codeBlockScan tm x S (f (s + 1)) p).getD q false) + (hret : ∀ p, p < kk + 3 → HoldsBits (fun q i => (W (walkReg i)).cells q) 0 (cA p) + (codeBlockScan tm x S (f s) p)) + (hretReg : ∀ p, p < kk + 3 → ∀ p', p' < L.toWalkLayout.stepBlocks → + (walkReg (cA p) : Fin (jj + 2 + r + 1)) ≠ stepReg L second p') : + StageCols x L dc Ps ds cOlds cNews tgt f cA cB L.toWalkLayout.cnt L.toWalkLayout.cnt' s + (stepCells L second W) := by + have hscratch : ∀ p, p < L.toWalkLayout.scratch → p < L.toWalkLayout.stepBlocks := by + intro p hp + rw [WalkLayout.stepBlocks] + omega + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · have h := holdsBits_block_of_step x L second _ g hs s W hinv hh hr1 hgf + L.toWalkLayout.parIdx (hscratch _ L.toWalkLayout.par_scratch) + ((succParamsCodec tm.Q kk).enc (Ps s)) (fun q hq => by + rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.par_scratch, + stageBits_par L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (aOld s) (aNew s) q, + List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some]) (by + rw [(succParamsCodec tm.Q kk).enc_length, + stepWidth_scratch L _ L.toWalkLayout.par_scratch, L.width_par] + omega) + rw [stepReg_scratch L second _ L.toWalkLayout.par_scratch] at h + exact h + · intro p hp + have hr := stepCells_retained L second W hinv hh (cA p) (hretReg p hp) + intro q hq + have h := hret p hp q hq + show stepCells L second W (cA p) (0 + q + 1) = _ + rw [hr] + exact h + · intro p hp + have h := holdsBits_block_of_step x L second _ g hs s W hinv hh hr1 hgf + (L.toWalkLayout.scratch + p) (by + rw [WalkLayout.stepBlocks] + omega) + (codeBlockScan tm x S (f (s + 1)) p) (fun q hq => by + rw [hcertB p hp q, List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, + Option.getD_some]) (by + rw [codeBlockScan_length, stepWidth_code L p hp] + exact blockLen_le_codeWidthScan tm x.length S p) + rw [hcB p hp] at h + exact h + · have h := holdsBits_block_of_step x L second _ g hs s W hinv hh hr1 hgf + L.toWalkLayout.cntIdx (hscratch _ L.toWalkLayout.cnt_scratch) + (bitsOfLenLE wc (cOlds s)) (fun q hq => by + rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.cnt_scratch, + stageBits_cnt L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (aOld s) (aNew s) q, + List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some]) (by + rw [bitsOfLenLE_length, stepWidth_scratch L _ L.toWalkLayout.cnt_scratch, L.width_cnt] + omega) + rw [stepReg_scratch L second _ L.toWalkLayout.cnt_scratch] at h + exact h + · have h := holdsBits_block_of_step x L second _ g hs s W hinv hh hr1 hgf + L.toWalkLayout.cnt'Idx (hscratch _ L.toWalkLayout.cnt'_scratch) + (bitsOfLenLE wc (cNews s)) (fun q hq => by + rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.cnt'_scratch, + stageBits_cnt' L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (aOld s) (aNew s) q, + List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some]) (by + rw [bitsOfLenLE_length, stepWidth_scratch L _ L.toWalkLayout.cnt'_scratch, L.width_cnt'] + omega) + rw [stepReg_scratch L second _ L.toWalkLayout.cnt'_scratch] at h + exact h + · have h := holdsBits_block_of_step x L second _ g hs s W hinv hh hr1 hgf + L.toWalkLayout.targetIdx (hscratch _ L.toWalkLayout.target_scratch) + (bitsOfLenLE wc tgt) (fun q hq => by + rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.target_scratch, + stageBits_target L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (aOld s) (aNew s) q, + List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq, Option.getD_some]) (by + rw [bitsOfLenLE_length, stepWidth_scratch L _ L.toWalkLayout.target_scratch, + L.width_target] + omega) + rw [stepReg_scratch L second _ L.toWalkLayout.target_scratch] at h + exact h + · have h := cell_of_step x L second _ g hs s W hinv hh hr1 hgf L.toWalkLayout.mvIdx + (hscratch _ L.toWalkLayout.mv_scratch) + (by rw [stepWidth_scratch L _ L.toWalkLayout.mv_scratch, L.width_mv]) _ + (dc.encMove_bit (ds s)) (by + rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.mv_scratch, stageBits] + simp only [L.toWalkLayout.role_mv]) + rw [stepReg_scratch L second _ L.toWalkLayout.mv_scratch] at h + exact h + · have h := cell_of_step x L second _ g hs s W hinv hh hr1 hgf L.toWalkLayout.drIdx + (hscratch _ L.toWalkLayout.dr_scratch) + (by rw [stepWidth_scratch L _ L.toWalkLayout.dr_scratch, L.width_dr]) _ + (dc.enc_bit (ds s)) (by + rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.dr_scratch, stageBits] + simp only [L.toWalkLayout.role_dr]) + rw [stepReg_scratch L second _ L.toWalkLayout.dr_scratch] at h + exact h + +/-- **The first step of a pair.** It guesses the new code's registers and keeps the old code's, +so its scan compares its guess against what the step before really left behind. -/ +theorem stepCols_holds_first {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (s : ℕ) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks + (stepCert L x dc Ps ds cOlds cNews tgt f (fun s => f (s + 1)) false) g) + (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L false p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) + (hret : ∀ p, p < kk + 3 → HoldsBits (fun q i => (W (walkReg i)).cells q) 0 + (L.toWalkLayout.codeA p) (codeBlockScan tm x S (f s) p)) : + StageCols x L dc Ps ds cOlds cNews tgt f L.toWalkLayout.codeA L.toWalkLayout.codeB + L.toWalkLayout.cnt L.toWalkLayout.cnt' s (stepCells L false W) := by + refine stepCols_holds x L dc Ps ds cOlds cNews tgt f f (fun s => f (s + 1)) g false _ _ s hs + W hinv hh hr1 hgf (fun p hp => ?_) (fun p hp q => ?_) hret (fun p hp p' hp' hc => ?_) + · rw [stepReg, L.toWalkLayout.stepIdx_codeB p hp] + rfl + · rw [stepCert, L.toWalkLayout.stepIdx_codeB p hp, + stageBits_codeB L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f s) (f (s + 1)) p hp q] + · exact L.toWalkLayout.stepIdx_ne_codeA p' p hp' hp + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt false p' hp') + (L.toWalkLayout.codeA_lt p hp) (walkReg_inj hc).symm) + +/-- **The second step of a pair.** The families have swapped roles: it guesses the old code's +registers and keeps the new code's, which is what returns each code to the registers it started +in. -/ +theorem stepCols_holds_second {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (s : ℕ) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks + (stepCert L x dc Ps ds cOlds cNews tgt (fun s => f (s + 1)) f true) g) + (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L true p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) + (hret : ∀ p, p < kk + 3 → HoldsBits (fun q i => (W (walkReg i)).cells q) 0 + (L.toWalkLayout.codeB p) (codeBlockScan tm x S (f s) p)) : + StageCols x L dc Ps ds cOlds cNews tgt f L.toWalkLayout.codeB L.toWalkLayout.codeA + L.toWalkLayout.cnt L.toWalkLayout.cnt' s (stepCells L true W) := by + refine stepCols_holds x L dc Ps ds cOlds cNews tgt f (fun s => f (s + 1)) f g true _ _ s hs + W hinv hh hr1 hgf (fun p hp => ?_) (fun p hp q => ?_) hret (fun p hp p' hp' hc => ?_) + · rw [stepReg, L.toWalkLayout.stepIdx_codeA p hp] + rfl + · rw [stepCert, L.toWalkLayout.stepIdx_codeA p hp, + stageBits_codeA L x dc (Ps s) (ds s) (cOlds s) (cNews s) tgt true (f (s + 1)) (f s) p hp q] + · exact L.toWalkLayout.stepIdx_ne_codeB p' p hp' hp + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt true p' hp') + (L.toWalkLayout.codeB_lt p hp) (walkReg_inj hc).symm) + +/-- **A stage of a walk that stays put is accepted.** Every hypothesis is now about the walk and +the guess tape: the certificate supplies the registers, and the input check leaves them alone. -/ +theorem stage_accepts_stay {kk jj : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (cA cB : ℕ → Fin (jj + 1)) (cO cN : Fin (jj + 1)) + (hcA : ∀ p, p < kk + 3 → cA p ≠ L.toWalkLayout.res) + (hcB : ∀ p, p < kk + 3 → cB p ≠ L.toWalkLayout.res) + (hcO : cO ≠ L.toWalkLayout.res) (hcN : cN ≠ L.toWalkLayout.res) + (s : ℕ) (cells : Fin (jj + 1) → ℕ → Γ) + (hc : StageCols x L dc Ps ds cOlds cNews tgt f cA cB cO cN s cells) + (advance : Bool) (gsym : Γ) + (hstay : f (s + 1) = f s) (hd : ds s = Dir3.stay) + (hwc : wc ≤ walkScanLen tm x.length S) + (hu : cOlds s < 2 ^ wc) (hv : cNews s < 2 ^ wc) + (hmove : if advance then cNews s = cOlds s + 1 else cOlds s = cNews s) : + (walkStepScanner tm x.length S L.toWalkLayout.par L.toWalkLayout.mv L.toWalkLayout.dr + L.toWalkLayout.res cO cN wc advance dc cA cB).emit + ((walkStepScanner tm x.length S L.toWalkLayout.par L.toWalkLayout.mv L.toWalkLayout.dr + L.toWalkLayout.res cO cN wc advance dc cA cB).run + (fun q i => checkedCells cells L.toWalkLayout.par L.toWalkLayout.res gsym i q) + (walkScanLen tm x.length S)) = true := by + refine walkStepScanner_accepts_stay tm x S _ L.toWalkLayout.par L.toWalkLayout.mv + L.toWalkLayout.dr L.toWalkLayout.res cO cN wc advance dc + cA cB (f s) (cOlds s) (cNews s) ?_ ?_ ?_ ?_ hwc hu hv + ?_ ?_ hmove + · intro p hp + exact holdsBits_checked (hcA p hp) + (hc.codeA p hp) + · intro p hp + have hcb := hc.codeB p hp + rw [hstay] at hcb + exact holdsBits_checked (hcB p hp) hcb + · show checkedCells cells L.toWalkLayout.par L.toWalkLayout.res gsym + L.toWalkLayout.mv 1 = _ + rw [checked_cell _ _ _ _ _ L.toWalkLayout.mv_ne_res] + rw [hc.mv, hd] + · show checkedCells cells L.toWalkLayout.par L.toWalkLayout.res gsym + L.toWalkLayout.dr 1 = _ + rw [checked_cell _ _ _ _ _ L.toWalkLayout.dr_ne_res] + rw [hc.dr, hd] + · exact holdsBits_checked hcO hc.cnt + · exact holdsBits_checked hcN hc.cnt' + +/-- **A stage of a walk that advances is accepted.** The input check's verdict is not assumed: it +follows, because the certificate names the transition the code really takes, whose input symbol is +the one the machine's own head is over. -/ +theorem stage_accepts_succ {kk jj : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (cA cB : ℕ → Fin (jj + 1)) (cO cN : Fin (jj + 1)) + (hcA : ∀ p, p < kk + 3 → cA p ≠ L.toWalkLayout.res) + (hcB : ∀ p, p < kk + 3 → cB p ≠ L.toWalkLayout.res) + (hcO : cO ≠ L.toWalkLayout.res) (hcN : cN ≠ L.toWalkLayout.res) + (s : ℕ) (cells : Fin (jj + 1) → ℕ → Γ) + (hc : StageCols x L dc Ps ds cOlds cNews tgt f cA cB cO cN s cells) + (advance : Bool) (β : Bool) + (hPs : Ps s = paramsOf tm x S (f s) β) + (hsucc : f (s + 1) = succCode tm x S β (f s)) + (hds : ds s = adjustedDir (succTrans tm (Ps s)).2.2.2.1 (f s).2.1.val) + (hclampIn : movedIdx (succTrans tm (Ps s)).2.2.2.1 (f s).2.1.val ≤ x.length + S + 1) + (hclampW : ∀ i, movedIdx (succDir tm (Ps s) i) ((f s).2.2.1 i).1.val ≤ S) + (hclampO : movedIdx (succTrans tm (Ps s)).2.2.2.2.2 (f s).2.2.2.1.val ≤ S + 1) + (hleft : (succTrans tm (Ps s)).2.2.2.1 = Dir3.left → 0 < (f s).2.1.val) + (hwc : wc ≤ walkScanLen tm x.length S) + (hu : cOlds s < 2 ^ wc) (hv : cNews s < 2 ^ wc) + (hmove : if advance then cNews s = cOlds s + 1 else cOlds s = cNews s) : + (walkStepScanner tm x.length S L.toWalkLayout.par L.toWalkLayout.mv L.toWalkLayout.dr + L.toWalkLayout.res cO cN wc advance dc cA cB).emit + ((walkStepScanner tm x.length S L.toWalkLayout.par L.toWalkLayout.mv L.toWalkLayout.dr + L.toWalkLayout.res cO cN wc advance dc cA cB).run + (fun q i => checkedCells cells L.toWalkLayout.par L.toWalkLayout.res + (inSymOf tm x S (f s)) i q) + (walkScanLen tm x.length S)) = true := by + have hpar := hc.par + have hinSym : (Ps s).inSym = inSymOf tm x S (f s) := by + rw [hPs] + rfl + obtain ⟨hq, hstate, hwsym, hosym, hhead, hwork, hout⟩ := + succ_fields_of_eq tm x S (f s) (f (s + 1)) β hsucc (by rw [← hPs] at *; exact hclampIn) + (by rw [← hPs] at *; exact hclampW) (by rw [← hPs] at *; exact hclampO) + rw [← hPs] at hq hstate hwsym hosym hhead hwork hout + refine walkStepScanner_accepts_succ tm x S _ L.toWalkLayout.par L.toWalkLayout.mv + L.toWalkLayout.dr L.toWalkLayout.res cO cN wc advance dc + cA cB (f s) (f (s + 1)) (Ps s) (cOlds s) (cNews s) + (holdsBits_checked L.toWalkLayout.par_ne_res hpar) ?_ ?_ hq hstate hwsym hosym hhead hwork + hout hleft ?_ ?_ hinSym ?_ hwc hu hv ?_ ?_ hmove + · intro p hp + exact holdsBits_checked (hcA p hp) + (hc.codeA p hp) + · intro p hp + exact holdsBits_checked (hcB p hp) + (hc.codeB p hp) + · show checkedCells cells L.toWalkLayout.par L.toWalkLayout.res _ + L.toWalkLayout.mv 1 = _ + rw [checked_cell _ _ _ _ _ L.toWalkLayout.mv_ne_res] + rw [hc.mv, hds] + · show checkedCells cells L.toWalkLayout.par L.toWalkLayout.res _ + L.toWalkLayout.dr 1 = _ + rw [checked_cell _ _ _ _ _ L.toWalkLayout.dr_ne_res] + rw [hc.dr, hds] + · intro _ + show checkedCells cells L.toWalkLayout.par L.toWalkLayout.res _ + L.toWalkLayout.res 1 = _ + rw [checkedCells_res] + have hv := inMatchVerdict_of_inSym tm (fun q i => cells i q) L.toWalkLayout.par (Ps s) + (inSymOf tm x S (f s)) hpar hinSym + have hv' : TM.inMatchVerdict gammaBits (inSymOf tm x S (f s)) + (cells L.toWalkLayout.par 1) (cells L.toWalkLayout.par 2) = true := hv + rw [hv'] + rfl + · exact holdsBits_checked hcO hc.cnt + · exact holdsBits_checked hcN hc.cnt' + +/-- **A step's ruler register spans the scan**, which is what makes the scan well formed. -/ +theorem ruler_of_step {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (aOld aNew : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (second : Bool) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks + (stepCert L x dc Ps ds cOlds cNews tgt aOld aNew second) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L second p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) : + ∀ q, 1 ≤ q → q ≤ walkScanLen tm x.length S → + stepCells L second W (L.toWalkLayout.reg L.toWalkLayout.rulerIdx) q = Γ.one := by + have hlt : L.toWalkLayout.rulerIdx < L.toWalkLayout.stepBlocks := by + rw [WalkLayout.stepBlocks] + have := L.toWalkLayout.ruler_scratch + omega + have h := holdsBits_block_of_step x L second _ g hs s W hinv hh hr1 hgf + L.toWalkLayout.rulerIdx hlt (rulerBlock (walkScanLen tm x.length S)) (fun q hq => ?_) ?_ + · rw [stepReg_scratch L second _ L.toWalkLayout.ruler_scratch] at h + exact ruler_of_holds _ _ _ h + · rw [stepCert_scratch L x dc Ps ds cOlds cNews tgt aOld aNew second s _ + L.toWalkLayout.ruler_scratch, stageBits] + simp only [L.toWalkLayout.role_ruler] + rw [rulerBlock_getElem _ q (by simpa using hq)] + · rw [rulerBlock_length, stepWidth_scratch L _ L.toWalkLayout.ruler_scratch, L.width_ruler] + have := one_le_walkScanLen tm x.length S + omega + +/-- **A step's registers make a well-formed scan.** The ruler spans the scan, and the blank that +stops the scan is the ruler tape's own — the guess writes up to the ruler's width and no further, +so a caller only has to know that the tape was blank there to begin with. -/ +theorem scanTape_of_step {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (dc : DirCodec) + (Ps : ℕ → SuccParams tm.Q kk) (ds : ℕ → Dir3) (cOlds cNews : ℕ → ℕ) (tgt : ℕ) + (aOld aNew : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (second : Bool) + (hs : TM.StageBlocks (stepWidth L) L.toWalkLayout.stepBlocks + (stepCert L x dc Ps ds cOlds cNews tgt aOld aNew second) g) + (s : ℕ) (W : Fin (jj + 2 + r + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) + (hh : ∀ i, 1 ≤ (W i).head) + (hr1 : ∀ p, p < L.toWalkLayout.stepBlocks → (W (stepReg L second p)).head = 1) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) + (hblank : (W (walkReg (L.toWalkLayout.reg L.toWalkLayout.rulerIdx))).cells + (walkScanLen tm x.length S + 1) = Γ.blank) : + TM.ScanTape (stepCells L second W) (walkScanLen tm x.length S) := by + have hlt : L.toWalkLayout.rulerIdx < L.toWalkLayout.stepBlocks := by + rw [WalkLayout.stepBlocks] + have := L.toWalkLayout.ruler_scratch + omega + obtain ⟨ginv, -, -, -, -⟩ := TM.guessBlocksTapes_spec (stepReg L second) + (fun p => walkReg_ne_last _) (stepWidth L) L.toWalkLayout.stepBlocks W hinv hh + (fun p q hp hq hpq => L.toWalkLayout.stepIdx_inj second p q hp hq + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt second p hp) + (L.toWalkLayout.stepIdx_lt second q hq) (walkReg_inj hpq))) + refine scanTape_of_ruler (stepCells L second W) (walkScanLen tm x.length S) + (fun i => (ginv (walkReg i)).1) (fun i q hq => (ginv (walkReg i)).2 q hq) (fun q h1 h2 => ?_) + ?_ + · rw [← L.toWalkLayout.ruler_zero] + exact ruler_of_step x L dc Ps ds cOlds cNews tgt aOld aNew g second hs s W hinv hh hr1 hgf + q h1 h2 + · have hbeyond := TM.guessBlocksTapes_beyond (stepReg L second) (fun p => walkReg_ne_last _) + (stepWidth L) L.toWalkLayout.stepBlocks W hinv hh + (fun p q hp hq hpq => L.toWalkLayout.stepIdx_inj second p q hp hq + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt second p hp) + (L.toWalkLayout.stepIdx_lt second q hq) (walkReg_inj hpq))) + L.toWalkLayout.rulerIdx hlt (walkScanLen tm x.length S + 1) ?_ + · rw [← L.toWalkLayout.ruler_zero] + show (TM.guessBlocksTapes (stepReg L second) (stepWidth L) L.toWalkLayout.stepBlocks W + (walkReg (L.toWalkLayout.reg L.toWalkLayout.rulerIdx))).cells _ = _ + rw [← stepReg_scratch L second _ L.toWalkLayout.ruler_scratch, hbeyond, + stepReg_scratch L second _ L.toWalkLayout.ruler_scratch, hblank] + · rw [hr1 _ hlt, stepWidth_scratch L _ L.toWalkLayout.ruler_scratch, L.width_ruler] + have := one_le_walkScanLen tm x.length S + omega + +/-- **A step advances the guess tape by exactly its own consumption**, so the guess-tape clause of +the walk's invariant is re-established one step further on. -/ +theorem guessFrom_after_step {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (second : Bool) (W : Fin (jj + 2 + r + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (g : ℕ → Bool) (s : ℕ) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (W (Fin.last (jj + 2 + r)))) : + TM.GuessFrom + (fun q => g ((s + 1) * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (TM.guessBlocksTapes (stepReg L second) (stepWidth L) L.toWalkLayout.stepBlocks W + (Fin.last (jj + 2 + r))) := by + have h := TM.guessFrom_after (stepReg L second) (fun p => walkReg_ne_last _) (stepWidth L) + L.toWalkLayout.stepBlocks W hinv hh + (fun p q hp hq hpq => L.toWalkLayout.stepIdx_inj second p q hp hq + (L.toWalkLayout.reg_inj _ _ (L.toWalkLayout.stepIdx_lt second p hp) + (L.toWalkLayout.stepIdx_lt second q hq) (walkReg_inj hpq))) _ hgf + intro q + have hq := h q + rw [hq] + refine congrArg Γ.ofBool (congrArg g ?_) + rw [Nat.succ_mul] + omega + +/-- **A stage advances the guess tape by exactly its own consumption.** So the guess-tape clause +of the invariant is re-established one stage further on. -/ +theorem guessFrom_after_stage {kk jj r : ℕ} {tm : NTM kk} {nn S wc : ℕ} + (L : WalkWidths kk jj tm nn S wc) (W : Fin (jj + 2 + r + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (g : ℕ → Bool) (s : ℕ) + (hgf : TM.GuessFrom + (fun q => g (s * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (W (Fin.last (jj + 2 + r)))) : + TM.GuessFrom + (fun q => g ((s + 1) * TM.guessOffset L.width L.toWalkLayout.blocks + q)) + (TM.guessBlocksTapes (fun p => walkReg (L.toWalkLayout.reg p)) L.width + L.toWalkLayout.blocks W (Fin.last (jj + 2 + r))) := by + have h := TM.guessFrom_after (fun p => walkReg (L.toWalkLayout.reg p)) + (fun p => walkReg_ne_last _) L.width L.toWalkLayout.blocks W hinv hh + (walkReg_reg_inj L) _ hgf + intro q + have hq := h q + rw [hq] + refine congrArg Γ.ofBool (congrArg g ?_) + rw [Nat.succ_mul] + omega + +/-! ## The walk loop's invariant + +After `j` iterations the counter names `j`, the code registers hold the `2j`-th code of the walk +— two steps per iteration — and the machine's own input head sits where that code's input head +does, which is what lets `TM.inMatchTM` check the guessed symbol against the real tape. -/ + +/-- **What holds between the steps of a walk.** The registers are parked and the ruler tape's +blank still stops the scan; the code the next step will check against sits in the family that step +retains; the machine's own input head is where that code says; and the guess tape is positioned at +the step's own share of the certificate. -/ +def WalkStepInv {kk jj r : ℕ} {tm : NTM kk} {S wc : ℕ} (x : List Bool) + (L : WalkWidths kk jj tm x.length S wc) (cOld : ℕ → Fin (jj + 1)) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (s : ℕ) : + TM.TapePred (jj + 2 + r + 1) := + fun inp work out => + (∀ i, (work i).StartInvariant) ∧ (∀ i, 1 ≤ (work i).head) ∧ + (∀ i : Fin (jj + 1), (work (walkReg i)).head = 1) ∧ + (work (walkReg (L.toWalkLayout.reg L.toWalkLayout.rulerIdx))).cells + (walkScanLen tm x.length S + 1) = Γ.blank ∧ + (∀ p, p < kk + 3 → HoldsBits (fun q i => (work (walkReg i)).cells q) 0 (cOld p) + (codeBlockScan tm x S (f s) p)) ∧ + inp = ⟨max (f s).2.1.val 1, (Tape.init (x.map Γ.ofBool)).cells⟩ ∧ + out.StartInvariant ∧ 1 ≤ out.head ∧ + TM.GuessFrom + (fun q => g (s * TM.guessOffset (stepWidth L) L.toWalkLayout.stepBlocks + q)) + (work (Fin.last (jj + 2 + r))) + +/-- The walk loop's invariant after `j` iterations. -/ +def WalkLoopInv {kk jj r : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cnt : Fin (jj + 1)) (wc : ℕ) (jold : ℕ → Fin (jj + 1)) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (w : ℕ → ℕ) (t : ℕ) (j : ℕ) : + TM.TapePred (jj + 2 + r + 1) := + fun inp work _out => + j < 2 ^ wc ∧ + HoldsBits (fun p i => (work i).cells p) 0 (walkReg cnt) (bitsOfLenLE wc j) ∧ + (∀ p, p < kk + 3 → HoldsBits (fun q i => (work i).cells q) 0 (walkReg (jold p)) + (codeBlockScan tm x S (f (2 * j)) p)) ∧ + inp = ⟨max (f (2 * j)).2.1.val 1, (Tape.init (x.map Γ.ofBool)).cells⟩ ∧ + TM.GuessFrom (fun q => g (j * walkGuessStride w t + q)) (work (Fin.last (jj + 2 + r))) + +/-- **The invariant pins the counter**, so `Complexity.counterLoop_hoareTime` applies to the +walk. -/ +theorem holdsCounter_of_walkLoopInv {kk jj r : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cnt : Fin (jj + 1)) (wc : ℕ) (jold : ℕ → Fin (jj + 1)) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (w : ℕ → ℕ) (t : ℕ) (j : ℕ) (inp : Tape) + (work : Fin (jj + 2 + r + 1) → Tape) (out : Tape) + (h : WalkLoopInv tm x S cnt wc jold f g w t j inp work out) : + HoldsCounter (walkReg cnt) wc j inp work out := + ⟨h.1, h.2.1⟩ + +/-- **The invariant says what symbol the simulated input head is over**, whenever that head is +off the marker. At the marker no machine can keep its own head in place, and none needs to: the +symbol there is `▷`, which the code's head field already says. -/ +theorem inSym_of_walkLoopInv {kk jj r : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cnt : Fin (jj + 1)) (wc : ℕ) (jold : ℕ → Fin (jj + 1)) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (w : ℕ → ℕ) (t : ℕ) (j : ℕ) (inp : Tape) + (work : Fin (jj + 2 + r + 1) → Tape) (out : Tape) + (h : WalkLoopInv tm x S cnt wc jold f g w t j inp work out) + (hne : (f (2 * j)).2.1.val ≠ 0) : inp.read = inSymOf tm x S (f (2 * j)) := by + rw [h.2.2.2.1, Tape.read, inSymOf] + show (Tape.init (x.map Γ.ofBool)).cells (max (f (2 * j)).2.1.val 1) = _ + rw [show max (f (2 * j)).2.1.val 1 = (f (2 * j)).2.1.val by omega] + +/-- **The machine's input head is never on the marker**, which is what lets a step read it. -/ +theorem inp_read_ne_start_of_walkLoopInv {kk jj r : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cnt : Fin (jj + 1)) (wc : ℕ) (jold : ℕ → Fin (jj + 1)) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (w : ℕ → ℕ) (t : ℕ) (j : ℕ) (inp : Tape) + (work : Fin (jj + 2 + r + 1) → Tape) (out : Tape) + (h : WalkLoopInv tm x S cnt wc jold f g w t j inp work out) : + inp.read ≠ Γ.start := by + rw [h.2.2.2.1] + show (Tape.init (x.map Γ.ofBool)).cells (max (f (2 * j)).2.1.val 1) ≠ Γ.start + exact Tape.init_ofBool_cells_ne_start x _ (le_max_right _ _) + +/-- **The invariant says what the guess tape still holds**, which is what lets an iteration find +the guesses it needs. -/ +theorem guessFrom_of_walkLoopInv {kk jj r : ℕ} (tm : NTM kk) (x : List Bool) (S : ℕ) + (cnt : Fin (jj + 1)) (wc : ℕ) (jold : ℕ → Fin (jj + 1)) + (f : ℕ → Code tm.Q kk x.length S) (g : ℕ → Bool) (w : ℕ → ℕ) (t : ℕ) (j : ℕ) (inp : Tape) + (work : Fin (jj + 2 + r + 1) → Tape) (out : Tape) + (h : WalkLoopInv tm x S cnt wc jold f g w t j inp work out) : + TM.GuessFrom (fun q => g (j * walkGuessStride w t + q)) (work (Fin.last (jj + 2 + r))) := + h.2.2.2.2 + +/-- **The blocks an iteration guesses are read off the stream.** The first stage of iteration `j` +starts at `j * walkGuessStride w t`, the second a stage further on. -/ +theorem walkGuessStride_split (w : ℕ → ℕ) (t j : ℕ) : + (j + 1) * walkGuessStride w t + = j * walkGuessStride w t + TM.guessOffset w t + TM.guessOffset w t := by + show (j + 1) * (2 * TM.guessOffset w t) + = j * (2 * TM.guessOffset w t) + TM.guessOffset w t + TM.guessOffset w t + rw [Nat.succ_mul] + omega + + +/-- **The walk loop.** Given a body that carries the invariant one step forward, and a test that +halts at `N`, the loop carries the initial code to the `N`-th code of the walk. The counter names +the loop's index, which is what makes the rule's variant decrease. -/ +theorem walkLoop_hoareTime (tm : NTM kk) (x : List Bool) (S : ℕ) {jj : ℕ} + (R : CodeRegs kk jj) (cnt : Fin (jj + 1)) (wc : ℕ) + (f : ℕ → Code tm.Q kk x.length S) (N b : ℕ) + (body test : TM (jj + 1)) {post : TM.TapePred (jj + 1)} + (hstep : ∀ j, j < N → ∀ inp work out, WalkInv tm x S R cnt wc f j inp work out → + ∃ inp' work' out' t, t ≤ b ∧ + (TM.loopTM body test).reachesIn t + ⟨(TM.loopTM body test).qstart, inp, work, out⟩ + ⟨(TM.loopTM body test).qstart, inp', work', out'⟩ ∧ + WalkInv tm x S R cnt wc f (j + 1) inp' work' out') + (hstop : ∀ inp work out, WalkInv tm x S R cnt wc f N inp work out → + ∃ c' t, t ≤ b ∧ + (TM.loopTM body test).reachesIn t + ⟨(TM.loopTM body test).qstart, inp, work, out⟩ c' ∧ + (TM.loopTM body test).halted c' ∧ post c'.input c'.work c'.output) : + (TM.loopTM body test).HoareTime (WalkInv tm x S R cnt wc f 0) post ((N + 1) * b) := + TM.loopTM_hoareTime_indexed body test + (idx := fun _ work _ => counterVal cnt wc work) + (fun j inp work out h => counterVal_of_walkInv tm x S R cnt wc f j inp work out h) + hstep hstop + +/-- **The counter reads back the value a counter predicate pins.** -/ +theorem counterVal_of_holdsCounter {jj : ℕ} (cnt : Fin (jj + 1)) (wc v : ℕ) + (inp : Tape) (work : Fin (jj + 1) → Tape) (out : Tape) + (h : HoldsCounter cnt wc v inp work out) : counterVal cnt wc work = v := by + obtain ⟨hv, hcnt⟩ := h + have hbits : (List.ofFn fun q : Fin wc => decide ((work cnt).cells (q.val + 1) = Γ.one)) + = bitsOfLenLE wc v := by + refine List.ext_getElem (by simp [bitsOfLenLE_length]) ?_ + intro q h1 h2 + have hq : q < wc := by simpa using h1 + have hc := hcnt q (by rw [bitsOfLenLE_length]; exact hq) + simp only [Nat.zero_add] at hc + simp only [List.getElem_ofFn] + show decide ((work cnt).cells (q + 1) = Γ.one) = _ + rw [hc] + cases (bitsOfLenLE wc v)[q]'(by rw [bitsOfLenLE_length]; exact hq) <;> simp [Γ.ofBool] + rw [counterVal, hbits, binValLE_bitsOfLenLE wc v hv] + +/-- **The increment check advances a counter.** A loop does not compute its next index: it +guesses it into a second register and checks it here. -/ +theorem counter_succ_of_plusOne {jj : ℕ} (cnt cnt' : Fin (jj + 1)) (wc u v : ℕ) + (inp : Tape) (work : Fin (jj + 1) → Tape) (out : Tape) + (hu : HoldsCounter cnt wc u inp work out) (hv : HoldsCounter cnt' wc v inp work out) + (hscan : (Scanner.plusOne jj cnt cnt').emit + ((Scanner.plusOne jj cnt cnt').run (fun p i => (work i).cells p) wc) = true) : + v = u + 1 := + (plusOne_of_holds (fun p i => (work i).cells p) cnt cnt' wc u v hu.1 hv.1 hu.2 hv.2).mp hscan + +/-- **A counter-driven loop.** Any invariant family whose members pin the counter to their index +satisfies the indexed loop rule — the counter names the index, so the rule's variant decreases. +The walk, the enumeration of codes and the enumeration of rounds all have this shape. -/ +theorem counterLoop_hoareTime {jj : ℕ} (cnt : Fin (jj + 1)) (wc : ℕ) + (E : ℕ → TM.TapePred (jj + 1)) + (hE : ∀ j inp work out, E j inp work out → HoldsCounter cnt wc j inp work out) + (N b : ℕ) (body test : TM (jj + 1)) {post : TM.TapePred (jj + 1)} + (hstep : ∀ j, j < N → ∀ inp work out, E j inp work out → + ∃ inp' work' out' t, t ≤ b ∧ + (TM.loopTM body test).reachesIn t + ⟨(TM.loopTM body test).qstart, inp, work, out⟩ + ⟨(TM.loopTM body test).qstart, inp', work', out'⟩ ∧ + E (j + 1) inp' work' out') + (hstop : ∀ inp work out, E N inp work out → + ∃ c' t, t ≤ b ∧ + (TM.loopTM body test).reachesIn t + ⟨(TM.loopTM body test).qstart, inp, work, out⟩ c' ∧ + (TM.loopTM body test).halted c' ∧ post c'.input c'.work c'.output) : + (TM.loopTM body test).HoareTime (E 0) post ((N + 1) * b) := + TM.loopTM_hoareTime_indexed body test + (idx := fun _ work _ => counterVal cnt wc work) + (fun j inp work out h => + counterVal_of_holdsCounter cnt wc j inp work out (hE j inp work out h)) + hstep hstop + +end Complexity diff --git a/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean b/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean new file mode 100644 index 00000000..fb9c9212 --- /dev/null +++ b/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean @@ -0,0 +1,281 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.BinArith +public import Complexitylib.Classes.Containments.Internal.FPBridge +public import Complexitylib.Encoding.DataEncode + +/-! +# The transcript encoding inside the polynomial-time algebra + +⚠️ Unreviewed by Bolton + +An interactive verifier reads `Complexity.Protocol.view`, which carries the transcript through +`DataEncode.bitstringEncode`. A machine walking the game tree therefore has to *build* that +encoding as it extends the transcript, one message at a time. + +The encoding is a parenthesized serialization, so it is a plain concatenation once the outer +brackets are stripped: `Complexity.encBody` is the concatenation of the per-message encodings, and +extending the transcript appends to it (`Complexity.encBody_append`). That is what makes the walk +possible — nothing has to be re-encoded when a message is added or removed. + +## Main definitions + +- `Complexity.encBit`, `Complexity.encMsg`, `Complexity.encBody` — the three layers +- `Complexity.encStep` — the scan computing a message's encoding + +## Main results + +- `Complexity.bitstringEncode_transcript` — the encoding, spelled out +- `Complexity.encBody_append` — a new message is appended +- `Complexity.encMsgFn_mem_FP` — a message can be encoded in polynomial time +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-! ## The three layers -/ + +/-- The encoding of a single bit. -/ +def encBit (b : Bool) : List Bool := if b then [false, false, true, true] else [false, true] + +/-- The encoding of one message. -/ +def encMsg (v : List Bool) : List Bool := false :: ((v.map encBit).flatten ++ [true]) + +/-- The concatenation of the messages' encodings — the body of a transcript's encoding. -/ +def encBody (τ : List (List Bool)) : List Bool := (τ.map encMsg).flatten + +theorem encBit_eq (b : Bool) : (DataEncode.encode b).toBits = encBit b := by + cases b <;> simp [DataEncode.encode, Data.toBits_l, encBit] + +theorem encMsg_eq (v : List Bool) : + (DataEncode.encode v).toBits = encMsg v := by + show (Data.l (v.map DataEncode.encode)).toBits = _ + rw [Data.toBits_l, encMsg, List.map_map] + have hmap : List.map (Data.toBits ∘ DataEncode.encode) v = v.map encBit := + List.map_congr_left fun b _ => encBit_eq b + rw [hmap] + +/-- **The transcript's encoding, spelled out.** -/ +theorem bitstringEncode_transcript (τ : List (List Bool)) : + DataEncode.bitstringEncode τ = false :: (encBody τ ++ [true]) := by + show (Data.l (τ.map DataEncode.encode)).toBits = _ + rw [Data.toBits_l, encBody, List.map_map] + have hmap : List.map (Data.toBits ∘ DataEncode.encode) τ = τ.map encMsg := + List.map_congr_left fun v _ => encMsg_eq v + rw [hmap] + +@[simp] theorem encBody_nil : encBody [] = [] := rfl + +/-- **A new message is appended.** Nothing already written has to change. -/ +@[simp] theorem encBody_append (τ : List (List Bool)) (v : List Bool) : + encBody (τ ++ [v]) = encBody τ ++ encMsg v := by + rw [encBody, encBody, List.map_append] + simp + +theorem encBody_append_two (τ : List (List Bool)) (v a : List Bool) : + encBody (τ ++ [v, a]) = encBody τ ++ encMsg v ++ encMsg a := by + have h : τ ++ [v, a] = (τ ++ [v]) ++ [a] := by simp + rw [h, encBody_append, encBody_append] + +theorem encBit_length_le (b : Bool) : (encBit b).length ≤ 4 := by + cases b <;> simp [encBit] + +theorem encMsg_length_le (v : List Bool) : (encMsg v).length ≤ 4 * v.length + 2 := by + rw [encMsg, List.length_cons, List.length_append, List.length_flatten, List.length_cons] + have h : ∀ l ∈ (v.map encBit).map List.length, l ≤ 4 := by + intro l hl + obtain ⟨y, hy, rfl⟩ := List.mem_map.mp hl + obtain ⟨b, _, rfl⟩ := List.mem_map.mp hy + exact encBit_length_le b + have := List.sum_le_card_nsmul _ 4 h + rw [List.length_map, List.length_map] at this + simp only [smul_eq_mul] at this + simp only [List.length_nil] + omega + +/-! ## Encoding a message is polynomial-time -/ + +/-- One step of the encoding scan: the bits emitted so far, and the message still to read. -/ +def encStep : List Bool × List Bool → List Bool × List Bool + | (acc, []) => (acc, []) + | (acc, b :: t) => (acc ++ encBit b, t) + +@[simp] theorem encStep_nil (acc : List Bool) : encStep (acc, []) = (acc, []) := rfl + +theorem encStep_cons (acc : List Bool) (b : Bool) (t : List Bool) : + encStep (acc, b :: t) = (acc ++ encBit b, t) := rfl + +/-- **The scan flattens the per-bit encodings.** -/ +theorem encStep_iterate_run (acc v : List Bool) : + encStep^[v.length] (acc, v) = (acc ++ (v.map encBit).flatten, []) := by + induction v generalizing acc with + | nil => simp + | cons b t ih => + rw [List.length_cons, Function.iterate_succ_apply, encStep_cons, ih] + simp + +theorem encStep_iterate_length (acc v : List Bool) (n : ℕ) : + (encStep^[n] (acc, v)).1.length + (encStep^[n] (acc, v)).2.length + ≤ acc.length + 4 * v.length := by + induction n generalizing acc v with + | zero => simp; omega + | succ n ih => + rw [Function.iterate_succ_apply] + cases v with + | nil => simpa using ih acc [] + | cons b t => + rw [encStep_cons] + have hb : (encBit b).length ≤ 4 := by cases b <;> simp [encBit] + have := ih (acc ++ encBit b) t + simp only [List.length_append, List.length_cons] at this ⊢ + omega + +/-! ## The packed scan -/ + +/-- The packed scan state. -/ +def encPack (acc rest : List Bool) : List Bool := pair acc rest + +@[simp] theorem encPack_length (acc rest : List Bool) : + (encPack acc rest).length = 2 * acc.length + rest.length + 2 := by + rw [encPack, pair_length] + omega + +/-- One step of the packed scan. -/ +def encStepP (z : List Bool) : List Bool := + selectHead (lenLeFlag (sndBlock z) [false]) + (encPack (fstBlock z ++ + selectHead (bit1 (sndBlock z)) [false, false, true, true] [false, true]) + ((sndBlock z).drop 1)) + z + +theorem encStepP_pack (acc rest : List Bool) : + encStepP (encPack acc rest) + = encPack (encStep (acc, rest)).1 (encStep (acc, rest)).2 := by + rw [encStepP, encPack] + simp only [fstBlock_pair, sndBlock_pair] + cases rest with + | nil => + have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl + rw [selectHead, hflag] + simp [encPack] + | cons b t => + have hflag : lenLeFlag (b :: t) [false] = [true] := + (lenLeFlag_eq_true_iff (b :: t) [false]).mpr (by simp) + rw [selectHead, hflag] + simp only [List.head?_cons, reduceIte] + rw [encStep_cons, encPack, bit1_cons] + cases b <;> simp [encBit, selectHead, encPack] + +theorem encStepP_iterate (s : List Bool × List Bool) (n : ℕ) : + encStepP^[n] (encPack s.1 s.2) = encPack (encStep^[n] s).1 (encStep^[n] s).2 := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply, encStepP_pack, ih (encStep s), + Function.iterate_succ_apply] + +theorem encStepP_iterate_args (acc rest : List Bool) (n : ℕ) : + encStepP^[n] (encPack acc rest) + = encPack (encStep^[n] (acc, rest)).1 (encStep^[n] (acc, rest)).2 := + encStepP_iterate (acc, rest) n + +/-- The flattened per-bit encodings, computed by the scan. -/ +def encFlat (v : List Bool) : List Bool := fstBlock (encStepP^[v.length] (encPack [] v)) + +theorem encFlat_eq (v : List Bool) : encFlat v = (v.map encBit).flatten := by + rw [encFlat, encStepP_iterate_args, encStep_iterate_run, encPack] + simp + +theorem encMsg_eq_encFlat (v : List Bool) : encMsg v = false :: (encFlat v ++ [true]) := by + rw [encMsg, encFlat_eq] + +theorem encStepP_mem_FP : encStepP ∈ FP := by + have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) + have hfst : (fun z : List Bool => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] + have hbit : (fun z => bit1 (sndBlock z)) ∈ FP := by + have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hsnd hone) + simpa [bit1] using this + have hdrop : (fun z => (sndBlock z).drop 1) ∈ FP := by + have := dropLenFn_mem_FP hone hsnd + simpa using this + exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hsnd hone) + (Cobham.pairFn_mem_FP + (Cobham.appendFn_mem_FP hfst + (Cobham.selectHeadFn_mem_FP hbit (constFn_mem_FP [false, false, true, true]) + (constFn_mem_FP [false, true]))) + hdrop) hid + +theorem encFlatFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => encFlat (a z)) ∈ FP := by + have hinit : (fun z => encPack [] (a z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP []) ha + have hwidth : (fun z => encPack (a z ++ a z ++ a z ++ a z) (a z)) ∈ FP := + Cobham.pairFn_mem_FP + (Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP ha ha) ha) ha) ha + have hbound : ∀ z, ∀ n ≤ (a z).length, + (encStepP^[n] (encPack [] (a z))).length + ≤ (encPack (a z ++ a z ++ a z ++ a z) (a z)).length := by + intro z n _ + rw [encStepP_iterate_args, encPack_length, encPack_length] + have := encStep_iterate_length [] (a z) n + simp only [List.length_nil, List.length_append] at this ⊢ + omega + have h := Cobham.iterate_mem_FP encStepP_mem_FP hinit ha hwidth hbound + have h1 := mem_FP_comp h Cobham.fstBlock_mem_FP + simpa [Function.comp, encFlat] using h1 + +theorem encMsgFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => encMsg (a z)) ∈ FP := by + have h : (fun z => false :: (encFlat (a z) ++ [true])) ∈ FP := by + have hcat := Cobham.appendFn_mem_FP (encFlatFn_mem_FP ha) (constFn_mem_FP [true]) + have := mem_FP_comp hcat (Cobham.cons_mem_FP false) + simpa [Function.comp] using this + exact mem_FP_of_eq h fun z => (encMsg_eq_encFlat (a z)).symm + +/-! ## Transcripts given as rounds -/ + +/-- A transcript, read off a list of rounds. This is the shape a stack holds: one frame per +round, carrying the verifier's message and the prover's reply. -/ +def flatRounds : List (List Bool × List Bool) → List (List Bool) + | [] => [] + | p :: ps => p.1 :: p.2 :: flatRounds ps + +@[simp] theorem flatRounds_nil : flatRounds [] = [] := rfl + +@[simp] theorem flatRounds_cons (p : List Bool × List Bool) + (ps : List (List Bool × List Bool)) : + flatRounds (p :: ps) = p.1 :: p.2 :: flatRounds ps := rfl + +@[simp] theorem flatRounds_length (ps : List (List Bool × List Bool)) : + (flatRounds ps).length = 2 * ps.length := by + induction ps with + | nil => rfl + | cons p ps ih => + rw [flatRounds_cons, List.length_cons, List.length_cons, ih, List.length_cons] + omega + +@[simp] theorem flatRounds_append (ps : List (List Bool × List Bool)) (v a : List Bool) : + flatRounds (ps ++ [(v, a)]) = flatRounds ps ++ [v, a] := by + induction ps with + | nil => rfl + | cons p ps ih => rw [List.cons_append, flatRounds_cons, ih, flatRounds_cons]; simp + +/-- The body of the encoding of a transcript given as rounds. -/ +def encBodyR (ps : List (List Bool × List Bool)) : List Bool := encBody (flatRounds ps) + +@[simp] theorem encBodyR_nil : encBodyR [] = [] := rfl + +@[simp] theorem encBodyR_append (ps : List (List Bool × List Bool)) (v a : List Bool) : + encBodyR (ps ++ [(v, a)]) = encBodyR ps ++ encMsg v ++ encMsg a := by + rw [encBodyR, encBodyR, flatRounds_append, encBody_append_two] + +end Complexity diff --git a/Complexitylib/Classes/Containments/NLSubsetCoNL.lean b/Complexitylib/Classes/Containments/NLSubsetCoNL.lean index aba707e7..b0561f4d 100644 --- a/Complexitylib/Classes/Containments/NLSubsetCoNL.lean +++ b/Complexitylib/Classes/Containments/NLSubsetCoNL.lean @@ -7,6 +7,8 @@ module public import Complexitylib.Classes.L public import Complexitylib.Classes.Containments.Defs public import Complexitylib.Classes.Containments.Internal.InductiveCounting +public import Complexitylib.Classes.Containments.Internal.SuccMachine +public import Complexitylib.Classes.Containments.Internal.CountingCert /-! # `NL ⊆ coNL` @@ -25,25 +27,55 @@ no accepting configuration is reachable. ## Progress -The two statements the argument turns on are proved. `NL_complement_characterization` says what -has to be certified: an input is outside the language exactly when *every* configuration the -bounded search reaches fails to be accepting — a universally quantified statement over the -rounds. `inductive_counting_certificate` says why guessing suffices: a subset of a round that is -at least as large as the round *is* the round, so a machine that has verified `r_i` distinct -members, and has not seen `c` among them, may conclude `c` is not in round `i`. That is how a -negative fact gets certified positively, with only the count `r_i` stored. +**The complement is now a certificate.** `NL_complement_certificate` says that an input is +outside the language exactly when the last round of the bounded search can be *listed* with none +of its members accepting — where a list counts as exhausting the round when its entries are +distinct members and there are at least as many of them as the round contains. That is +`inductive_counting_certificate` in the form a machine uses it: a negative fact certified +positively, by a count. + +The certificate is built so that a logarithmically bounded machine never holds any of it. + +- A list entry is checked by `NL_membership_is_walk`: a code lies in round `i` exactly when some + sequence of `i` steps from the start reaches it, each step staying put or moving to a successor. + A machine verifies that holding only the current code and the step index. +- The list itself is guessed one entry at a time and only *counted*; `NL_nonmembership_by_counting` + is what licenses concluding non-membership from absence once the count is reached. ## What the proof still needs -- The guessing procedure and its space accounting: for each round, cycle over all configurations, - guess membership, verify a guessed member by a guessed path, and compare the tally against the - stored `r_i`. The delicate part is that every branch either aborts or agrees on the count. -- Configurations enumerable in logarithmic space, which the coding of - `Complexitylib.Classes.Containments.Internal.ConfigCount` supplies. +Only the machine. It has to guess the certificate and check it, which is three nested bounded +loops — over the rounds, over the codes of a round, and over the steps of a walk — with a handful +of logarithmically wide registers: a round index, two counts, the code being tested, the code +being walked, and a step index. + +The machine is now to be built **deterministically**. `Complexity.NTM.exists_loadTape` turns a +deterministic machine whose guesses arrive on its last work tape into a nondeterministic one, so +the whole of `Complexitylib.Models.TuringMachine.Subroutines` — `TM.binaryFor`, `TM.binaryEq`, +`TM.binarySucc` and their Hoare contracts — applies unchanged, and the nondeterminism is confined +to a single tape read. `Complexitylib.Models.TuringMachine.GuessAssembly` supplies the parts: +`TM.liftLast` runs an existing subroutine while holding the guess tape still, and +`TM.liftLast_hoareTime` carries its contract across; `TM.guessReadTM` is the one-step primitive +that consumes a guess; and +`TM.guessProtocol_seqTM` / `TM.guessProtocol_loopTM` say the obligation survives composition. + +The registers it works on are laid out by `Complexity.codeCodec`: a configuration code as a +fixed-width bitstring, so that a register is a fixed number of cells and the enumeration over +configurations is one binary counter. `Complexity.BitCodec` assembles that layout field by field +and discharges the width and round-trip obligations once, and its decoder is total, so every +bitstring the counter reaches denotes some configuration — the ones outside the image simply +denote configurations no walk reaches. + +What remains is the machine itself: a successor check on those codes — decode, apply one +transition of the simulated machine, encode — the three nested loops over rounds, codes, and walk +steps, and the space accounting that keeps every register logarithmically wide. ## Main results - `NL_complement_characterization` — what the complement of an `NL` language says +- `NL_complement_certificate` — and the certificate that establishes it +- `NL_membership_is_walk` — a round member is reached by a walk a machine can follow +- `NL_nonmembership_by_counting` — absence from a full list is non-membership - `inductive_counting_certificate` — the counting principle that makes the guessing sound - `NL_subset_coNL_of_counting` — the containment, granted one machine @@ -83,6 +115,40 @@ theorem inductive_counting_certificate {k : ℕ} (tm : NTM k) (c₀ : Cfg k tm.Q NTM.reachSet_eq_of_ncard_le tm c₀ i hsub hcard +/-- **A round member is reached by a walk.** A code lies in round `i` exactly when some sequence +of `i` steps from the start reaches it, each step either staying put or moving to a successor. +This is the form the machine verifies: it holds only the current code and the step index, never +the walk. -/ +theorem NL_membership_is_walk {k : ℕ} (tm : NTM k) (x : List Bool) (S : ℕ) + (a₀ : Code tm.Q k x.length S) (i : ℕ) (a : Code tm.Q k x.length S) : + a ∈ NTM.reachCodes tm x S a₀ i ↔ + ∃ f : ℕ → Code tm.Q k x.length S, f 0 = a₀ ∧ f i = a ∧ + ∀ j < i, f (j + 1) = f j ∨ f (j + 1) ∈ NTM.codeSucc tm x S (f j) := + NTM.mem_reachCodes_iff_walk tm x S a₀ i a + +/-- **Absence from a full list is non-membership.** Once a machine has counted as many distinct +verified members of a round as the round contains, a code it has not seen is not in the round. -/ +theorem NL_nonmembership_by_counting {k : ℕ} {tm : NTM k} {x : List Bool} {S : ℕ} + {a₀ : Code tm.Q k x.length S} {i : ℕ} {l : List (Code tm.Q k x.length S)} + (h : NTM.RoundList tm x S a₀ i l) {a : Code tm.Q k x.length S} (ha : a ∉ l) : + a ∉ NTM.reachCodes tm x S a₀ i := + NTM.not_mem_of_roundList h ha + +/-- **The complement of an `NL` language, as a certificate.** An input is outside the language +exactly when the last round of the bounded search can be listed with none of its members +accepting. Every quantity is an explicit arithmetic function of the input length, and the list is +consumed one entry at a time — which is what a logarithmically bounded machine can do. -/ +theorem NL_complement_certificate {L : Language} (hL : L ∈ NL) : + ∃ (k : ℕ) (tm : NTM k) (C D A B : ℕ), + ∀ x : List Bool, x ∉ L ↔ + ∃ l : List (Code tm.Q k x.length (logWindow C D x.length)), + NTM.RoundList tm x (logWindow C D x.length) + (cfgCode x.length (logWindow C D x.length) (tm.initCfg x)) + (A * (x.length + 1) ^ B) l ∧ + ∀ a ∈ l, ¬ ((decodeCfg x (logWindow C D x.length) a).state = tm.qhalt ∧ + (decodeCfg x (logWindow C D x.length) a).output.cells 1 = Γ.one) := + NL_complement_certificate_internal hL + /-- **`NL ⊆ coNL`, reduced to the existence of one machine.** For a log-space machine `tm` — the space witness is part of the hypothesis — and a polynomial round bound, exhibit a nondeterministic log-space transducer deciding the *negative* condition, that no configuration the bounded search diff --git a/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean b/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean index ff2f4a2a..ad627f01 100644 --- a/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean +++ b/Complexitylib/Classes/Containments/NPSPACESubsetPSPACE.lean @@ -7,8 +7,8 @@ module public import Complexitylib.Classes.P.Defs public import Complexitylib.Classes.Containments.Defs public import Complexitylib.Classes.Containments.Internal.SavitchBound -public import Complexitylib.Classes.Containments.Internal.SpaceIterate -public import Complexitylib.Classes.Containments.Internal.SavitchStep +public import Complexitylib.Classes.Containments.Internal.SavitchAssemble +public import Complexitylib.Classes.Containments.PSPACESubsetNPSPACE public import Complexitylib.Classes.NP /-! @@ -24,64 +24,40 @@ and reusing the same space for the two subcalls costs `O(S)` bits per level and levels, so a machine using space `S` is simulated deterministically in space `O(S²)` — polynomial space is closed under this squaring. -## Progress - -The combinatorial core is done. `savitch_halving` below is the midpoint identity the recursion -turns on, in the form the machine uses it: a step bound of `2 ^ (i + 1)` splits into two -independent subproblems with bound `2 ^ i`, so the recursion has depth `i` and each level stores -exactly one midpoint configuration. `savitch_reaches_within_codes` supplies the base fact that -makes the depth finite: a walk longer than the number of configuration codes repeats a -configuration, so reachability is always witnessed within that many steps. - -`NPSPACE_bounded_reachability` puts the two together: membership in a language of `NPSPACE` is -reachability within `2 ^ q(|x|)` steps for an explicit polynomial `q`. Halving that bound -`q(|x|)` times reaches a single step, so the recursion depth is polynomial — and each level -stores one configuration, which a polynomially space-bounded machine can afford. - -## What the proof still needs - -A space-accounted implementation of the recursion. The route, following `NL ⊆ P`, is to write -the recursion as a *pure function* and let a general tool supply the machine: - -- Savitch's procedure is a stack machine. Its stack holds one frame per level — a level counter, - the two endpoints and the midpoint being tried — so it is polynomially bounded, and one step of - it (push, pop, or advance the midpoint) is a polynomial-time function of the stack, computable - with the block toolkit of `Complexitylib.Classes.Containments.Internal.BlockMember` and the - encoded machine step `Complexity.nstepFn` that `NL ⊆ P` already uses. -- What is missing is the tool that turns such a function into a `PSPACE` machine: *iterating a - polynomial-time function on a polynomially bounded state is in `PSPACE`*, however many - iterations it takes. `Complexitylib.Classes.Containments.Internal.SpaceIterate` is building it. - The iteration machinery is already there — `Cobham.iterSetup` and `Cobham.iterBody` from the - completeness half of Cobham's theorem apply the function once and restore the entry shape — and - only the loop driver has to change: `TM.forRegTM` counts in unary, which cannot reach - `2 ^ poly`, so the loop runs against a binary counter, exactly as in `PP ⊆ PSPACE` and - `PH ⊆ PSPACE`. Its window comes from `TM.loopTM_keepsWindowOn_phases`, with each iteration's - window read off that iteration's (polynomial) running time. - -This tool is what `IP ⊆ PSPACE` will need too: a game-tree value is another -polynomially-bounded stack recursion. +## How the proof runs + +Not as a machine, but as a *pure function iterated in place*, exactly as `NL ⊆ P` was done: + +- `Complexity.savStep` (`Internal.SavitchStep`) is one step of Savitch's stack machine, written + inside the polynomial-time algebra on a single bitstring — a done flag, an answer, the block + ruler, a returning value, and a stack of frames, each frame carrying a level, two endpoints and + the midpoint currently being tried. +- `Complexity.Sav.step` (`Internal.SavitchSem`) is the same recursion on an inductive state, where + it can be reasoned about, and `Complexity.savStep_encSst` proves the square commutes. + `Complexity.Sav.run_frame` is the heart: a pushed frame is popped again carrying its value + within `Complexity.Sav.runBound` steps — by induction on the level, and inside a level by + induction on the work the frame has left. +- `Complexity.accB_cfgCode` (`Internal.SavitchReach`) identifies the value the recursion returns + with reachability in the configuration graph: the enumeration of midpoints is *every* string of + the code width, and a code has exactly that width. +- `Complexity.SpaceIter.mem_PSPACE_of_iterate` supplies the machine: iterating a polynomial-time + function on a polynomially bounded state is in `PSPACE`, however many iterations it takes. The + iteration count is `2 ^ poly` — `Complexity.Sav.runBound_le` — which is exactly what a binary + counter can drive. ## Main results - `savitch_halving` — the midpoint recursion at a halved step bound - `savitch_reaches_within_codes` — reachability is witnessed within the number of codes - `NPSPACE_bounded_reachability` — membership is reachability within `2 ^ poly` steps -- `NPSPACE_subset_PSPACE_of_recursion` — the containment, granted one machine - -## TODO - -- Finish `Internal.SpaceIterate`, program Savitch's stack step as a polynomial-time function, - and combine with `PSPACE_subset_NPSPACE` for `PSPACE = NPSPACE`. +- `NPSPACE_subset_PSPACE` — **Savitch's theorem** +- `PSPACE_eq_NPSPACE` — hence the two classes coincide -/ @[expose] public section namespace Complexity -/-- **`NPSPACE ⊆ PSPACE`** (Savitch): halving the path length recursively simulates a -nondeterministic space-`S` machine deterministically in space `O(S²)`. -/ -def NPSPACESubsetPSPACE : Prop := NPSPACE ⊆ PSPACE - /-- **The recursion Savitch's machine runs.** A step bound of `2 ^ (i + 1)` is met exactly when some midpoint configuration is reachable within `2 ^ i` steps and reaches the target within `2 ^ i` steps. Recursing on `i` costs one stored midpoint per level and bottoms out at `i = 0`, @@ -113,29 +89,14 @@ theorem NPSPACE_bounded_reachability {L : Language} (hL : L ∈ NPSPACE) : tm.halted c ∧ c.output.cells 1 = Γ.one := NPSPACE_bounded_reachability_internal hL -/-- Savitch's theorem settles the equality, given the immediate inclusion. -/ -theorem PSPACE_eq_NPSPACE_of (h : NPSPACESubsetPSPACE) (h' : PSPACE ⊆ NPSPACE) : - PSPACE = NPSPACE := - subset_antisymm h' h - - -/-- **`NPSPACE ⊆ PSPACE`, reduced to the existence of one machine.** For a space-bounded machine -`tm` — the space witness is part of the hypothesis — and a polynomial `q`, exhibit a deterministic -machine keeping a polynomial window that decides whether an accepting configuration is reachable -within `2 ^ q(|x|)` steps. `savitch_halving` is the recursion that makes that search affordable; -implementing it with exact space accounting is what remains. -/ -theorem NPSPACE_subset_PSPACE_of_recursion - (h : ∀ (k : ℕ) (tm : NTM k) (S : ℕ → ℕ) (L₀ : Language) (m : ℕ) (q : Polynomial ℕ), - tm.DecidesInSpace L₀ S → S =O (· ^ m) → - ∃ (k' : ℕ) (M : TM k') (r : Polynomial ℕ), - (∀ (x : List Bool) (c' : Cfg k' M.Q), M.reaches (M.initCfg x) c' → - c'.WithinDecisionSpace x.length (r.eval x.length)) ∧ - (∀ x : List Bool, ∃ c', M.reaches (M.initCfg x) c' ∧ M.halted c' ∧ - ((∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ - c.output.cells 1 = Γ.one) → c'.output.cells 1 = Γ.one) ∧ - ((¬ ∃ c, tm.ReachesCfgLe (2 ^ q.eval x.length) (tm.initCfg x) c ∧ tm.halted c ∧ - c.output.cells 1 = Γ.one) → c'.output.cells 1 = Γ.zero))) : - NPSPACE ⊆ PSPACE := - NPSPACE_subset_PSPACE_of_recursion_internal h +/-- **`NPSPACE ⊆ PSPACE`** (Savitch): halving the path length recursively simulates a +nondeterministic space-`S` machine deterministically in space `O(S²)`. -/ +theorem NPSPACE_subset_PSPACE : NPSPACE ⊆ PSPACE := + NPSPACE_subset_PSPACE_internal + +/-- **`PSPACE = NPSPACE`.** Savitch's theorem settles the equality: the reverse inclusion is +immediate, since a deterministic machine is a nondeterministic one that ignores its choices. -/ +theorem PSPACE_eq_NPSPACE : PSPACE = NPSPACE := + subset_antisymm PSPACE_subset_NPSPACE NPSPACE_subset_PSPACE end Complexity diff --git a/Complexitylib/Classes/Containments/PSPACESubsetIP.lean b/Complexitylib/Classes/Containments/PSPACESubsetIP.lean index 60acf607..b91c8588 100644 --- a/Complexitylib/Classes/Containments/PSPACESubsetIP.lean +++ b/Complexitylib/Classes/Containments/PSPACESubsetIP.lean @@ -39,8 +39,8 @@ namespace Complexity /-- **`PSPACE ⊆ IP`** (Shamir): arithmetize a quantified Boolean formula and run sum-check. -/ def PSPACESubsetIP : Prop := PSPACE ⊆ IP -/-- The two halves together are Shamir's theorem. -/ -theorem IP_eq_PSPACE_of (h : IPSubsetPSPACE) (h' : PSPACESubsetIP) : IP = PSPACE := - subset_antisymm (h : IP ⊆ PSPACE) (h' : PSPACE ⊆ IP) +/-- The two halves together are Shamir's theorem; the first is `IP_subset_PSPACE`. -/ +theorem IP_eq_PSPACE_of (h' : PSPACESubsetIP) : IP = PSPACE := + subset_antisymm IP_subset_PSPACE (h' : PSPACE ⊆ IP) end Complexity diff --git a/Complexitylib/Classes/Interactive.lean b/Complexitylib/Classes/Interactive.lean index f684a130..420908ea 100644 --- a/Complexitylib/Classes/Interactive.lean +++ b/Complexitylib/Classes/Interactive.lean @@ -52,10 +52,12 @@ The three classes differ in who speaks when: Completeness `2/3` and soundness `1/3` are hard-wired, as in `Complexitylib.Classes.Randomized`. Message lengths are bounded by -`Protocol.msgLen`, and soundness in `IP` quantifies over the strategies obeying -that bound (`ProverStrategy.Bounded`): an unbounded message would blow up the -transcript the polynomial-time verifier has to read. The prover is adaptive — -it is a function of the transcript, not a single witness string. +`Protocol.msgLen` — the prover's by `ProverStrategy.Bounded`, which soundness in +`IP` quantifies over, and the verifier's by `Protocol.vmsg_len`. An unbounded +message would blow up the transcript the polynomial-time verifier has to read, +and after polynomially many rounds the verifier would no longer be polynomial in +the input at all. The prover is adaptive — it is a function of the transcript, +not a single witness string. ## TODO @@ -119,21 +121,36 @@ def ProverStrategy := Transcript → List Bool def ProverStrategy.Bounded (S : ProverStrategy) (m : ℕ) : Prop := ∀ τ : Transcript, (S τ).length ≤ m +/-- The encoded view handed to the verifier: the input, its coins, and the +transcript so far. -/ +def protocolView (x r : List Bool) (τ : Transcript) : List Bool := + pair (pair x r) (DataEncode.bitstringEncode τ) + /-- An interactive protocol: a round count, a private-coin count, a message-length bound, the verifier's next message as a polynomial-time function of the encoded input, coins and transcript, and its final verdict as a -polynomial-time predicate of the same. -/ +polynomial-time predicate of the same. + +`msgLen` bounds *both* sides' messages: the prover's through +`ProverStrategy.Bounded`, the verifier's through `vmsg_len`. Bounding the +verifier is not a convenience — without it the transcript grows by a polynomial +each round, so after polynomially many rounds the view, and with it the +verifier's own running time, is no longer polynomial in the input. -/ structure Protocol where /-- Number of rounds, as a function of the input length. -/ rounds : ℕ → ℕ /-- Number of private coins, as a function of the input length. -/ coins : ℕ → ℕ - /-- Bound on the length of the prover's messages. -/ + /-- Bound on the length of either side's messages. -/ msgLen : ℕ → ℕ /-- The verifier's next message, computed from `pair (pair x r) ⌜τ⌝`. -/ vmsg : List Bool → List Bool /-- That computation is polynomial-time. -/ vmsg_mem : vmsg ∈ FP + /-- The verifier's messages respect the length bound, so the transcript stays + polynomially long however many rounds are played. -/ + vmsg_len : ∀ (x r : List Bool) (τ : Transcript), + (vmsg (protocolView x r τ)).length ≤ msgLen x.length /-- The verifier's final verdict, on `pair (pair x r) ⌜τ⌝`. -/ verdict : Language /-- That verdict is polynomial-time decidable. -/ @@ -143,8 +160,7 @@ namespace Protocol /-- The encoded view handed to the verifier: the input, its coins, and the transcript so far. -/ -def view (x r : List Bool) (τ : Transcript) : List Bool := - pair (pair x r) (DataEncode.bitstringEncode τ) +abbrev view (x r : List Bool) (τ : Transcript) : List Bool := protocolView x r τ /-- The transcript after `n` rounds of `prot` on input `x` with coins `r` against the strategy `S`: each round appends the verifier's message and then @@ -170,13 +186,19 @@ noncomputable def acceptEvent (prot : Protocol) (S : ProverStrategy) (x : List B end Protocol /-- **IP**: languages with an interactive proof system whose round count, coin -count and message lengths are polynomially bounded. Completeness asks for one +count and message lengths are *given by polynomials*. Completeness asks for one strategy convincing the verifier with probability at least `2/3`; soundness -bounds every length-respecting strategy by `1/3`. -/ +bounds every length-respecting strategy by `1/3`. + +The three counts are polynomials rather than merely polynomially bounded because +a verifier has to *know* them: it must stop after the right number of rounds and +read the right number of coins. An arbitrary polynomially bounded `ℕ → ℕ` need +not be computable at all, and a protocol carrying one would let the class contain +undecidable languages. -/ def IP : Set Language := - {L | ∃ (prot : Protocol) (p : Polynomial ℕ), - (∀ n, prot.rounds n ≤ p.eval n) ∧ (∀ n, prot.coins n ≤ p.eval n) ∧ - (∀ n, prot.msgLen n ≤ p.eval n) ∧ + {L | ∃ (prot : Protocol) (rp cp mp : Polynomial ℕ), + (∀ n, prot.rounds n = rp.eval n) ∧ (∀ n, prot.coins n = cp.eval n) ∧ + (∀ n, prot.msgLen n = mp.eval n) ∧ (∀ x ∈ L, ∃ S : ProverStrategy, S.Bounded (prot.msgLen x.length) ∧ 2 / 3 ≤ eventProb (prot.acceptEvent S x)) ∧ (∀ x ∉ L, ∀ S : ProverStrategy, S.Bounded (prot.msgLen x.length) → diff --git a/Complexitylib/Models.lean b/Complexitylib/Models.lean index f01c8323..780f8aae 100644 --- a/Complexitylib/Models.lean +++ b/Complexitylib/Models.lean @@ -11,6 +11,9 @@ public import Complexitylib.Models.TuringMachine.Trace.DetPrefix public import Complexitylib.Models.TuringMachine.SingleTape public import Complexitylib.Models.TuringMachine.Branch public import Complexitylib.Models.TuringMachine.ChoiceTape +public import Complexitylib.Models.TuringMachine.GuessTape +public import Complexitylib.Models.TuringMachine.GuessStream +public import Complexitylib.Models.TuringMachine.GuessAssembly public import Complexitylib.Models.TuringMachine.Combinators public import Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork public import Complexitylib.Models.TuringMachine.Combinators.ForInput @@ -30,6 +33,7 @@ public import Complexitylib.Models.TuringMachine.Experimental.BinaryRoutine.Spac public import Complexitylib.Models.TuringMachine.Tape.Encoding public import Complexitylib.Models.TuringMachine.Subroutines public import Complexitylib.Models.TuringMachine.Subroutines.BinaryAdd +public import Complexitylib.Models.TuringMachine.Subroutines.InputMatch public import Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst public import Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy public import Complexitylib.Models.TuringMachine.Subroutines.BinaryEq @@ -49,6 +53,7 @@ public import Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput public import Complexitylib.Models.TuringMachine.Subroutines.PairEmit public import Complexitylib.Models.TuringMachine.Subroutines.PairValidate public import Complexitylib.Models.TuringMachine.Subroutines.PairSplit +public import Complexitylib.Models.TuringMachine.Subroutines.Scan public import Complexitylib.Models.TuringMachine.Subroutines.ScanRight public import Complexitylib.Models.TuringMachine.Subroutines.ResetBinary public import Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany diff --git a/Complexitylib/Models/TuringMachine/GuessAssembly.lean b/Complexitylib/Models/TuringMachine/GuessAssembly.lean new file mode 100644 index 00000000..5fae3f52 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/GuessAssembly.lean @@ -0,0 +1,1375 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.GuessStream +public import Complexitylib.Models.TuringMachine.Subroutines.ParkRewind +public import Complexitylib.Models.TuringMachine.Hoare +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps + +/-! +# Assembling a machine that guesses + +`Complexitylib.Models.TuringMachine.GuessStream` reduces building a nondeterministic machine to +building a deterministic one that satisfies `TM.GuessProtocol` on its last work tape. This file +supplies the parts. + +`TM.liftLast` puts an ordinary machine to work on the first tapes and leaves the guess tape +untouched, so every existing subroutine can be used verbatim. `TM.GuessProtocol` is then closed +under `TM.seqTM` and `TM.loopTM`, which is what lets the guessing and the not-guessing be +assembled into one machine: all three of its conditions are pointwise properties of the transition +function, and the combinators' own steps preserve every tape they are not driving. + +## Main definitions + +- `TM.liftLast` — run a machine on the first work tapes, holding the last one still +- `TM.guessReadTM` — copy the guess cell onto a work tape and advance the guess head +- `TM.guessWriteTM` — the same, advancing the target head too, so a block of guesses can be + written +- `TM.guessBlockTM` — a fixed number of those in sequence +- `TM.guessBlocksTM` — and a block written into each of several registers +- `TM.guessThenTM` — guess some blocks, then run a guess-free machine on them +- `TM.guessStageTM` — and the stage every construction is built from: guess, then rewind the + guessed registers so a scan can read them +- `TM.guessWriteTapes`, `TM.guessBlockTapes` — the tapes one guess-write, and a block of them, + leave behind + +## Main results + +- `TM.guessProtocol_liftLast` — a lifted machine never consults the guess tape +- `TM.liftLast_reachesIn` — and its runs are the original's +- `TM.lift4`, `TM.lift4_hoareTime` — the same, four tapes at a time +- `TM.guessProtocol_seqTM`, `TM.guessProtocol_loopTM` — the protocol survives composition +- `TM.guessProtocol_guessReadTM`, `TM.guessReadTM_stepCfg`, + `TM.guessProtocol_guessWriteTM`, `TM.guessWriteTM_stepCfg` — what the primitives do +- `TM.guessProtocol_guessBlockTM`, `TM.guessProtocol_guessBlocksTM`, + `TM.guessProtocol_guessThenTM` — and these respect the protocol +- `TM.skipTM_hoareTime'`, `TM.guessBlocksTM_hoareTime`, `TM.guessThenTM_hoareTime` — and their + contracts +- `TM.guessWriteTM_hoareTime`, `TM.guessBlockTM_hoareTime` — their contracts +- `TM.guessWriteTapes_last`, `TM.guessWriteTapes_target`, `TM.guessWriteTapes_other` — what one + guess-write does to each tape, off the left marker +- `TM.guessWriteTapes_target_head`, `TM.guessWriteTapes_target_cells`, + `TM.guessWriteTapes_target_cells_ne` — where the guessed bit lands +- `TM.guessWriteTapes_startInvariant`, `TM.guessWriteTapes_head_pos` — and that the invariants + survive it +- `TM.GuessFrom`, `TM.guessFrom_after` — what the guess tape still holds, and that a stage + consumes a prefix and leaves the rest +- `TM.guessBlocksTapes_spec` — what several blocks leave behind, when the registers are distinct +- `TM.guessList`, `TM.guessList_getElem` — the guess stream that realizes a family of blocks +- `TM.StageBlocks`, `TM.exists_stageBlocks`, `TM.blocks_of_stageBlocks` — and one that feeds every + stage of a loop, with each stage reading its own blocks off it +- `TM.guessBlockTapes_spec` — what a whole block leaves behind: both heads advanced by the number + of bits, those bits on the target, nothing else touched +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k m : ℕ} + +/-! ## Lifting a machine past the guess tape -/ + +/-- Run `D` on the first `m` work tapes, writing the last one back unchanged and holding its head +still. -/ +def liftLast (D : TM m) : TM (m + 1) where + Q := D.Q + qstart := D.qstart + qhalt := D.qhalt + δ q iHead wHeads oHead := + let r := D.δ q iHead (fun i => wHeads i.castSucc) oHead + (r.1, Fin.snoc r.2.1 (readBackWrite (wHeads (Fin.last m))), r.2.2.1, r.2.2.2.1, + Fin.snoc r.2.2.2.2.1 (idleDir (wHeads (Fin.last m))), r.2.2.2.2.2) + δ_right_of_start := by + intro q iHead wHeads oHead + have h := D.δ_right_of_start q iHead (fun i => wHeads i.castSucc) oHead + dsimp only at h ⊢ + refine ⟨h.1, fun i => ?_, h.2.2⟩ + refine Fin.lastCases ?_ ?_ i + · intro hs + rw [Fin.snoc_last] + exact idleDir_right_of_start hs + · intro j hj + rw [Fin.snoc_castSucc] + exact h.2.1 j hj + +@[simp] theorem liftLast_qhalt (D : TM m) : (liftLast D).qhalt = D.qhalt := rfl + +@[simp] theorem liftLast_qstart (D : TM m) : (liftLast D).qstart = D.qstart := rfl + +/-- A lifted machine never consults the guess tape, so it advances nowhere. -/ +theorem guessProtocol_liftLast (D : TM m) : GuessProtocol (liftLast D) (fun _ => false) := by + refine ⟨fun q _ iHead wHeads oHead => ?_, fun q _ iHead wHeads oHead h => ?_, + fun q _ _ iHead ww oHead g g' => ?_⟩ + · simp [liftLast] + · simp [liftLast, idleDir, h] + · simp only [visible, liftLast, Fin.snoc_castSucc] + +/-- One step of a lifted machine is one step of the original, with the guess tape untouched. -/ +theorem liftLast_stepCfg (D : TM m) (c : Cfg m D.Q) (τ : Tape) (hτ : τ.read ≠ Γ.start) : + (liftLast D).stepCfg (NTM.attach c τ) = NTM.attach (D.stepCfg c) τ := by + refine Cfg.ext ?_ ?_ ?_ ?_ + · simp [TM.stepCfg, liftLast, NTM.attach] + · simp [TM.stepCfg, liftLast, NTM.attach] + · funext i + refine Fin.lastCases ?_ ?_ i + · simp only [TM.stepCfg, liftLast, NTM.attach, Fin.snoc_last] + rw [writeAndMove_readBack _ hτ, idleDir, if_neg hτ] + rfl + · intro j + simp [TM.stepCfg, liftLast, NTM.attach] + · simp [TM.stepCfg, liftLast, NTM.attach] + +/-- **A run of a lifted machine is a run of the original.** -/ +theorem liftLast_reachesIn (D : TM m) (τ : Tape) (hτ : τ.read ≠ Γ.start) : + ∀ (t : ℕ) {c c' : Cfg m D.Q}, D.reachesIn t c c' → + (liftLast D).reachesIn t (NTM.attach c τ) (NTM.attach c' τ) := by + intro t + induction t with + | zero => + intro c c' h + rw [reachesIn_zero_iff] at h + subst h + exact reachesIn.zero + | succ t ih => + intro c c' h + rw [reachesIn_succ_iff] at h + obtain ⟨c₁, hstep, hrest⟩ := h + have hne : c.state ≠ D.qhalt := by + intro hq + unfold TM.step at hstep + rw [if_pos hq] at hstep + exact absurd hstep (by simp) + have hb : D.stepCfg c = c₁ := by + rw [step_of_not_halted D hne] at hstep + exact Option.some.inj hstep + subst hb + refine reachesIn.step ?_ (ih hrest) + rw [step_of_not_halted (liftLast D) hne, liftLast_stepCfg D c τ hτ] + rfl + +/-- The starting configuration of a lifted machine is the original's with the guess tape +attached. -/ +theorem liftLast_initCfg (D : TM m) (inp out : Tape) (work : Fin (m + 1) → Tape) : + ({ state := (liftLast D).qstart, input := inp, work := work, output := out } : + Cfg (m + 1) (liftLast D).Q) + = NTM.attach + { state := D.qstart + input := inp + work := fun i => work i.castSucc + output := out } (work (Fin.last m)) := by + refine Cfg.ext rfl rfl ?_ rfl + exact (Fin.snoc_init_self work).symm + +/-- **A Hoare triple for a lifted machine.** Everything the original guarantees still holds, and +the guess tape comes out exactly as it went in. -/ +theorem liftLast_hoareTime (D : TM m) {pre post : TapePred m} {bound : ℕ} + (h : D.HoareTime pre post bound) (τ : Tape) (hτ : τ.read ≠ Γ.start) : + (liftLast D).HoareTime + (fun inp work out => work (Fin.last m) = τ ∧ pre inp (fun i => work i.castSucc) out) + (fun inp work out => work (Fin.last m) = τ ∧ post inp (fun i => work i.castSucc) out) + bound := by + rintro inp work out ⟨hlast, hpre⟩ + obtain ⟨c', t, hle, hreach, hhalt, hpost⟩ := h inp (fun i => work i.castSucc) out hpre + refine ⟨NTM.attach c' τ, t, hle, ?_, hhalt, ?_, ?_⟩ + · rw [liftLast_initCfg D inp out work, hlast] + exact liftLast_reachesIn D τ hτ t hreach + · simp [NTM.attach] + · simpa [NTM.attach] using hpost + +/-- Lift a machine past four fresh tapes, holding them still. Four at a time because a check's +block is four tapes wide. -/ +def lift4 (D : TM m) : TM (m + 4) := + liftLast (liftLast (liftLast (liftLast D))) + +/-- A lifted-by-four machine never consults the last tape. -/ +theorem guessProtocol_lift4 (D : TM m) : + GuessProtocol (lift4 D) (fun _ => false) := + guessProtocol_liftLast _ + +/-- **A lifted-by-four machine's contract.** Four fresh tapes come through untouched. -/ +theorem lift4_hoareTime (D : TM m) {pre post : TapePred m} {b : ℕ} + (h : D.HoareTime pre post b) (τ₁ τ₂ τ₃ τ₄ : Tape) + (h₁ : τ₁.read ≠ Γ.start) (h₂ : τ₂.read ≠ Γ.start) (h₃ : τ₃.read ≠ Γ.start) + (h₄ : τ₄.read ≠ Γ.start) : + (lift4 D).HoareTime + (fun inp work out => work (Fin.last (m + 3)) = τ₄ ∧ + (fun i => work i.castSucc) (Fin.last (m + 2)) = τ₃ ∧ + (fun i => work i.castSucc.castSucc) (Fin.last (m + 1)) = τ₂ ∧ + (fun i => work i.castSucc.castSucc.castSucc) (Fin.last m) = τ₁ ∧ + pre inp (fun i => work i.castSucc.castSucc.castSucc.castSucc) out) + (fun inp work out => work (Fin.last (m + 3)) = τ₄ ∧ + (fun i => work i.castSucc) (Fin.last (m + 2)) = τ₃ ∧ + (fun i => work i.castSucc.castSucc) (Fin.last (m + 1)) = τ₂ ∧ + (fun i => work i.castSucc.castSucc.castSucc) (Fin.last m) = τ₁ ∧ + post inp (fun i => work i.castSucc.castSucc.castSucc.castSucc) out) + b := + liftLast_hoareTime _ (liftLast_hoareTime _ + (liftLast_hoareTime _ (liftLast_hoareTime D h τ₁ h₁) τ₂ h₂) τ₃ h₃) τ₄ h₄ + +/-- Lift a machine past `r` fresh tapes, holding them still. The original tapes +keep their indices — `Fin.castAdd r` — and the fresh ones are appended. + +`TM.liftTM` in `Models/TuringMachine/Lift.lean` widens a machine the same way, +but its interface carries *blank* extra tapes, for lifting whole decision +procedures. This one is the iterated `liftLast`, so its Hoare rule below carries +arbitrary extra tapes through untouched — what an assembled subroutine needs. -/ +def liftMany (D : TM m) : (r : ℕ) → TM (m + r) + | 0 => D + | r + 1 => liftLast (liftMany D r) + +/-- **A padded machine's contract.** The `r` fresh tapes come through +untouched, and the original tapes keep their meaning under `Fin.castAdd`. -/ +theorem liftMany_hoareTime (D : TM m) {pre post : TapePred m} {b : ℕ} + (h : D.HoareTime pre post b) : + ∀ (r : ℕ) (τ : Fin r → Tape), (∀ i, (τ i).read ≠ Γ.start) → + (liftMany D r).HoareTime + (fun inp work out => (∀ i, work (Fin.natAdd m i) = τ i) ∧ + pre inp (fun i => work (Fin.castAdd r i)) out) + (fun inp work out => (∀ i, work (Fin.natAdd m i) = τ i) ∧ + post inp (fun i => work (Fin.castAdd r i)) out) + b := by + intro r + induction r with + | zero => + intro τ _ + refine TM.HoareTime.consequence (h := h) ?_ ?_ (Nat.le_refl b) + · rintro inp work out ⟨-, hpre⟩ + simpa only [Fin.castAdd_zero, Fin.cast_eq_self] using hpre + · intro inp work out hpost + exact ⟨fun i => absurd i.isLt (Nat.not_lt_zero i.val), by + simpa only [Fin.castAdd_zero, Fin.cast_eq_self] using hpost⟩ + | succ r ih => + intro τ hτ + have hlift := liftLast_hoareTime (liftMany D r) + (ih (fun i => τ i.castSucc) fun i => hτ _) (τ (Fin.last r)) + (hτ (Fin.last r)) + have hnat : ∀ (work : Fin (m + r + 1) → Tape) (i : Fin (r + 1)), + work (Fin.natAdd m i) = + (Fin.snoc (fun j : Fin r => work (Fin.natAdd m j).castSucc) + (work (Fin.last (m + r))) : Fin (r + 1) → Tape) i := by + intro work i + refine Fin.lastCases ?_ ?_ i + · rw [Fin.snoc_last] + congr 1 + · intro j + rw [Fin.snoc_castSucc] + congr 1 + have hcast : ∀ (work : Fin (m + r + 1) → Tape) (i : Fin m), + work (Fin.castAdd (r + 1) i) = work (Fin.castAdd r i).castSucc := by + intro work i + congr 1 + refine TM.HoareTime.consequence (h := hlift) ?_ ?_ (Nat.le_refl b) + · rintro inp work out ⟨hfresh, hpre⟩ + refine ⟨?_, ?_, ?_⟩ + · rw [← hfresh (Fin.last r)] + exact congrArg work (Fin.ext (by simp)) + · intro i + have := hfresh i.castSucc + rw [hnat work i.castSucc, Fin.snoc_castSucc] at this + exact this + · simpa only [hcast work] using hpre + · rintro inp work out ⟨hlast, hfresh, hpost⟩ + refine ⟨?_, ?_⟩ + · intro i + refine Fin.lastCases ?_ ?_ i + · rw [hnat work (Fin.last r), Fin.snoc_last, hlast] + · intro j + rw [hnat work j.castSucc, Fin.snoc_castSucc] + exact hfresh j + · simpa only [hcast work] using hpost + +/-- A lifted machine keeps the one-way-output discipline. -/ +theorem IsTransducer.liftLast {D : TM m} (h : D.IsTransducer) : + (liftLast D).IsTransducer := fun q iHead wHeads oHead => + h q iHead (fun i => wHeads i.castSucc) oHead + +/-- A padded machine keeps the one-way-output discipline. -/ +theorem IsTransducer.liftMany {D : TM m} (h : D.IsTransducer) : + ∀ r, (liftMany D r).IsTransducer + | 0 => h + | r + 1 => (h.liftMany r).liftLast + +/-! ## The protocol survives composition -/ + +/-- The advancing states of a sequential composition: each part's own, with the handoff step — +which the combinator takes in `A`'s halt state — excluded. -/ +def seqAdv {A B : TM (k + 1)} (AdvA : A.Q → Bool) (AdvB : B.Q → Bool) : + SeqQ A.Q B.Q → Bool := + Sum.elim (fun q => AdvA q && !decide (q = A.qhalt)) AdvB + +/-- **The guess protocol survives sequential composition.** -/ +theorem guessProtocol_seqTM {A B : TM (k + 1)} {AdvA : A.Q → Bool} {AdvB : B.Q → Bool} + (hA : GuessProtocol A AdvA) (hB : GuessProtocol B AdvB) : + GuessProtocol (seqTM A B) (seqAdv AdvA AdvB) := by + have hinr : ∀ q : B.Q, (Sum.inr q : SeqQ A.Q B.Q) ≠ (seqTM A B).qhalt → q ≠ B.qhalt := + fun q hq hb => hq (by rw [hb]; rfl) + refine ⟨?_, ?_, ?_⟩ + · rintro (q | q) hq iHead wHeads oHead + · by_cases h : q = A.qhalt + · subst h + simp [seqTM] + · have hred : ((seqTM A B).δ (Sum.inl q) iHead wHeads oHead).2.1 + = (A.δ q iHead wHeads oHead).2.1 := by simp [seqTM, h] + rw [hred] + exact hA.write q h iHead wHeads oHead + · have h := hinr q hq + have hred : ((seqTM A B).δ (Sum.inr q) iHead wHeads oHead).2.1 + = (B.δ q iHead wHeads oHead).2.1 := by simp [seqTM, h] + rw [hred] + exact hB.write q h iHead wHeads oHead + · rintro (q | q) hq iHead wHeads oHead hs + · by_cases h : q = A.qhalt + · subst h + simp [seqTM, seqAdv, idleDir, hs] + · have hred : ((seqTM A B).δ (Sum.inl q) iHead wHeads oHead).2.2.2.2.1 + = (A.δ q iHead wHeads oHead).2.2.2.2.1 := by simp [seqTM, h] + rw [hred, hA.dir q h iHead wHeads oHead hs] + simp [seqAdv, h] + · have h := hinr q hq + have hred : ((seqTM A B).δ (Sum.inr q) iHead wHeads oHead).2.2.2.2.1 + = (B.δ q iHead wHeads oHead).2.2.2.2.1 := by simp [seqTM, h] + rw [hred, hB.dir q h iHead wHeads oHead hs] + simp [seqAdv] + · rintro (q | q) hq hadv iHead ww oHead g g' + · by_cases h : q = A.qhalt + · subst h + simp [seqTM, visible] + · have hadvA : ¬ AdvA q = true := by + simpa [seqAdv, h] using hadv + have hAi := hA.indep q h hadvA iHead ww oHead g g' + have hmap := congrArg (fun z : A.Q × (Fin k → Γw) × Γw × Dir3 × (Fin k → Dir3) × Dir3 => + ((Sum.inl z.1 : SeqQ A.Q B.Q), z.2)) hAi + simpa [seqTM, visible, h] using hmap + · have h := hinr q hq + have hBi := hB.indep q h (by simpa [seqAdv] using hadv) iHead ww oHead g g' + have hmap := congrArg (fun z : B.Q × (Fin k → Γw) × Γw × Dir3 × (Fin k → Dir3) × Dir3 => + ((Sum.inr z.1 : SeqQ A.Q B.Q), z.2)) hBi + simpa [seqTM, visible, h] using hmap + +/-- The advancing states of a loop: each part's own, with the combinator's own control phases and +handoff steps excluded. -/ +def loopAdv {Body Test : TM (k + 1)} (AdvB : Body.Q → Bool) (AdvT : Test.Q → Bool) : + LoopQ Body.Q Test.Q → Bool := + Sum.elim (fun q => AdvB q && !decide (q = Body.qhalt)) + (Sum.elim (fun _ => false) (fun q => AdvT q && !decide (q = Test.qhalt))) + +/-- **The guess protocol survives looping.** -/ +theorem guessProtocol_loopTM {Body Test : TM (k + 1)} {AdvB : Body.Q → Bool} + {AdvT : Test.Q → Bool} (hB : GuessProtocol Body AdvB) (hT : GuessProtocol Test AdvT) : + GuessProtocol (loopTM Body Test) (loopAdv AdvB AdvT) := by + have hphase : ∀ p : LoopPhase, (Sum.inr (Sum.inl p) : LoopQ Body.Q Test.Q) + ≠ (loopTM Body Test).qhalt → p ≠ LoopPhase.done := fun p hq hd => hq (by rw [hd]; rfl) + refine ⟨?_, ?_, ?_⟩ + · rintro (q | (p | q)) hq iHead wHeads oHead + · by_cases h : q = Body.qhalt + · subst h + simp [loopTM] + · have hred : ((loopTM Body Test).δ (Sum.inl q) iHead wHeads oHead).2.1 + = (Body.δ q iHead wHeads oHead).2.1 := by simp [loopTM, h] + rw [hred] + exact hB.write q h iHead wHeads oHead + · have hp := hphase p hq + cases p with + | rewindOut => + simp only [loopTM] + split <;> rfl + | check => + simp only [loopTM] + split <;> rfl + | done => exact absurd rfl hp + · by_cases h : q = Test.qhalt + · subst h + simp [loopTM] + · have hred : ((loopTM Body Test).δ (Sum.inr (Sum.inr q)) iHead wHeads oHead).2.1 + = (Test.δ q iHead wHeads oHead).2.1 := by simp [loopTM, h] + rw [hred] + exact hT.write q h iHead wHeads oHead + · rintro (q | (p | q)) hq iHead wHeads oHead hs + · by_cases h : q = Body.qhalt + · subst h + simp [loopTM, loopAdv, idleDir, hs] + · have hred : ((loopTM Body Test).δ (Sum.inl q) iHead wHeads oHead).2.2.2.2.1 + = (Body.δ q iHead wHeads oHead).2.2.2.2.1 := by simp [loopTM, h] + rw [hred, hB.dir q h iHead wHeads oHead hs] + simp [loopAdv, h] + · have hp := hphase p hq + cases p with + | rewindOut => + simp only [loopTM] + split <;> simp [loopAdv, idleDir, hs] + | check => + simp only [loopTM] + split <;> simp [loopAdv, idleDir, hs] + | done => exact absurd rfl hp + · by_cases h : q = Test.qhalt + · subst h + simp [loopTM, loopAdv, idleDir, hs] + · have hred : ((loopTM Body Test).δ (Sum.inr (Sum.inr q)) iHead wHeads oHead).2.2.2.2.1 + = (Test.δ q iHead wHeads oHead).2.2.2.2.1 := by simp [loopTM, h] + rw [hred, hT.dir q h iHead wHeads oHead hs] + simp [loopAdv, h] + · rintro (q | (p | q)) hq hadv iHead ww oHead g g' + · by_cases h : q = Body.qhalt + · subst h + simp [loopTM, visible] + · have hadvB : ¬ AdvB q = true := by simpa [loopAdv, h] using hadv + have hBi := hB.indep q h hadvB iHead ww oHead g g' + have hmap := congrArg + (fun z : Body.Q × (Fin k → Γw) × Γw × Dir3 × (Fin k → Dir3) × Dir3 => + ((Sum.inl z.1 : LoopQ Body.Q Test.Q), z.2)) hBi + simpa [loopTM, visible, h] using hmap + · have hp := hphase p hq + cases p with + | rewindOut => + simp only [loopTM] + split <;> simp [visible] + | check => + simp only [loopTM] + split <;> simp [visible] + | done => exact absurd rfl hp + · by_cases h : q = Test.qhalt + · subst h + simp [loopTM, visible] + · have hadvT : ¬ AdvT q = true := by simpa [loopAdv, h] using hadv + have hTi := hT.indep q h hadvT iHead ww oHead g g' + have hmap := congrArg + (fun z : Test.Q × (Fin k → Γw) × Γw × Dir3 × (Fin k → Dir3) × Dir3 => + ((Sum.inr (Sum.inr z.1) : LoopQ Body.Q Test.Q), z.2)) hTi + simpa [loopTM, visible, h] using hmap + +/-! ## Reading a guess -/ + +/-- Control states of `TM.guessReadTM`. -/ +inductive GuessPhase where + /-- Copy the guess cell onto the target tape. -/ + | read + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype GuessPhase where + elems := {.read, .done} + complete := fun x => by cases x <;> simp + +/-- **The guess-reading primitive.** In one step it copies the symbol under the guess head onto +work tape `j`, advances the guess head, and halts. This is the only place a machine assembled +with `TM.liftLast` ever consults the guess tape. -/ +def guessReadTM (j : Fin (k + 1)) : TM (k + 1) where + Q := GuessPhase + qstart := .read + qhalt := .done + δ q iHead wHeads oHead := + match q with + | .read => + (GuessPhase.done, + fun i => if i = j then readBackWrite (wHeads (Fin.last k)) else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = Fin.last k then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle GuessPhase.done iHead wHeads oHead + δ_right_of_start := by + intro q iHead wHeads oHead + match q with + | .read => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only + split + · rfl + · exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +@[simp] theorem guessReadTM_qhalt (j : Fin (k + 1)) : + (guessReadTM j).qhalt = GuessPhase.done := rfl + +@[simp] theorem guessReadTM_qstart (j : Fin (k + 1)) : + (guessReadTM j).qstart = GuessPhase.read := rfl + +/-- The guess-reading primitive advances exactly in its one working state. -/ +theorem guessProtocol_guessReadTM (j : Fin (k + 1)) : + GuessProtocol (guessReadTM j) (fun q => decide (q = GuessPhase.read)) := by + refine ⟨?_, ?_, ?_⟩ + · rintro (_ | _) hq iHead wHeads oHead + · simp only [guessReadTM] + split <;> simp_all + · exact absurd rfl hq + · rintro (_ | _) hq iHead wHeads oHead hs + · simp [guessReadTM] + · exact absurd rfl hq + · rintro (_ | _) hq hadv iHead ww oHead g g' + · simp at hadv + · exact absurd rfl hq + +/-- One step of the guess-reading primitive: the guess symbol lands on tape `j`, the guess head +advances, and every other tape is left where it was. -/ +theorem guessReadTM_stepCfg (j : Fin (k + 1)) (hj : j ≠ Fin.last k) + (c : Cfg (k + 1) (guessReadTM j).Q) (hstate : c.state = GuessPhase.read) : + ((guessReadTM j).stepCfg c).state = GuessPhase.done ∧ + ((guessReadTM j).stepCfg c).work j + = (c.work j).writeAndMove (readBackWrite (c.work (Fin.last k)).read).toΓ + (idleDir (c.work j).read) ∧ + ((guessReadTM j).stepCfg c).work (Fin.last k) + = (c.work (Fin.last k)).writeAndMove + (readBackWrite (c.work (Fin.last k)).read).toΓ Dir3.right ∧ + (∀ i, i ≠ j → i ≠ Fin.last k → + ((guessReadTM j).stepCfg c).work i + = (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (idleDir (c.work i).read)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · simp [TM.stepCfg, guessReadTM, hstate] + · simp [TM.stepCfg, guessReadTM, hstate, hj] + · simp [TM.stepCfg, guessReadTM, hstate, Ne.symm hj] + · intro i hij hil + simp [TM.stepCfg, guessReadTM, hstate, hij, hil] + +/-- **The guess-writing primitive.** Like `TM.guessReadTM`, but it also advances the target head, +so that repeating it writes a block of guessed bits. -/ +def guessWriteTM (j : Fin (k + 1)) : TM (k + 1) where + Q := GuessPhase + qstart := .read + qhalt := .done + δ q iHead wHeads oHead := + match q with + | .read => + (GuessPhase.done, + fun i => if i = j then readBackWrite (wHeads (Fin.last k)) else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = Fin.last k then Dir3.right else if i = j then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle GuessPhase.done iHead wHeads oHead + δ_right_of_start := by + intro q iHead wHeads oHead + match q with + | .read => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only + split + · rfl + · split + · rfl + · exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +@[simp] theorem guessWriteTM_qhalt (j : Fin (k + 1)) : + (guessWriteTM j).qhalt = GuessPhase.done := rfl + +@[simp] theorem guessWriteTM_qstart (j : Fin (k + 1)) : + (guessWriteTM j).qstart = GuessPhase.read := rfl + +/-- The guess-writing primitive advances exactly in its one working state. -/ +theorem guessProtocol_guessWriteTM (j : Fin (k + 1)) : + GuessProtocol (guessWriteTM j) (fun q => decide (q = GuessPhase.read)) := by + refine ⟨?_, ?_, ?_⟩ + · rintro (_ | _) hq iHead wHeads oHead + · simp only [guessWriteTM] + split <;> simp_all + · exact absurd rfl hq + · rintro (_ | _) hq iHead wHeads oHead hs + · simp [guessWriteTM] + · exact absurd rfl hq + · rintro (_ | _) hq hadv iHead ww oHead g g' + · simp at hadv + · exact absurd rfl hq + +/-- One step of the guess-writing primitive: the guess symbol lands on tape `j`, which then +advances, the guess head advances, and every other tape is left where it was. -/ +theorem guessWriteTM_stepCfg (j : Fin (k + 1)) (hj : j ≠ Fin.last k) + (c : Cfg (k + 1) (guessWriteTM j).Q) (hstate : c.state = GuessPhase.read) : + ((guessWriteTM j).stepCfg c).state = GuessPhase.done ∧ + ((guessWriteTM j).stepCfg c).work j + = (c.work j).writeAndMove (readBackWrite (c.work (Fin.last k)).read).toΓ Dir3.right ∧ + ((guessWriteTM j).stepCfg c).work (Fin.last k) + = (c.work (Fin.last k)).writeAndMove + (readBackWrite (c.work (Fin.last k)).read).toΓ Dir3.right ∧ + (∀ i, i ≠ j → i ≠ Fin.last k → + ((guessWriteTM j).stepCfg c).work i + = (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (idleDir (c.work i).read)) := by + refine ⟨?_, ?_, ?_, ?_⟩ + · simp [TM.stepCfg, guessWriteTM, hstate] + · simp [TM.stepCfg, guessWriteTM, hstate, hj] + · simp [TM.stepCfg, guessWriteTM, hstate, Ne.symm hj] + · intro i hij hil + simp [TM.stepCfg, guessWriteTM, hstate, hij, hil] + +/-- The tapes after one guess-write: the target takes the guessed symbol and advances, the guess +tape advances, and every other tape passes through the phase transition unchanged. -/ +def guessWriteTapes (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) : Fin (k + 1) → Tape := + fun i => if i = j then (W j).writeAndMove (readBackWrite (W (Fin.last k)).read).toΓ Dir3.right + else if i = Fin.last k then (W (Fin.last k)).writeAndMove + (readBackWrite (W (Fin.last k)).read).toΓ Dir3.right + else transitionTape (W i) + +/-- **The contract of one guess-write.** -/ +theorem guessWriteTM_hoareTime (j : Fin (k + 1)) (hj : j ≠ Fin.last k) + (inp₀ out₀ : Tape) (W₀ : Fin (k + 1) → Tape) : + (guessWriteTM j).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = transitionInput inp₀ ∧ out = transitionTape out₀ ∧ + work = guessWriteTapes j W₀) 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + have hne : (GuessPhase.read : (guessWriteTM j).Q) ≠ (guessWriteTM j).qhalt := by + intro h + exact GuessPhase.noConfusion h + refine ⟨(guessWriteTM j).stepCfg + { state := (guessWriteTM j).qstart, input := inp, work := work, output := out }, + 1, le_rfl, reachesIn.step (step_of_not_halted _ hne) reachesIn.zero, ?_, ?_, ?_, ?_⟩ + · exact (guessWriteTM_stepCfg j hj _ rfl).1 + · rfl + · rfl + · obtain ⟨-, h1, h2, h3⟩ := guessWriteTM_stepCfg j hj + { state := (guessWriteTM j).qstart, input := inp, work := work, output := out } rfl + funext i + rw [guessWriteTapes] + by_cases hij : i = j + · rw [if_pos hij, hij] + exact h1 + · rw [if_neg hij] + by_cases hil : i = Fin.last k + · rw [if_pos hil, hil] + exact h2 + · rw [if_neg hil] + exact h3 i hij hil + +/-! ## Writing a block of guesses + +A parameter block is a fixed number of bits — fixed because it holds a state, a choice bit and +one symbol per head, none of which grows with the input — so the machine that writes it can be +built by recursion on that number rather than by a counted loop. -/ + +/-- Write `n + 1` guessed bits onto work tape `j`, advancing it. -/ +def guessBlockTM (j : Fin (k + 1)) : ℕ → TM (k + 1) + | 0 => guessWriteTM j + | n + 1 => seqTM (guessWriteTM j) (guessBlockTM j n) + +/-- Its advancing states: every state of every stage. -/ +def guessBlockAdv (j : Fin (k + 1)) : (n : ℕ) → (guessBlockTM j n).Q → Bool + | 0 => fun q => decide (q = GuessPhase.read) + | n + 1 => seqAdv (fun q => decide (q = GuessPhase.read)) (guessBlockAdv j n) + +/-- The tapes a block of guess-writes leaves behind. Each stage writes, then the composition's +own handoff step passes every tape through `TM.transitionTape`. -/ +def guessBlockTapes (j : Fin (k + 1)) : ℕ → (Fin (k + 1) → Tape) → (Fin (k + 1) → Tape) + | 0, W => guessWriteTapes j W + | n + 1, W => guessBlockTapes j n (fun i => transitionTape (guessWriteTapes j W i)) + +/-- The input tape a block of guess-writes leaves behind. -/ +def guessBlockInput : ℕ → Tape → Tape + | 0, t => transitionInput t + | n + 1, t => guessBlockInput n (transitionInput (transitionInput t)) + +/-- The output tape a block of guess-writes leaves behind. -/ +def guessBlockOutput : ℕ → Tape → Tape + | 0, t => transitionTape t + | n + 1, t => guessBlockOutput n (transitionTape (transitionTape t)) + +/-- **The contract of a block of guess-writes.** -/ +theorem guessBlockTM_hoareTime (j : Fin (k + 1)) (hj : j ≠ Fin.last k) : + ∀ (n : ℕ) (inp₀ out₀ : Tape) (W₀ : Fin (k + 1) → Tape), + (guessBlockTM j n).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = guessBlockInput n inp₀ ∧ out = guessBlockOutput n out₀ ∧ + work = guessBlockTapes j n W₀) (2 * n + 1) := by + intro n + induction n with + | zero => + intro inp₀ out₀ W₀ + exact guessWriteTM_hoareTime j hj inp₀ out₀ W₀ + | succ n ih => + intro inp₀ out₀ W₀ + have hcomp := seqTM_hoareTime (guessWriteTM j) (guessBlockTM j n) + (guessWriteTM_hoareTime j hj inp₀ out₀ W₀) + (h_trans := fun inp work out h => by + obtain ⟨h1, h2, h3⟩ := h + exact ⟨by rw [h1], by rw [h2], by rw [h3]⟩) + (ih (transitionInput (transitionInput inp₀)) (transitionTape (transitionTape out₀)) + (fun i => transitionTape (guessWriteTapes j W₀ i))) + have hb : 1 + 1 + (2 * n + 1) = 2 * (n + 1) + 1 := by omega + rw [hb] at hcomp + exact hcomp + +/-! ## What a block of guesses actually leaves behind + +On tapes whose heads are off the left marker — which is how every stage of an assembled machine +runs — the phase transitions are the identity, and the description collapses. -/ + +theorem guessBlockInput_eq_self {t : Tape} (h : t.read ≠ Γ.start) : + ∀ n : ℕ, guessBlockInput n t = t := by + intro n + induction n with + | zero => exact transitionInput_eq_self h + | succ n ih => + rw [guessBlockInput, transitionInput_eq_self h, transitionInput_eq_self h] + exact ih + +theorem guessBlockOutput_eq_self {t : Tape} (h : t.read ≠ Γ.start) : + ∀ n : ℕ, guessBlockOutput n t = t := by + intro n + induction n with + | zero => exact transitionTape_eq_self h + | succ n ih => + rw [guessBlockOutput, transitionTape_eq_self h, transitionTape_eq_self h] + exact ih + +theorem guessWriteTapes_last (j : Fin (k + 1)) (hj : j ≠ Fin.last k) (W : Fin (k + 1) → Tape) + (hg : (W (Fin.last k)).read ≠ Γ.start) : + guessWriteTapes j W (Fin.last k) = (W (Fin.last k)).move Dir3.right := by + rw [guessWriteTapes, if_neg (Ne.symm hj), if_pos rfl, writeAndMove_readBack _ hg] + +theorem guessWriteTapes_target (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) + (hg : (W (Fin.last k)).read ≠ Γ.start) : + guessWriteTapes j W j = ((W j).write (W (Fin.last k)).read).move Dir3.right := by + rw [guessWriteTapes, if_pos rfl, toΓ_readBackWrite_of_ne_start hg] + +theorem guessWriteTapes_other (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) (i : Fin (k + 1)) + (hij : i ≠ j) (hil : i ≠ Fin.last k) (h : (W i).read ≠ Γ.start) : + guessWriteTapes j W i = W i := by + rw [guessWriteTapes, if_neg hij, if_neg hil, transitionTape_eq_self h] + +theorem guessWriteTapes_target_head (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) + (hg : (W (Fin.last k)).read ≠ Γ.start) : + (guessWriteTapes j W j).head = (W j).head + 1 := by + rw [guessWriteTapes_target j W hg] + show ((W j).write (W (Fin.last k)).read).head + 1 = _ + rw [Tape.write_head] + +theorem guessWriteTapes_target_cells (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) + (hg : (W (Fin.last k)).read ≠ Γ.start) (hh : 1 ≤ (W j).head) : + (guessWriteTapes j W j).cells ((W j).head) = (W (Fin.last k)).read := by + rw [guessWriteTapes_target j W hg] + show ((W j).write (W (Fin.last k)).read).cells ((W j).head) = _ + rw [Tape.write, if_neg (by omega)] + exact Function.update_self _ _ _ + +theorem guessWriteTapes_target_cells_ne (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) + (hg : (W (Fin.last k)).read ≠ Γ.start) {q : ℕ} (hq : q ≠ (W j).head) : + (guessWriteTapes j W j).cells q = (W j).cells q := by + rw [guessWriteTapes_target j W hg] + show ((W j).write (W (Fin.last k)).read).cells q = _ + rw [Tape.write] + split + · rfl + · exact Function.update_of_ne hq _ _ + +theorem guessWriteTapes_startInvariant (j : Fin (k + 1)) (W : Fin (k + 1) → Tape) + (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) (i : Fin (k + 1)) : + (guessWriteTapes j W i).StartInvariant := by + have hg : (W (Fin.last k)).read ≠ Γ.start := + (hinv (Fin.last k)).read_ne_start (hh (Fin.last k)) + rw [guessWriteTapes] + split + · exact (hinv j).writeAndMove _ _ + · split + · exact (hinv (Fin.last k)).writeAndMove _ _ + · rw [transitionTape_eq_self ((hinv i).read_ne_start (hh i))] + exact hinv i + +theorem guessWriteTapes_head_pos (j : Fin (k + 1)) (hj : j ≠ Fin.last k) + (W : Fin (k + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (i : Fin (k + 1)) : 1 ≤ (guessWriteTapes j W i).head := by + have hg : (W (Fin.last k)).read ≠ Γ.start := + (hinv (Fin.last k)).read_ne_start (hh (Fin.last k)) + by_cases hij : i = j + · rw [hij, guessWriteTapes_target_head j W hg] + omega + · by_cases hil : i = Fin.last k + · rw [hil, guessWriteTapes_last j hj W hg] + show 1 ≤ (W (Fin.last k)).head + 1 + omega + · rw [guessWriteTapes_other j W i hij hil ((hinv i).read_ne_start (hh i))] + exact hh i + +/-- A block of guess-writes preserves the left-marker invariant. -/ +theorem guessBlockTapes_startInvariant (j : Fin (k + 1)) (hj : j ≠ Fin.last k) : + ∀ (n : ℕ) (W : Fin (k + 1) → Tape), (∀ i, (W i).StartInvariant) → (∀ i, 1 ≤ (W i).head) → + ∀ i, (guessBlockTapes j n W i).StartInvariant := by + intro n + induction n with + | zero => intro W hinv hh i; exact guessWriteTapes_startInvariant j W hinv hh i + | succ n ih => + intro W hinv hh i + have hinv' : ∀ i, (guessWriteTapes j W i).StartInvariant := + guessWriteTapes_startInvariant j W hinv hh + have hh' : ∀ i, 1 ≤ (guessWriteTapes j W i).head := + guessWriteTapes_head_pos j hj W hinv hh + rw [guessBlockTapes] + refine ih _ (fun i => ?_) (fun i => ?_) i + · rw [transitionTape_eq_self ((hinv' i).read_ne_start (hh' i))]; exact hinv' i + · rw [transitionTape_eq_self ((hinv' i).read_ne_start (hh' i))]; exact hh' i + +/-- **What a block of guess-writes leaves behind.** The guess tape and the target have both +advanced by the number of bits written, the target's cells hold those bits, its earlier cells and +every other tape are untouched. -/ +theorem guessBlockTapes_spec (j : Fin (k + 1)) (hj : j ≠ Fin.last k) : + ∀ (n : ℕ) (W : Fin (k + 1) → Tape), (∀ i, (W i).StartInvariant) → (∀ i, 1 ≤ (W i).head) → + guessBlockTapes j n W (Fin.last k) + = ⟨(W (Fin.last k)).head + (n + 1), (W (Fin.last k)).cells⟩ ∧ + (guessBlockTapes j n W j).head = (W j).head + (n + 1) ∧ + (∀ i, i ≠ j → i ≠ Fin.last k → guessBlockTapes j n W i = W i) ∧ + (∀ q < (W j).head, (guessBlockTapes j n W j).cells q = (W j).cells q) ∧ + (∀ p ≤ n, (guessBlockTapes j n W j).cells ((W j).head + p) + = (W (Fin.last k)).cells ((W (Fin.last k)).head + p)) := by + intro n + induction n with + | zero => + intro W hinv hh + have hg : (W (Fin.last k)).read ≠ Γ.start := + (hinv (Fin.last k)).read_ne_start (hh (Fin.last k)) + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [guessBlockTapes, guessWriteTapes_last j hj W hg] + rfl + · rw [guessBlockTapes, guessWriteTapes_target_head j W hg] + · intro i hij hil + rw [guessBlockTapes, guessWriteTapes_other j W i hij hil ((hinv i).read_ne_start (hh i))] + · intro q hq + rw [guessBlockTapes, guessWriteTapes_target_cells_ne j W hg (by omega)] + · intro p hp + have hp0 : p = 0 := by omega + rw [hp0, guessBlockTapes, Nat.add_zero, Nat.add_zero, + guessWriteTapes_target_cells j W hg (hh j)] + rfl + | succ n ih => + intro W hinv hh + have hg : (W (Fin.last k)).read ≠ Γ.start := + (hinv (Fin.last k)).read_ne_start (hh (Fin.last k)) + have hinv' : ∀ i, (guessWriteTapes j W i).StartInvariant := + guessWriteTapes_startInvariant j W hinv hh + have hh' : ∀ i, 1 ≤ (guessWriteTapes j W i).head := + guessWriteTapes_head_pos j hj W hinv hh + have hstep : guessBlockTapes j (n + 1) W = guessBlockTapes j n (guessWriteTapes j W) := by + rw [guessBlockTapes] + congr 1 + funext i + exact transitionTape_eq_self ((hinv' i).read_ne_start (hh' i)) + obtain ⟨i1, i2, i3, i4, i5⟩ := ih (guessWriteTapes j W) hinv' hh' + have hlast : guessWriteTapes j W (Fin.last k) + = ⟨(W (Fin.last k)).head + 1, (W (Fin.last k)).cells⟩ := by + rw [guessWriteTapes_last j hj W hg] + rfl + have hjh : (guessWriteTapes j W j).head = (W j).head + 1 := + guessWriteTapes_target_head j W hg + rw [hstep] + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [i1, hlast] + show (⟨(W (Fin.last k)).head + 1 + (n + 1), (W (Fin.last k)).cells⟩ : Tape) = _ + congr 1 + omega + · rw [i2, hjh] + omega + · intro i hij hil + rw [i3 i hij hil, guessWriteTapes_other j W i hij hil ((hinv i).read_ne_start (hh i))] + · intro q hq + rw [i4 q (by omega), guessWriteTapes_target_cells_ne j W hg (by omega)] + · intro p hp + rcases Nat.eq_zero_or_pos p with hp0 | hp0 + · rw [hp0, Nat.add_zero, i4 ((W j).head) (by omega), + guessWriteTapes_target_cells j W hg (hh j)] + rfl + · obtain ⟨q, rfl⟩ : ∃ q, p = q + 1 := ⟨p - 1, by omega⟩ + have hq := i5 q (by omega) + rw [hjh, hlast] at hq + rw [show (W j).head + (q + 1) = (W j).head + 1 + q by omega, hq] + show (W (Fin.last k)).cells ((W (Fin.last k)).head + 1 + q) = _ + congr 1 + omega + +/-- **A block of guesses respects the protocol.** -/ +theorem guessProtocol_guessBlockTM (j : Fin (k + 1)) : + ∀ n : ℕ, GuessProtocol (guessBlockTM j n) (guessBlockAdv j n) := by + intro n + induction n with + | zero => exact guessProtocol_guessWriteTM j + | succ n ih => exact guessProtocol_seqTM (guessProtocol_guessWriteTM j) ih + +/-! ## Several blocks of guesses + +A configuration is spread over several registers, so guessing one means writing a block into each. +The registers are addressed by index, so no placement is involved. -/ + +/-- The do-nothing machine never consults the guess tape. -/ +theorem guessProtocol_skipTM : GuessProtocol (skipTM (n := k + 1)) (fun _ => false) := by + refine ⟨fun q _ iHead wHeads oHead => rfl, fun q _ iHead wHeads oHead h => ?_, + fun q _ _ iHead ww oHead g g' => ?_⟩ + · show idleDir (wHeads (Fin.last k)) = _ + rw [idleDir, if_neg h] + simp + · simp [visible, skipTM] + +/-- **The do-nothing machine's contract**, in the pinned form the guess stages use: one step, and +every tape passes through the phase transition. -/ +theorem skipTM_hoareTime' (inp₀ out₀ : Tape) (W₀ : Fin (k + 1) → Tape) : + (skipTM (n := k + 1)).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = transitionInput inp₀ ∧ out = transitionTape out₀ ∧ + work = fun i => transitionTape (W₀ i)) 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + have hne : (skipTM (n := k + 1)).qstart ≠ (skipTM (n := k + 1)).qhalt := by + intro h + exact BumpPhase.noConfusion h + refine ⟨(skipTM (n := k + 1)).stepCfg + { state := (skipTM (n := k + 1)).qstart, input := inp, work := work, output := out }, + 1, le_rfl, reachesIn.step (step_of_not_halted _ hne) reachesIn.zero, rfl, rfl, rfl, rfl⟩ + +/-- A block of guess-writes leaves every head off the left marker. -/ +theorem guessBlockTapes_head_pos (j : Fin (k + 1)) (hj : j ≠ Fin.last k) (n : ℕ) + (W : Fin (k + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (i : Fin (k + 1)) : 1 ≤ (guessBlockTapes j n W i).head := by + obtain ⟨hlast, hjhead, hother, -, -⟩ := guessBlockTapes_spec j hj n W hinv hh + by_cases hil : i = Fin.last k + · rw [hil, hlast] + have := hh (Fin.last k) + show 1 ≤ (W (Fin.last k)).head + (n + 1) + omega + · by_cases hij : i = j + · rw [hij, hjhead] + have := hh j + omega + · rw [hother i hij hil] + exact hh i + +/-- Where block `p`'s guesses sit on the guess tape: each block consumes one cell per bit plus +one for the block's final advance. -/ +def guessOffset (w : ℕ → ℕ) : ℕ → ℕ + | 0 => 0 + | p + 1 => guessOffset w p + (w p + 1) + +/-- Offsets grow with the number of blocks. -/ +theorem guessOffset_le (w : ℕ → ℕ) : ∀ {p t : ℕ}, p ≤ t → guessOffset w p ≤ guessOffset w t := by + intro p t + induction t with + | zero => intro h; rw [Nat.le_zero.mp h] + | succ t ih => + intro h + rcases Nat.lt_or_ge p (t + 1) with hp | hp + · have := ih (by omega) + rw [guessOffset] + omega + · rw [show p = t + 1 by omega] + +/-- The bits of a family of blocks, laid end to end: this is the guess stream that makes each +register of `TM.guessBlocksTM` hold what the caller wants it to hold. -/ +def guessList (w : ℕ → ℕ) (b : ℕ → ℕ → Bool) : ℕ → List Bool + | 0 => [] + | p + 1 => guessList w b p ++ List.ofFn (fun q : Fin (w p + 1) => b p q.val) + +@[simp] theorem guessList_length (w : ℕ → ℕ) (b : ℕ → ℕ → Bool) (t : ℕ) : + (guessList w b t).length = guessOffset w t := by + induction t with + | zero => rfl + | succ t ih => rw [guessList, guessOffset, List.length_append, ih, List.length_ofFn] + +/-- **Block `p`'s bits sit at offset `guessOffset w p`.** -/ +theorem guessList_getElem (w : ℕ → ℕ) (b : ℕ → ℕ → Bool) : + ∀ (t p q : ℕ), p < t → q ≤ w p → + (guessList w b t)[guessOffset w p + q]? = some (b p q) := by + intro t + induction t with + | zero => intro p q hp; omega + | succ t ih => + intro p q hp hq + rw [guessList] + rcases Nat.lt_or_ge p t with hpt | hpt + · have hlt : guessOffset w p + q < (guessList w b t).length := by + have h1 : guessOffset w (p + 1) ≤ guessOffset w t := guessOffset_le w hpt + rw [guessList_length] + rw [guessOffset] at h1 + omega + rw [List.getElem?_append_left hlt] + exact ih p q hpt hq + · have hpe : p = t := by omega + subst hpe + have hge : (guessList w b p).length ≤ guessOffset w p + q := by + rw [guessList_length]; omega + rw [List.getElem?_append_right hge, guessList_length, + show guessOffset w p + q - guessOffset w p = q by omega] + rw [List.getElem?_ofFn] + simp [hq, Nat.lt_succ_of_le] + +/-- Write a block of guesses into each of `t` registers in turn. -/ +def guessBlocksTM (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) : ℕ → TM (k + 1) + | 0 => skipTM + | t + 1 => seqTM (guessBlocksTM j w t) (guessBlockTM (j t) (w t)) + +/-- Its advancing states. -/ +def guessBlocksAdv (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) : + (t : ℕ) → (guessBlocksTM j w t).Q → Bool + | 0 => fun _ => false + | t + 1 => seqAdv (guessBlocksAdv j w t) (guessBlockAdv (j t) (w t)) + +/-- The tapes several blocks of guesses leave behind. -/ +def guessBlocksTapes (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) : + ℕ → (Fin (k + 1) → Tape) → (Fin (k + 1) → Tape) + | 0, W => fun i => transitionTape (W i) + | t + 1, W => guessBlockTapes (j t) (w t) + (fun i => transitionTape (guessBlocksTapes j w t W i)) + +/-- **A guessed block leaves the tape beyond it untouched.** The blank that stops a scan belongs +to the tape, not to the guess, so it has to survive the guess. -/ +theorem guessBlockTapes_beyond (j : Fin (k + 1)) (hj : j ≠ Fin.last k) : + ∀ (n : ℕ) (W : Fin (k + 1) → Tape), (∀ i, (W i).StartInvariant) → (∀ i, 1 ≤ (W i).head) → + ∀ q, (W j).head + n < q → (guessBlockTapes j n W j).cells q = (W j).cells q := by + intro n + induction n with + | zero => + intro W hinv hh q hq + have hg : (W (Fin.last k)).read ≠ Γ.start := + (hinv (Fin.last k)).read_ne_start (hh (Fin.last k)) + rw [guessBlockTapes, guessWriteTapes_target_cells_ne j W hg (by omega)] + | succ n ih => + intro W hinv hh q hq + have hg : (W (Fin.last k)).read ≠ Γ.start := + (hinv (Fin.last k)).read_ne_start (hh (Fin.last k)) + have hinv' : ∀ i, (guessWriteTapes j W i).StartInvariant := + guessWriteTapes_startInvariant j W hinv hh + have hh' : ∀ i, 1 ≤ (guessWriteTapes j W i).head := + guessWriteTapes_head_pos j hj W hinv hh + have hstep : guessBlockTapes j (n + 1) W = guessBlockTapes j n (guessWriteTapes j W) := by + rw [guessBlockTapes] + congr 1 + funext i + exact transitionTape_eq_self ((hinv' i).read_ne_start (hh' i)) + have hjh : (guessWriteTapes j W j).head = (W j).head + 1 := + guessWriteTapes_target_head j W hg + rw [hstep, ih (guessWriteTapes j W) hinv' hh' q (by rw [hjh]; omega), + guessWriteTapes_target_cells_ne j W hg (by omega)] + +/-- **What several blocks of guesses leave behind.** When the target registers are distinct, each +one ends up holding its own block of guessed bits, read off the guess tape at that block's +offset — which is what lets a stage guess a whole structured object at once. -/ +theorem guessBlocksTapes_spec (j : ℕ → Fin (k + 1)) (hj : ∀ p, j p ≠ Fin.last k) (w : ℕ → ℕ) : + ∀ (t : ℕ) (W : Fin (k + 1) → Tape), (∀ i, (W i).StartInvariant) → (∀ i, 1 ≤ (W i).head) → + (∀ p q, p < t → q < t → j p = j q → p = q) → + (∀ i, (guessBlocksTapes j w t W i).StartInvariant) ∧ + (∀ i, 1 ≤ (guessBlocksTapes j w t W i).head) ∧ + guessBlocksTapes j w t W (Fin.last k) + = ⟨(W (Fin.last k)).head + guessOffset w t, (W (Fin.last k)).cells⟩ ∧ + (∀ i, i ≠ Fin.last k → (∀ p, p < t → i ≠ j p) → guessBlocksTapes j w t W i = W i) ∧ + (∀ p, p < t → + (guessBlocksTapes j w t W (j p)).head = (W (j p)).head + (w p + 1) ∧ + ∀ q, q ≤ w p → (guessBlocksTapes j w t W (j p)).cells ((W (j p)).head + q) + = (W (Fin.last k)).cells ((W (Fin.last k)).head + guessOffset w p + q)) := by + intro t + induction t with + | zero => + intro W hinv hh _ + have hid : ∀ i, transitionTape (W i) = W i := fun i => + transitionTape_eq_self ((hinv i).read_ne_start (hh i)) + refine ⟨fun i => ?_, fun i => ?_, ?_, fun i _ _ => ?_, fun p hp => absurd hp (by omega)⟩ + · rw [guessBlocksTapes]; simp only []; rw [hid]; exact hinv i + · rw [guessBlocksTapes]; simp only []; rw [hid]; exact hh i + · rw [guessBlocksTapes]; simp only []; rw [hid]; rfl + · rw [guessBlocksTapes]; simp only []; rw [hid] + | succ t ih => + intro W hinv hh hinj + obtain ⟨uinv, uhh, ulast, uother, ublk⟩ := + ih W hinv hh (fun p q hp hq h => hinj p q (by omega) (by omega) h) + have hstep : guessBlocksTapes j w (t + 1) W + = guessBlockTapes (j t) (w t) (guessBlocksTapes j w t W) := by + rw [guessBlocksTapes] + congr 1 + funext i + exact transitionTape_eq_self ((uinv i).read_ne_start (uhh i)) + obtain ⟨blast, bhead, bother, -, bcells⟩ := + guessBlockTapes_spec (j t) (hj t) (w t) (guessBlocksTapes j w t W) uinv uhh + have huj : guessBlocksTapes j w t W (j t) = W (j t) := + uother (j t) (hj t) (fun p hp h => absurd (hinj t p (by omega) (by omega) h) (by omega)) + refine ⟨fun i => ?_, fun i => ?_, ?_, fun i hil hip => ?_, fun p hp => ?_⟩ + · rw [hstep] + exact guessBlockTapes_startInvariant (j t) (hj t) (w t) _ uinv uhh i + · rw [hstep] + exact guessBlockTapes_head_pos (j t) (hj t) (w t) _ uinv uhh i + · rw [hstep, blast, ulast] + simp [guessOffset, Nat.add_assoc] + · rw [hstep, bother i (hip t (by omega)) hil] + exact uother i hil (fun p hp => hip p (by omega)) + · rcases Nat.lt_or_ge p t with hpt | hpt + · have hne : j p ≠ j t := fun h => + absurd (hinj p t (by omega) (by omega) h) (by omega) + rw [hstep, bother (j p) hne (hj p)] + exact ublk p hpt + · have hpe : p = t := by omega + subst hpe + refine ⟨?_, fun q hq => ?_⟩ + · rw [hstep, bhead, huj] + · rw [hstep, ← huj, bcells q hq, ulast] + +/-- **And so do several blocks.** A register is written by at most one block, so beyond that +block's own width its cells are the ones it started with. -/ +theorem guessBlocksTapes_beyond (j : ℕ → Fin (k + 1)) (hj : ∀ p, j p ≠ Fin.last k) (w : ℕ → ℕ) : + ∀ (t : ℕ) (W : Fin (k + 1) → Tape), (∀ i, (W i).StartInvariant) → (∀ i, 1 ≤ (W i).head) → + (∀ p q, p < t → q < t → j p = j q → p = q) → + ∀ p, p < t → ∀ q, (W (j p)).head + w p < q → + (guessBlocksTapes j w t W (j p)).cells q = (W (j p)).cells q := by + intro t + induction t with + | zero => intro _ _ _ _ p hp; exact absurd hp (by omega) + | succ t ih => + intro W hinv hh hinj p hp q hq + obtain ⟨uinv, uhh, -, uother, -⟩ := + guessBlocksTapes_spec j hj w t W hinv hh + (fun p q hp hq h => hinj p q (by omega) (by omega) h) + have hstep : guessBlocksTapes j w (t + 1) W + = guessBlockTapes (j t) (w t) (guessBlocksTapes j w t W) := by + rw [guessBlocksTapes] + congr 1 + funext i + exact transitionTape_eq_self ((uinv i).read_ne_start (uhh i)) + have huj : guessBlocksTapes j w t W (j t) = W (j t) := + uother (j t) (hj t) (fun p hp h => absurd (hinj t p (by omega) (by omega) h) (by omega)) + rcases Nat.lt_or_ge p t with hpt | hpt + · have hne : j p ≠ j t := fun h => + absurd (hinj p t (by omega) (by omega) h) (by omega) + rw [hstep, (guessBlockTapes_spec (j t) (hj t) (w t) (guessBlocksTapes j w t W) uinv + uhh).2.2.1 (j p) hne (hj p)] + exact ih W hinv hh (fun p q hp hq h => hinj p q (by omega) (by omega) h) p hpt q hq + · have hpe : p = t := by omega + subst hpe + have h := guessBlockTapes_beyond (j p) (hj p) (w p) (guessBlocksTapes j w p W) uinv uhh q + (by rw [huj]; exact hq) + rw [hstep, h, huj] + +/-- The input tape they leave behind. -/ +def guessBlocksInput (w : ℕ → ℕ) : ℕ → Tape → Tape + | 0, t => transitionInput t + | s + 1, t => guessBlockInput (w s) (transitionInput (guessBlocksInput w s t)) + +/-- The output tape they leave behind. -/ +def guessBlocksOutput (w : ℕ → ℕ) : ℕ → Tape → Tape + | 0, t => transitionTape t + | s + 1, t => guessBlockOutput (w s) (transitionTape (guessBlocksOutput w s t)) + +/-- Several blocks of guesses leave a parked input tape alone. -/ +theorem guessBlocksInput_eq_self {t : Tape} (h : t.read ≠ Γ.start) (w : ℕ → ℕ) : + ∀ s : ℕ, guessBlocksInput w s t = t := by + intro s + induction s with + | zero => exact transitionInput_eq_self h + | succ s ih => + rw [guessBlocksInput, ih, transitionInput_eq_self h, guessBlockInput_eq_self h] + +/-- Several blocks of guesses leave a parked output tape alone. -/ +theorem guessBlocksOutput_eq_self {t : Tape} (h : t.read ≠ Γ.start) (w : ℕ → ℕ) : + ∀ s : ℕ, guessBlocksOutput w s t = t := by + intro s + induction s with + | zero => exact transitionTape_eq_self h + | succ s ih => + rw [guessBlocksOutput, ih, transitionTape_eq_self h, guessBlockOutput_eq_self h] + +/-- How long several blocks of guesses take. -/ +def guessBlocksTime (w : ℕ → ℕ) : ℕ → ℕ + | 0 => 1 + | t + 1 => guessBlocksTime w t + 1 + (2 * w t + 1) + +/-- **The contract of several blocks of guesses.** -/ +theorem guessBlocksTM_hoareTime (j : ℕ → Fin (k + 1)) (hj : ∀ t, j t ≠ Fin.last k) + (w : ℕ → ℕ) : + ∀ (t : ℕ) (inp₀ out₀ : Tape) (W₀ : Fin (k + 1) → Tape), + (guessBlocksTM j w t).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = guessBlocksInput w t inp₀ ∧ + out = guessBlocksOutput w t out₀ ∧ work = guessBlocksTapes j w t W₀) + (guessBlocksTime w t) := by + intro t + induction t with + | zero => + intro inp₀ out₀ W₀ + simpa using skipTM_hoareTime' inp₀ out₀ W₀ + | succ t ih => + intro inp₀ out₀ W₀ + have hcomp := seqTM_hoareTime (guessBlocksTM j w t) (guessBlockTM (j t) (w t)) + (ih inp₀ out₀ W₀) + (h_trans := fun inp work out h => by + obtain ⟨h1, h2, h3⟩ := h + exact ⟨by rw [h1], by rw [h2], by rw [h3]⟩) + (guessBlockTM_hoareTime (j t) (hj t) (w t) + (transitionInput (guessBlocksInput w t inp₀)) + (transitionTape (guessBlocksOutput w t out₀)) + (fun i => transitionTape (guessBlocksTapes j w t W₀ i))) + exact hcomp + +/-- **Several blocks of guesses respect the protocol.** -/ +theorem guessProtocol_guessBlocksTM (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) : + ∀ t : ℕ, GuessProtocol (guessBlocksTM j w t) (guessBlocksAdv j w t) := by + intro t + induction t with + | zero => exact guessProtocol_skipTM + | succ t ih => exact guessProtocol_seqTM ih (guessProtocol_guessBlockTM (j t) (w t)) + +/-- **Guess, then check.** Every stage of a guess-and-verify machine has this shape: write some +blocks of guesses onto the registers, then run a guess-free machine on them. -/ +def guessThenTM (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) (t : ℕ) (D : TM k) : TM (k + 1) := + seqTM (guessBlocksTM j w t) (liftLast D) + +/-- **A guess-and-check stage respects the protocol.** -/ +theorem guessProtocol_guessThenTM (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) (t : ℕ) (D : TM k) : + GuessProtocol (guessThenTM j w t D) + (seqAdv (guessBlocksAdv j w t) (fun _ => false)) := + guessProtocol_seqTM (guessProtocol_guessBlocksTM j w t) (guessProtocol_liftLast D) + +/-- **The contract of a guess-and-check stage.** The caller says what the guessed tapes give the +checking machine; this composes the two halves. -/ +theorem guessThenTM_hoareTime (j : ℕ → Fin (k + 1)) (hj : ∀ t, j t ≠ Fin.last k) (w : ℕ → ℕ) + (t : ℕ) (D : TM k) {mid post : TapePred (k + 1)} {b : ℕ} + (inp₀ out₀ : Tape) (W₀ : Fin (k + 1) → Tape) + (h_trans : ∀ inp work out, + (inp = guessBlocksInput w t inp₀ ∧ out = guessBlocksOutput w t out₀ ∧ + work = guessBlocksTapes j w t W₀) → + mid (transitionInput inp) (fun i => transitionTape (work i)) (transitionTape out)) + (hD : (liftLast D).HoareTime mid post b) : + (guessThenTM j w t D).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) post + (guessBlocksTime w t + 1 + b) := + seqTM_hoareTime (guessBlocksTM j w t) (liftLast D) + (guessBlocksTM_hoareTime j hj w t inp₀ out₀ W₀) h_trans hD + +/-! ## What the guess tape still holds + +A stage consumes a prefix of the guess tape and leaves the rest for the stages after it. Stating +that as a predicate on the tape lets a loop carry it as an invariant: each iteration shifts the +stream by the bits it used. -/ + +/-- The guess tape carries the bits of `g` from its head onward. -/ +def GuessFrom (g : ℕ → Bool) (t : Tape) : Prop := + ∀ q, t.cells (t.head + q) = Γ.ofBool (g q) + +/-- **A loaded guess tape carries its stream.** -/ +theorem guessFrom_loadTape (g : ℕ → Bool) : GuessFrom g (NTM.loadTape g) := by + intro q + show (NTM.loadTape g).cells (1 + q) = _ + rw [show 1 + q = q + 1 by omega, NTM.loadTape_cells_succ] + +/-- **A stage's blocks are read off the stream at their offsets.** -/ +theorem guessFrom_blocks {g : ℕ → Bool} {t : Tape} (h : GuessFrom g t) (w : ℕ → ℕ) (p q : ℕ) : + t.cells (t.head + guessOffset w p + q) = Γ.ofBool (g (guessOffset w p + q)) := by + rw [show t.head + guessOffset w p + q = t.head + (guessOffset w p + q) by omega] + exact h (guessOffset w p + q) + +/-- **A stage consumes a prefix and leaves the rest.** -/ +theorem guessFrom_after (j : ℕ → Fin (k + 1)) (hj : ∀ p, j p ≠ Fin.last k) (w : ℕ → ℕ) (t : ℕ) + (W : Fin (k + 1) → Tape) (hinv : ∀ i, (W i).StartInvariant) (hh : ∀ i, 1 ≤ (W i).head) + (hinj : ∀ p q, p < t → q < t → j p = j q → p = q) (g : ℕ → Bool) + (hg : GuessFrom g (W (Fin.last k))) : + GuessFrom (fun q => g (guessOffset w t + q)) (guessBlocksTapes j w t W (Fin.last k)) := by + obtain ⟨-, -, hlast, -, -⟩ := guessBlocksTapes_spec j hj w t W hinv hh hinj + intro q + rw [hlast] + show (W (Fin.last k)).cells ((W (Fin.last k)).head + guessOffset w t + q) = _ + exact guessFrom_blocks hg w t q + +/-! ## A stream that feeds every stage + +A machine that guesses in a loop consumes one stage's worth of bits per pass. Saying what the +whole guess tape must contain is then a statement about a doubly-indexed family: stage `s`, block +`p`, bit `q`. Such a stream always exists — the offsets of distinct stages and blocks never +collide. -/ + +/-- The stream gives stage `s` its block `p`'s bit `q`. -/ +def StageBlocks (w : ℕ → ℕ) (t : ℕ) (b : ℕ → ℕ → ℕ → Bool) (g : ℕ → Bool) : Prop := + ∀ s p q, p < t → q ≤ w p → g (s * guessOffset w t + (guessOffset w p + q)) = b s p q + +theorem guessOffset_pos (w : ℕ → ℕ) {t : ℕ} (ht : 0 < t) : 0 < guessOffset w t := by + obtain ⟨t', rfl⟩ : ∃ t', t = t' + 1 := ⟨t - 1, by omega⟩ + rw [guessOffset] + omega + +theorem guessOffset_lt (w : ℕ → ℕ) {t p q : ℕ} (hp : p < t) (hq : q ≤ w p) : + guessOffset w p + q < guessOffset w t := by + have h : guessOffset w (p + 1) ≤ guessOffset w t := guessOffset_le w hp + rw [guessOffset] at h + omega + +/-- **Every family of stages is realized by some stream.** -/ +theorem exists_stageBlocks (w : ℕ → ℕ) {t : ℕ} (ht : 0 < t) (b : ℕ → ℕ → ℕ → Bool) : + ∃ g : ℕ → Bool, StageBlocks w t b g := by + classical + refine ⟨fun o => ((guessList w (b (o / guessOffset w t)) t)[o % guessOffset w t]?).getD false, + ?_⟩ + intro s p q hp hq + have hG : 0 < guessOffset w t := guessOffset_pos w ht + have hlt : guessOffset w p + q < guessOffset w t := guessOffset_lt w hp hq + have hdiv : (s * guessOffset w t + (guessOffset w p + q)) / guessOffset w t = s := by + rw [show s * guessOffset w t + (guessOffset w p + q) + = (guessOffset w p + q) + s * guessOffset w t by omega, + Nat.add_mul_div_right _ _ hG, Nat.div_eq_of_lt hlt, Nat.zero_add] + have hmod : (s * guessOffset w t + (guessOffset w p + q)) % guessOffset w t + = guessOffset w p + q := by + rw [show s * guessOffset w t + (guessOffset w p + q) + = (guessOffset w p + q) + s * guessOffset w t by omega, + Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hlt] + show ((guessList w (b _) t)[_]?).getD false = _ + rw [hdiv, hmod, guessList_getElem w (b s) t p q hp hq] + rfl + +/-- **A stage reads its own blocks off the stream.** This is the hypothesis a guess stage's +contract asks for, supplied by the loop invariant's guess-tape clause. -/ +theorem blocks_of_stageBlocks {w : ℕ → ℕ} {t : ℕ} {b : ℕ → ℕ → ℕ → Bool} {g : ℕ → Bool} + (hs : StageBlocks w t b g) (s : ℕ) {τ : Tape} + (hgf : GuessFrom (fun q => g (s * guessOffset w t + q)) τ) : + ∀ p, p < t → ∀ q, q ≤ w p → τ.cells (τ.head + guessOffset w p + q) = Γ.ofBool (b s p q) := by + intro p hp q hq + rw [guessFrom_blocks hgf w p q, hs s p q hp hq] + +/-! ## A whole guess-and-rewind stage -/ + +/-- **A guess stage.** Write a block of guesses onto each of `t` registers, then bring the named +registers' heads back to cell one — the form every scan expects to read. The input head is left +alone: a machine simulating another one keeps its input head where the simulation put it. -/ +def guessStageTM (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) (t : ℕ) (targets : List (Fin k)) : + TM (k + 1) := + guessThenTM j w t (parkRewindWorkTM targets) + +/-- **A guess stage respects the protocol.** -/ +theorem guessProtocol_guessStageTM (j : ℕ → Fin (k + 1)) (w : ℕ → ℕ) (t : ℕ) + (targets : List (Fin k)) : + GuessProtocol (guessStageTM j w t targets) + (seqAdv (guessBlocksAdv j w t) (fun _ => false)) := + guessProtocol_guessThenTM j w t (parkRewindWorkTM targets) + +/-- **The contract of a guess stage.** -/ +theorem guessStageTM_hoareTime (j : ℕ → Fin (k + 1)) (hj : ∀ p, j p ≠ Fin.last k) (w : ℕ → ℕ) + (t : ℕ) (targets : List (Fin k)) (hnodup : targets.Nodup) (B : ℕ) (hB : 1 ≤ B) + (inp₀ out₀ : Tape) (W₀ : Fin (k + 1) → Tape) + (hinpSI : inp₀.StartInvariant) (houtSI : out₀.StartInvariant) + (hinp : inp₀.read ≠ Γ.start) (hout : out₀.read ≠ Γ.start) + (hinvW : ∀ i, (W₀ i).StartInvariant) (hhW : ∀ i, 1 ≤ (W₀ i).head) + (hinj : ∀ p q, p < t → q < t → j p = j q → p = q) + (hbound : ∀ i, i ∈ targets → (guessBlocksTapes j w t W₀ i.castSucc).head ≤ B) : + (guessStageTM j w t targets).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => + work (Fin.last k) = guessBlocksTapes j w t W₀ (Fin.last k) ∧ + inp = parkTape inp₀ ∧ + (fun i => work i.castSucc) + = (fun i => if i ∈ targets + then (⟨1, (guessBlocksTapes j w t W₀ i.castSucc).cells⟩ : Tape) + else parkTape (guessBlocksTapes j w t W₀ i.castSucc)) ∧ + out = parkTape out₀) + (guessBlocksTime w t + 1 + (1 + 1 + (targets.length * (B + 3) + 1))) := by + obtain ⟨ginv, ghh, -, -, -⟩ := guessBlocksTapes_spec j hj w t W₀ hinvW hhW hinj + have gns : ∀ i, (guessBlocksTapes j w t W₀ i).read ≠ Γ.start := + fun i => (ginv i).read_ne_start (ghh i) + refine guessThenTM_hoareTime j hj w t (parkRewindWorkTM targets) inp₀ out₀ W₀ ?_ + (liftLast_hoareTime (parkRewindWorkTM targets) + (parkRewindWorkTM_hoareTime targets hnodup B hB inp₀ + (fun i => guessBlocksTapes j w t W₀ i.castSucc) out₀ hinpSI + (fun i => ginv i.castSucc) houtSI hbound) + (guessBlocksTapes j w t W₀ (Fin.last k)) (gns (Fin.last k))) + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨transitionTape_eq_self (gns (Fin.last k)), ?_, ?_, ?_⟩ + · rw [guessBlocksInput_eq_self hinp, transitionInput_eq_self hinp] + · funext i + exact transitionTape_eq_self (gns i.castSucc) + · rw [guessBlocksOutput_eq_self hout, transitionTape_eq_self hout] + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/GuessStream.lean b/Complexitylib/Models/TuringMachine/GuessStream.lean new file mode 100644 index 00000000..7515f640 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/GuessStream.lean @@ -0,0 +1,542 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.GuessTape + +/-! +# Guessing in designated states + +`Complexitylib.Models.TuringMachine.GuessTape` pairs `NTM.ofGuess M` with `NTM.choiceTM`, which +forces `M` to consume a guess at *every* step. No machine assembled from +`Complexitylib.Models.TuringMachine.Combinators` does that: the handoff step of `TM.seqTM`, and +every step of a subroutine that has no interest in the guesses, leaves the tape's head where it +is. This file drops that requirement. + +A machine here nominates a set of **advancing states**. In an advancing state it consumes the +cell under the guess head and moves that head on; in every other state it neither consults the +guess tape nor moves its head. Between the two lies the whole deterministic subroutine library, +usable unchanged. + +The price is that the guess tape's head and the step counter part company: at step `i` the head +sits at the **cursor**, the number of advancing steps so far. `NTM.ofGuess M` still consumes one +choice per step, so the correspondence between a loaded tape and a choice sequence is no longer +the identity — it is the cursor. `NTM.exists_guessTape` is what makes it work in the direction a +soundness proof needs: *every* choice sequence is realized by some loaded tape, because the +choices made at non-advancing steps are the ones the machine never looks at. + +## Main definitions + +- `TM.traceD` — run a deterministic machine for a fixed number of steps, halting in place +- `TM.GuessProtocol` — advance and consume in the nominated states, hold elsewhere +- `NTM.guessBit` — the bit the machine reads at a given step + +## Main results + +- `NTM.dropChoice_stepCfg` — one step of `M` is one step of `NTM.ofGuess M` along the bit read +- `NTM.dropChoice_traceD` — and a run is a trace along the bits read +- `TM.traceD_of_reachesIn`, `TM.traceD_add`, `TM.traceD_of_reachesIn_halted` — a run of a fixed + length is the deterministic trace, traces compose, and a halted trace stays put +- `NTM.exists_guessTape` — every choice sequence comes from a loaded guess tape +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- Run a deterministic machine for `T` steps, staying put once halted. The deterministic +counterpart of `NTM.trace`. -/ +def traceD (M : TM n) : ℕ → Cfg n M.Q → Cfg n M.Q + | 0, c => c + | T + 1, c => if c.state = M.qhalt then c else M.traceD T (M.stepCfg c) + +@[simp] theorem traceD_zero (M : TM n) (c : Cfg n M.Q) : M.traceD 0 c = c := rfl + +theorem traceD_succ_of_not_halted (M : TM n) (T : ℕ) {c : Cfg n M.Q} + (h : c.state ≠ M.qhalt) : M.traceD (T + 1) c = M.traceD T (M.stepCfg c) := by + rw [traceD, if_neg h] + +theorem traceD_of_halted (M : TM n) (T : ℕ) {c : Cfg n M.Q} (h : c.state = M.qhalt) : + M.traceD T c = c := by + cases T with + | zero => rfl + | succ T => rw [traceD, if_pos h] + +/-- A run of `T + 1` steps is a run of `T` steps followed by one more. -/ +theorem traceD_succ_back (M : TM n) : ∀ (T : ℕ) (c : Cfg n M.Q), + M.traceD (T + 1) c = + if (M.traceD T c).state = M.qhalt then M.traceD T c else M.stepCfg (M.traceD T c) := by + intro T + induction T with + | zero => + intro c + by_cases h : c.state = M.qhalt + · rw [traceD_of_halted M _ h, traceD_zero, if_pos h] + · rw [traceD_succ_of_not_halted M 0 h, traceD_zero, traceD_zero, if_neg h] + | succ T ih => + intro c + by_cases h : c.state = M.qhalt + · rw [traceD_of_halted M _ h, traceD_of_halted M _ h, if_pos h] + · rw [traceD_succ_of_not_halted M (T + 1) h, traceD_succ_of_not_halted M T h, ih] + +/-- A fixed-length run is a `reachesIn` run, stopped early exactly when the machine halts. -/ +theorem reachesIn_traceD (M : TM n) (T : ℕ) (c : Cfg n M.Q) : + ∃ t ≤ T, M.reachesIn t c (M.traceD T c) ∧ (t < T → M.halted (M.traceD T c)) := by + induction T generalizing c with + | zero => exact ⟨0, le_rfl, reachesIn.zero, by omega⟩ + | succ T ih => + by_cases h : c.state = M.qhalt + · exact ⟨0, Nat.zero_le _, by rw [traceD_of_halted M _ h]; exact reachesIn.zero, + fun _ => by rw [traceD_of_halted M _ h]; exact h⟩ + · obtain ⟨t, hle, hreach, hstop⟩ := ih (M.stepCfg c) + refine ⟨t + 1, by omega, ?_, fun _ => ?_⟩ + · rw [traceD_succ_of_not_halted M T h] + exact reachesIn.step (step_of_not_halted M h) hreach + · rw [traceD_succ_of_not_halted M T h] + exact hstop (by omega) + +variable {k : ℕ} + +/-- The part of a transition that survives forgetting the guess tape. -/ +def visible {Q : Type} (r : Q × (Fin (k + 1) → Γw) × Γw × Dir3 × (Fin (k + 1) → Dir3) × Dir3) : + Q × (Fin k → Γw) × Γw × Dir3 × (Fin k → Dir3) × Dir3 := + (r.1, fun j => r.2.1 j.castSucc, r.2.2.1, r.2.2.2.1, fun j => r.2.2.2.2.1 j.castSucc, + r.2.2.2.2.2) + +/-- **The guess protocol.** In an advancing state the machine consumes the cell under the guess +head and moves that head on; in every other state it holds the head still and nothing visible +depends on what the cell holds. The guess tape's contents are never altered. -/ +structure GuessProtocol (M : TM (k + 1)) (Adv : M.Q → Bool) : Prop where + /-- The guess cell is always written back unchanged. -/ + write : ∀ (q : M.Q), q ≠ M.qhalt → ∀ (iHead : Γ) (wHeads : Fin (k + 1) → Γ) (oHead : Γ), + (M.δ q iHead wHeads oHead).2.1 (Fin.last k) = readBackWrite (wHeads (Fin.last k)) + /-- The guess head advances in advancing states and holds still elsewhere. -/ + dir : ∀ (q : M.Q), q ≠ M.qhalt → ∀ (iHead : Γ) (wHeads : Fin (k + 1) → Γ) (oHead : Γ), + wHeads (Fin.last k) ≠ Γ.start → + (M.δ q iHead wHeads oHead).2.2.2.2.1 (Fin.last k) = + if Adv q then Dir3.right else Dir3.stay + /-- Outside the advancing states the guess is not consulted. -/ + indep : ∀ (q : M.Q), q ≠ M.qhalt → ¬ Adv q → + ∀ (iHead : Γ) (ww : Fin k → Γ) (oHead : Γ) (g g' : Γ), + visible (M.δ q iHead (Fin.snoc ww g) oHead) = visible (M.δ q iHead (Fin.snoc ww g') oHead) + +/-- **A run of a fixed length is the deterministic trace.** A machine's step is a function, so +the configuration reached in exactly `t` steps is `TM.traceD t`. -/ +theorem traceD_of_reachesIn (M : TM n) : ∀ (t : ℕ) {c c' : Cfg n M.Q}, + M.reachesIn t c c' → M.traceD t c = c' := by + intro t + induction t with + | zero => + intro c c' h + cases h + rfl + | succ t ih => + intro c c' h + cases h with + | step hstep hrest => + have hne : c.state ≠ M.qhalt := by + intro hc + simp [TM.step, hc] at hstep + rw [traceD_succ_of_not_halted M t hne] + have hcfg := hstep + rw [TM.step_of_not_halted M hne] at hcfg + rw [Option.some.inj hcfg] + exact ih hrest + +/-- **Traces compose.** -/ +theorem traceD_add (M : TM n) : ∀ (a b : ℕ) (c : Cfg n M.Q), + M.traceD (a + b) c = M.traceD b (M.traceD a c) := by + intro a + induction a with + | zero => intro b c; rw [Nat.zero_add, traceD_zero] + | succ a ih => + intro b c + by_cases h : c.state = M.qhalt + · rw [traceD_of_halted M _ h, traceD_of_halted M _ h, traceD_of_halted M _ h] + · rw [show a + 1 + b = (a + b) + 1 by omega, traceD_succ_of_not_halted M (a + b) h, + traceD_succ_of_not_halted M a h, ih] + +/-- **Once halted, a longer trace stays put.** -/ +theorem traceD_of_reachesIn_halted (M : TM n) {t T : ℕ} (hle : t ≤ T) {c c' : Cfg n M.Q} + (h : M.reachesIn t c c') (hhalt : M.halted c') : M.traceD T c = c' := by + obtain ⟨d, rfl⟩ : ∃ d, T = t + d := ⟨T - t, by omega⟩ + rw [traceD_add, traceD_of_reachesIn M t h, traceD_of_halted M d hhalt] + +end TM + +namespace NTM + +variable {k : ℕ} + +private theorem snoc_init_self' {α : Type} (f : Fin (k + 1) → α) : + Fin.snoc (fun j => f j.castSucc) (f (Fin.last k)) = f := + Fin.snoc_init_self f + +open TM in +/-- The transition of `NTM.ofGuess M` is the visible part of `M`'s. -/ +theorem ofGuess_δ (M : TM (k + 1)) (b : Bool) (q : M.Q) (iHead : Γ) (ww : Fin k → Γ) + (oHead : Γ) : + (ofGuess M).δ b q iHead ww oHead = + TM.visible (M.δ q iHead (Fin.snoc ww (Γ.ofBool b)) oHead) := rfl + +/-- **One step of `M` is one step of `NTM.ofGuess M` along the bit under the guess head.** -/ +theorem dropChoice_stepCfg (M : TM (k + 1)) {c : Cfg (k + 1) M.Q} {b : Bool} + (hread : (c.work (Fin.last k)).read = Γ.ofBool b) : + dropChoice (M.stepCfg c) = stepCfg (ofGuess M) b (dropChoice c) := by + have hsnoc : Fin.snoc (fun i : Fin k => (c.work i.castSucc).read) (Γ.ofBool b) + = fun i => (c.work i).read := by + rw [← hread] + exact snoc_init_self' (fun i => (c.work i).read) + refine Cfg.ext ?_ ?_ ?_ ?_ <;> + simp only [dropChoice, TM.stepCfg, stepCfg, ofGuess, hsnoc] + +/-- Run a nondeterministic machine forward, taking the `i`-th choice at step `i`. Unlike +`NTM.trace`, which consumes its choices from the front, this indexes them absolutely, which is +what a statement about "the step at which a guess was consumed" needs. -/ +def nrunAt (N : NTM k) (choices : ℕ → Bool) (c : Cfg k N.Q) : ℕ → Cfg k N.Q + | 0 => c + | i + 1 => + let cᵢ := nrunAt N choices c i + if cᵢ.state = N.qhalt then cᵢ else stepCfg N (choices i) cᵢ + +@[simp] theorem nrunAt_zero (N : NTM k) (choices : ℕ → Bool) (c : Cfg k N.Q) : + nrunAt N choices c 0 = c := rfl + +theorem nrunAt_succ (N : NTM k) (choices : ℕ → Bool) (c : Cfg k N.Q) (i : ℕ) : + nrunAt N choices c (i + 1) = + if (nrunAt N choices c i).state = N.qhalt then nrunAt N choices c i + else stepCfg N (choices i) (nrunAt N choices c i) := rfl + +theorem nrunAt_of_halted (N : NTM k) (choices : ℕ → Bool) {c : Cfg k N.Q} + (h : c.state = N.qhalt) (i : ℕ) : nrunAt N choices c i = c := by + induction i with + | zero => rfl + | succ i ih => rw [nrunAt_succ, ih, if_pos h] + +theorem nrunAt_succ_front (N : NTM k) (choices : ℕ → Bool) {c : Cfg k N.Q} + (h : c.state ≠ N.qhalt) (i : ℕ) : + nrunAt N choices c (i + 1) + = nrunAt N (fun j => choices (j + 1)) (stepCfg N (choices 0) c) i := by + induction i with + | zero => + rw [nrunAt_succ] + simp only [nrunAt_zero] + rw [if_neg h] + | succ i ih => rw [nrunAt_succ, ih, nrunAt_succ] + +/-- The absolutely-indexed run is `NTM.trace`. -/ +theorem trace_eq_nrunAt (N : NTM k) (choices : ℕ → Bool) : + ∀ (T : ℕ) (c : Cfg k N.Q), + N.trace T (fun i => choices i.val) c = nrunAt N choices c T := by + intro T + induction T generalizing choices with + | zero => intro c; rfl + | succ T ih => + intro c + by_cases h : c.state = N.qhalt + · rw [trace, if_pos h, nrunAt_of_halted N choices h] + · rw [trace_succ_of_not_halted N T _ h, nrunAt_succ_front N choices h] + exact ih (fun j => choices (j + 1)) _ + +/-- The bit the machine reads off its guess tape at step `i`. -/ +def guessBit (M : TM (k + 1)) (c : Cfg (k + 1) M.Q) (i : ℕ) : Bool := + decide (((M.traceD i c).work (Fin.last k)).read = Γ.one) + +/-- A step preserves the guess tape and moves its head at most one cell right, so a tape holding +bits for `T + 1` cells still holds them for `T`. -/ +theorem boolFrom_stepCfg (M : TM (k + 1)) {Adv : M.Q → Bool} (hP : TM.GuessProtocol M Adv) + {T : ℕ} {c : Cfg (k + 1) M.Q} (hq : c.state ≠ M.qhalt) + (h : (c.work (Fin.last k)).BoolFrom (T + 1)) : + ((M.stepCfg c).work (Fin.last k)).BoolFrom T := by + have hread : (c.work (Fin.last k)).read ≠ Γ.start := h.read_ne_start + have hw : (M.stepCfg c).work (Fin.last k) + = (c.work (Fin.last k)).writeAndMove (TM.readBackWrite (c.work (Fin.last k)).read) + (if Adv c.state then Dir3.right else Dir3.stay) := by + show (c.work (Fin.last k)).writeAndMove ((M.δ c.state c.input.read + (fun i => (c.work i).read) c.output.read).2.1 (Fin.last k)) + ((M.δ c.state c.input.read (fun i => (c.work i).read) c.output.read).2.2.2.2.1 + (Fin.last k)) = _ + rw [hP.write _ hq, hP.dir _ hq _ _ _ hread] + rw [hw, TM.writeAndMove_readBack _ hread] + split + · exact h.move_right + · exact h.mono (by omega) + +/-- **A run of `M` is a trace of `NTM.ofGuess M` along the bits it reads.** -/ +theorem dropChoice_traceD (M : TM (k + 1)) {Adv : M.Q → Bool} (hP : TM.GuessProtocol M Adv) : + ∀ (T : ℕ) (c : Cfg (k + 1) M.Q), (c.work (Fin.last k)).BoolFrom T → + dropChoice (M.traceD T c) + = (ofGuess M).trace T (fun i => guessBit M c i.val) (dropChoice c) := by + intro T + induction T with + | zero => intro c _; rfl + | succ T ih => + intro c hbool + by_cases hhalt : c.state = M.qhalt + · rw [TM.traceD_of_halted M _ hhalt, trace] + simp [dropChoice, hhalt, ofGuess] + · obtain ⟨b, hb⟩ := hbool.read + have hbit : guessBit M c 0 = b := by + rw [guessBit, TM.traceD_zero, hb] + cases b <;> decide + have hstep : stepCfg (ofGuess M) (guessBit M c 0) (dropChoice c) + = dropChoice (M.stepCfg c) := by + rw [hbit] + exact (dropChoice_stepCfg M hb).symm + have hshift : ∀ i : ℕ, guessBit M c (i + 1) = guessBit M (M.stepCfg c) i := by + intro i + rw [guessBit, guessBit, TM.traceD_succ_of_not_halted M i hhalt] + rw [TM.traceD_succ_of_not_halted M T hhalt, + trace_succ_of_not_halted (ofGuess M) T _ (by simpa [dropChoice] using hhalt)] + dsimp only + rw [hstep] + rw [ih (M.stepCfg c) (boolFrom_stepCfg M hP hhalt hbool)] + congr 1 + funext i + exact (hshift i.val).symm + +/-! ## Every choice sequence comes from a loaded tape -/ + +/-- Outside the advancing states the choice bit does not matter. -/ +theorem stepCfg_indep (M : TM (k + 1)) {Adv : M.Q → Bool} (hP : TM.GuessProtocol M Adv) + {c : Cfg k M.Q} (hq : c.state ≠ M.qhalt) (h : ¬ Adv c.state) (b b' : Bool) : + stepCfg (ofGuess M) b c = stepCfg (ofGuess M) b' c := by + have hind := hP.indep c.state hq h c.input.read (fun i => (c.work i).read) c.output.read + (Γ.ofBool b) (Γ.ofBool b') + simp only [stepCfg, ofGuess_δ, hind] + +/-- Attach a guess tape to a configuration. -/ +def attach {Q : Type} (d : Cfg k Q) (τ : Tape) : Cfg (k + 1) Q where + state := d.state + input := d.input + work := Fin.snoc d.work τ + output := d.output + +@[simp] theorem attach_work_last {Q : Type} (d : Cfg k Q) (τ : Tape) : + (attach d τ).work (Fin.last k) = τ := by + simp [attach] + +@[simp] theorem dropChoice_attach {Q : Type} (d : Cfg k Q) (τ : Tape) : + dropChoice (attach d τ) = d := by + refine Cfg.ext rfl rfl ?_ rfl + funext i + simp [dropChoice, attach] + +@[simp] theorem attach_state {Q : Type} (d : Cfg k Q) (τ : Tape) : + (attach d τ).state = d.state := rfl + +theorem loadCfg_eq_attach (M : TM (k + 1)) (x : List Bool) (g : ℕ → Bool) : + loadCfg M x g = attach ((ofGuess M).initCfg x) (loadTape g) := by + refine Cfg.ext rfl rfl ?_ rfl + funext i + refine Fin.lastCases ?_ ?_ i + · simp [loadCfg, attach] + · intro j + simp [loadCfg, attach] + +/-- The largest index below `T` at which `P` holds, or `0` if there is none. -/ +def searchIdx (P : ℕ → Bool) : ℕ → ℕ + | 0 => 0 + | T + 1 => if P T then T else searchIdx P T + +theorem searchIdx_eq {P : ℕ → Bool} {T i : ℕ} (hi : i < T) (hP : P i = true) + (huniq : ∀ j, P j = true → j = i) : searchIdx P T = i := by + induction T with + | zero => omega + | succ T ih => + rw [searchIdx] + by_cases h : P T = true + · rw [if_pos h] + exact huniq T h + · rw [if_neg h] + refine ih ?_ + rcases Nat.lt_or_ge i T with h' | h' + · exact h' + · exact absurd ((show i = T by omega) ▸ hP) h + +section Cursor + +variable {k : ℕ} (M : TM (k + 1)) (Adv : M.Q → Bool) (choices : ℕ → Bool) (d : Cfg k M.Q) + +/-- Whether the nondeterministic run consumes a guess at step `i`. -/ +def consumes (i : ℕ) : Bool := + !decide ((nrunAt (ofGuess M) choices d i).state = M.qhalt) && + Adv (nrunAt (ofGuess M) choices d i).state + +/-- Where the guess head sits after `i` steps: one cell on for every guess consumed. -/ +def cursor : ℕ → ℕ + | 0 => 1 + | i + 1 => cursor i + (if consumes M Adv choices d i then 1 else 0) + +theorem one_le_cursor (i : ℕ) : 1 ≤ cursor M Adv choices d i := by + induction i with + | zero => exact le_rfl + | succ i ih => rw [cursor]; omega + +theorem cursor_le_succ (i : ℕ) : + cursor M Adv choices d i ≤ cursor M Adv choices d (i + 1) := by + rw [cursor]; omega + +theorem cursor_mono : ∀ {i j : ℕ}, i ≤ j → + cursor M Adv choices d i ≤ cursor M Adv choices d j := by + intro i j + induction j with + | zero => intro h; rw [Nat.le_zero.mp h] + | succ j ih => + intro h + rcases Nat.lt_or_ge i (j + 1) with hlt | hge + · exact le_trans (ih (by omega)) (cursor_le_succ M Adv choices d j) + · have hij : i = j + 1 := by omega + subst hij + exact le_rfl + +theorem cursor_lt_of_consumes {i j : ℕ} (hij : i < j) (hi : consumes M Adv choices d i = true) : + cursor M Adv choices d i < cursor M Adv choices d j := by + refine lt_of_lt_of_le ?_ (cursor_mono M Adv choices d hij) + rw [cursor, if_pos hi] + omega + +theorem cursor_inj_of_consumes {i j : ℕ} (hi : consumes M Adv choices d i = true) + (hj : consumes M Adv choices d j = true) + (h : cursor M Adv choices d i = cursor M Adv choices d j) : i = j := by + rcases Nat.lt_trichotomy i j with hlt | heq | hgt + · exact absurd h (Nat.ne_of_lt (cursor_lt_of_consumes M Adv choices d hlt hi)) + · exact heq + · exact absurd h.symm (Nat.ne_of_lt (cursor_lt_of_consumes M Adv choices d hgt hj)) + +/-- **The guess string that realizes a choice sequence.** Cell `p + 1` holds the choice made at +the step whose cursor is `p + 1`; cells no advancing step ever reads hold whatever falls out. -/ +def guessOf (T : ℕ) (p : ℕ) : Bool := + choices (searchIdx (fun i => + consumes M Adv choices d i && decide (cursor M Adv choices d i = p + 1)) T) + +theorem guessOf_eq {T i : ℕ} (hi : i < T) (hc : consumes M Adv choices d i = true) : + guessOf M Adv choices d T (cursor M Adv choices d i - 1) = choices i := by + have hpos := one_le_cursor M Adv choices d i + rw [guessOf, searchIdx_eq hi (by simp [hc]; omega) ?_] + intro j hj + simp only [Bool.and_eq_true, decide_eq_true_eq] at hj + exact cursor_inj_of_consumes M Adv choices d hj.1 hc (by omega) + +/-- A step moves the guess head on exactly in the advancing states. -/ +theorem work_last_stepCfg' {Adv' : M.Q → Bool} (hP : TM.GuessProtocol M Adv') + (c : Cfg (k + 1) M.Q) (hq : c.state ≠ M.qhalt) + (hread : (c.work (Fin.last k)).read ≠ Γ.start) : + (M.stepCfg c).work (Fin.last k) + = (c.work (Fin.last k)).move (if Adv' c.state then Dir3.right else Dir3.stay) := by + have hw : (M.stepCfg c).work (Fin.last k) + = (c.work (Fin.last k)).writeAndMove (TM.readBackWrite (c.work (Fin.last k)).read) + (if Adv' c.state then Dir3.right else Dir3.stay) := by + show (c.work (Fin.last k)).writeAndMove ((M.δ c.state c.input.read + (fun i => (c.work i).read) c.output.read).2.1 (Fin.last k)) + ((M.δ c.state c.input.read (fun i => (c.work i).read) c.output.read).2.2.2.2.1 + (Fin.last k)) = _ + rw [hP.write _ hq, hP.dir _ hq _ _ _ hread] + rw [hw, TM.writeAndMove_readBack _ hread] + +/-- **Every choice sequence is realized by a loaded guess tape.** Running `M` on the tape +`NTM.guessOf` builds reproduces, step for step, the path of `NTM.ofGuess M` along `choices`: the +guesses land where the advancing steps read them, and the bits the machine never looks at are +free. -/ +theorem traceD_guessOf {Adv : M.Q → Bool} (hP : TM.GuessProtocol M Adv) (T : ℕ) : + ∀ i ≤ T, + dropChoice (M.traceD i (attach d (loadTape (guessOf M Adv choices d T)))) + = nrunAt (ofGuess M) choices d i ∧ + (M.traceD i (attach d (loadTape (guessOf M Adv choices d T)))).work (Fin.last k) + = ⟨cursor M Adv choices d i, (loadTape (guessOf M Adv choices d T)).cells⟩ := by + intro i + induction i with + | zero => + intro _ + refine ⟨by simp, ?_⟩ + show (attach d (loadTape (guessOf M Adv choices d T))).work (Fin.last k) = _ + rw [attach_work_last] + rfl + | succ i ih => + intro hle + obtain ⟨ihd, ihw⟩ := ih (by omega) + have hilt : i < T := by omega + set g := guessOf M Adv choices d T with hg + set c₀ := attach d (loadTape g) with hc₀ + set cᵢ := M.traceD i c₀ with hcᵢ + have hstate : cᵢ.state = (nrunAt (ofGuess M) choices d i).state := by + rw [← ihd]; rfl + by_cases hhalt : cᵢ.state = M.qhalt + · have hcons : consumes M Adv choices d i = false := by + simp [consumes, ← hstate, hhalt] + have hnhalt : (nrunAt (ofGuess M) choices d i).state = (ofGuess M).qhalt := by + rw [← hstate]; exact hhalt + refine ⟨?_, ?_⟩ + · rw [TM.traceD_succ_back, if_pos hhalt, ihd, nrunAt_succ, if_pos hnhalt] + · rw [TM.traceD_succ_back, if_pos hhalt, ihw, cursor, hcons] + simp + · have hcells : (cᵢ.work (Fin.last k)).read + = Γ.ofBool (g (cursor M Adv choices d i - 1)) := by + have hpos := one_le_cursor M Adv choices d i + rw [ihw] + show (loadTape g).cells (cursor M Adv choices d i) = _ + have hc := loadTape_cells_succ g (cursor M Adv choices d i - 1) + rwa [show cursor M Adv choices d i - 1 + 1 = cursor M Adv choices d i by omega] at hc + have hne : (cᵢ.work (Fin.last k)).read ≠ Γ.start := by + rw [hcells]; exact Γ.ofBool_ne_start _ + have hstep : M.traceD (i + 1) c₀ = M.stepCfg cᵢ := by + rw [TM.traceD_succ_back, if_neg hhalt] + have hnstep : nrunAt (ofGuess M) choices d (i + 1) + = stepCfg (ofGuess M) (choices i) (nrunAt (ofGuess M) choices d i) := by + rw [nrunAt_succ, if_neg (by rw [← hstate]; exact hhalt)] + by_cases hadv : Adv cᵢ.state + · have hcons : consumes M Adv choices d i = true := by + simp [consumes, ← hstate, hhalt, hadv] + have hbit : g (cursor M Adv choices d i - 1) = choices i := + guessOf_eq M Adv choices d hilt hcons + refine ⟨?_, ?_⟩ + · rw [hstep, hnstep, ← ihd] + exact dropChoice_stepCfg M (by rw [hcells, hbit]) + · rw [hstep, work_last_stepCfg' M hP cᵢ hhalt hne, if_pos hadv, ihw, cursor, hcons] + rfl + · have hcons : consumes M Adv choices d i = false := by + simp [consumes, ← hstate, hadv] + refine ⟨?_, ?_⟩ + · rw [hstep, hnstep, ← ihd] + rw [dropChoice_stepCfg M hcells] + exact stepCfg_indep M hP hhalt hadv _ _ + · rw [hstep, work_last_stepCfg' M hP cᵢ hhalt hne, if_neg hadv, ihw, cursor, hcons] + rfl + +end Cursor + +/-- **A path of `NTM.ofGuess M` is a run of `M` on a loaded guess tape.** This is the transfer a +nondeterministic construction is built on: design and verify `M` deterministically, with its +guesses arriving on the last work tape, and read the result off here as a statement about the +paths of `NTM.ofGuess M`. Unlike `NTM.ofGuess_trace` it asks nothing of `M` between guesses, so +`M` may be assembled from the ordinary deterministic combinators. -/ +theorem exists_loadTape (M : TM (k + 1)) {Adv : M.Q → Bool} (hP : TM.GuessProtocol M Adv) + (x : List Bool) (T : ℕ) (choices : Fin T → Bool) : + ∃ (g : ℕ → Bool) (c' : Cfg (k + 1) M.Q) (t : ℕ), t ≤ T ∧ + M.reachesIn t (loadCfg M x g) c' ∧ (t < T → M.halted c') ∧ + dropChoice c' = (ofGuess M).trace T choices ((ofGuess M).initCfg x) := by + classical + set ch : ℕ → Bool := fun i => if h : i < T then choices ⟨i, h⟩ else false with hch + refine ⟨guessOf M Adv ch ((ofGuess M).initCfg x) T, + M.traceD T (loadCfg M x (guessOf M Adv ch ((ofGuess M).initCfg x) T)), ?_⟩ + obtain ⟨t, hle, hreach, hstop⟩ := + TM.reachesIn_traceD M T (loadCfg M x (guessOf M Adv ch ((ofGuess M).initCfg x) T)) + refine ⟨t, hle, hreach, hstop, ?_⟩ + have hmain := (traceD_guessOf M ch ((ofGuess M).initCfg x) hP T T le_rfl).1 + have hfun : (ofGuess M).trace T (fun i => ch i.val) ((ofGuess M).initCfg x) + = (ofGuess M).trace T choices ((ofGuess M).initCfg x) := by + congr 1 + funext i + simp [hch, i.isLt] + rw [loadCfg_eq_attach, ← hfun, trace_eq_nrunAt] + exact hmain + +end NTM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/GuessTape.lean b/Complexitylib/Models/TuringMachine/GuessTape.lean new file mode 100644 index 00000000..ec605a07 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/GuessTape.lean @@ -0,0 +1,307 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.ChoiceTape + +/-! +# Building a nondeterministic machine from a deterministic one + +`Complexitylib.Models.TuringMachine.ChoiceTape` runs one path of a given `NTM` deterministically. +This file goes the other way, which is what a *construction* needs: it turns a deterministic +machine that reads a **guess tape** into a nondeterministic machine whose choices supply that +tape's contents. + +The point is leverage. Every subroutine in `Complexitylib.Models.TuringMachine.Subroutines` is +deterministic, and so is every Hoare-style contract proved about them. Assembling an `NTM` by +hand forgoes all of it. Assembling a `TM` that consults one extra tape for its guesses, and then +applying `NTM.ofGuess`, keeps the whole toolkit and confines the nondeterminism to a single +tape read. + +## Conventions + +The guess tape is the **last** work tape, matching `NTM.choiceTM`. A machine that uses it as a +guess tape must, at every step, write the cell back unchanged and move that head one cell right — +that is `TM.GuessDiscipline`. The discipline is what makes the guesses independent: the machine +consumes exactly one fresh bit per step and can never revisit one. + +## Main definitions + +- `NTM.ofGuess` — the nondeterministic machine a guess-reading deterministic machine denotes +- `TM.GuessDiscipline` — write the guess cell back, advance its head +- `Tape.BoolFrom` — the guess tape holds Boolean symbols for the next `T` cells + +## Main results + +- `NTM.choiceTM_ofGuess_δ` — the round trip is the identity on transitions +- `NTM.step_ofGuess` — and on steps, wherever the guess cell holds a bit +- `NTM.reachesIn_ofGuess_iff` — and on runs +- `NTM.ofGuess_simulates` — a `T`-step run of `M` on a loaded guess tape is a trace of + `NTM.ofGuess M` along the bits loaded onto it +-/ + +@[expose] public section + +namespace Complexity + +namespace Tape + +/-- The next `T` cells from the head hold Boolean symbols. -/ +def BoolFrom (t : Tape) (T : ℕ) : Prop := + ∀ j < T, ∃ b : Bool, t.cells (t.head + j) = Γ.ofBool b + +theorem BoolFrom.read {t : Tape} {T : ℕ} (h : t.BoolFrom (T + 1)) : + ∃ b : Bool, t.read = Γ.ofBool b := by + obtain ⟨b, hb⟩ := h 0 (Nat.succ_pos T) + exact ⟨b, by simpa [Tape.read] using hb⟩ + +theorem BoolFrom.read_ne_start {t : Tape} {T : ℕ} (h : t.BoolFrom (T + 1)) : + t.read ≠ Γ.start := by + obtain ⟨b, hb⟩ := h.read + rw [hb] + exact Γ.ofBool_ne_start b + +theorem BoolFrom.move_right {t : Tape} {T : ℕ} (h : t.BoolFrom (T + 1)) : + (t.move Dir3.right).BoolFrom T := by + intro j hj + obtain ⟨b, hb⟩ := h (j + 1) (by omega) + refine ⟨b, ?_⟩ + show t.cells (t.head + 1 + j) = Γ.ofBool b + rw [show t.head + 1 + j = t.head + (j + 1) by omega] + exact hb + +theorem BoolFrom.mono {t : Tape} {T T' : ℕ} (h : t.BoolFrom T) (hle : T' ≤ T) : + t.BoolFrom T' := + fun j hj => h j (by omega) + +end Tape + +namespace TM + +variable {k : ℕ} + +/-- **The guess-tape discipline.** At every transition the machine writes the last work tape's +cell back unchanged and advances that head one cell right, so it consumes exactly one fresh +guess per step and never revisits one. -/ +structure GuessDiscipline (M : TM (k + 1)) : Prop where + /-- The guess cell is written back unchanged. -/ + write : ∀ (q : M.Q) (iHead : Γ) (wHeads : Fin (k + 1) → Γ) (oHead : Γ), + (M.δ q iHead wHeads oHead).2.1 (Fin.last k) = readBackWrite (wHeads (Fin.last k)) + /-- The guess head advances one cell right. -/ + dir : ∀ (q : M.Q) (iHead : Γ) (wHeads : Fin (k + 1) → Γ) (oHead : Γ), + (M.δ q iHead wHeads oHead).2.2.2.2.1 (Fin.last k) = Dir3.right + +end TM + +namespace NTM + +variable {k : ℕ} + +/-- **The nondeterministic machine a guess-reading deterministic machine denotes.** The choice +bit is fed to `M` as the symbol under the last work head, and that tape disappears. -/ +def ofGuess (M : TM (k + 1)) : NTM k where + Q := M.Q + qstart := M.qstart + qhalt := M.qhalt + δ b q iHead wHeads oHead := + let r := M.δ q iHead (Fin.snoc wHeads (Γ.ofBool b)) oHead + (r.1, fun j => r.2.1 j.castSucc, r.2.2.1, r.2.2.2.1, + fun j => r.2.2.2.2.1 j.castSucc, r.2.2.2.2.2) + δ_right_of_start := by + intro b q iHead wHeads oHead + have h := M.δ_right_of_start q iHead (Fin.snoc wHeads (Γ.ofBool b)) oHead + dsimp only at h ⊢ + refine ⟨h.1, fun i hi => ?_, h.2.2⟩ + exact h.2.1 i.castSucc (by rwa [Fin.snoc_castSucc]) + +@[simp] theorem ofGuess_Q (M : TM (k + 1)) : (ofGuess M).Q = M.Q := rfl + +@[simp] theorem ofGuess_qhalt (M : TM (k + 1)) : (ofGuess M).qhalt = M.qhalt := rfl + +@[simp] theorem ofGuess_qstart (M : TM (k + 1)) : (ofGuess M).qstart = M.qstart := rfl + +private theorem snoc_init_self' {α : Type} (f : Fin (k + 1) → α) : + Fin.snoc (fun j => f j.castSucc) (f (Fin.last k)) = f := + Fin.snoc_init_self f + +/-- **The round trip is the identity on transitions.** Reattaching the guess tape to +`NTM.ofGuess M` recovers `M`, wherever the guess cell holds a bit. -/ +theorem choiceTM_ofGuess_δ (M : TM (k + 1)) (hM : TM.GuessDiscipline M) + (q : M.Q) (iHead : Γ) (wHeads : Fin (k + 1) → Γ) (oHead : Γ) (b : Bool) + (hb : wHeads (Fin.last k) = Γ.ofBool b) : + (choiceTM (ofGuess M)).δ q iHead wHeads oHead = M.δ q iHead wHeads oHead := by + have hcell : Γ.ofBool (decide (wHeads (Fin.last k) = Γ.one)) = wHeads (Fin.last k) := by + rw [hb]; cases b <;> decide + dsimp only [choiceTM, ofGuess] + rw [hcell, snoc_init_self' wHeads, ← hM.write q iHead wHeads oHead, + ← hM.dir q iHead wHeads oHead, snoc_init_self', snoc_init_self'] + +/-- **The round trip is the identity on steps**, wherever the guess cell holds a bit. -/ +theorem step_ofGuess (M : TM (k + 1)) (hM : TM.GuessDiscipline M) {c : Cfg (k + 1) M.Q} + (hb : ∃ b : Bool, (c.work (Fin.last k)).read = Γ.ofBool b) : + (choiceTM (ofGuess M)).step c = M.step c := by + obtain ⟨b, hbv⟩ := hb + by_cases hhalt : c.state = M.qhalt + · have h1 : (choiceTM (ofGuess M)).step c = none := by + unfold TM.step + simp [hhalt, choiceTM, ofGuess] + have h2 : M.step c = none := by + unfold TM.step + simp [hhalt] + rw [h1, h2] + rfl + · rw [TM.step_of_not_halted (choiceTM (ofGuess M)) hhalt, TM.step_of_not_halted M hhalt] + have hδ := choiceTM_ofGuess_δ M hM c.state c.input.read (fun i => (c.work i).read) + c.output.read b hbv + simp only [TM.stepCfg, hδ] + rfl + +/-- **A step leaves the guess tape alone and advances its head.** -/ +theorem work_last_stepCfg (M : TM (k + 1)) (hM : TM.GuessDiscipline M) (c : Cfg (k + 1) M.Q) + (hread : (c.work (Fin.last k)).read ≠ Γ.start) : + (M.stepCfg c).work (Fin.last k) = (c.work (Fin.last k)).move Dir3.right := by + show (c.work (Fin.last k)).writeAndMove ((M.δ c.state c.input.read + (fun i => (c.work i).read) c.output.read).2.1 (Fin.last k)) + ((M.δ c.state c.input.read (fun i => (c.work i).read) c.output.read).2.2.2.2.1 + (Fin.last k)) + = (c.work (Fin.last k)).move Dir3.right + rw [hM.write, hM.dir] + exact TM.writeAndMove_readBack _ hread Dir3.right + +/-- **The round trip is the identity on runs**, as long as the guess tape holds bits for as many +cells as the run has steps. -/ +theorem reachesIn_ofGuess_iff (M : TM (k + 1)) (hM : TM.GuessDiscipline M) : + ∀ (t : ℕ) (c c' : Cfg (k + 1) M.Q), (c.work (Fin.last k)).BoolFrom t → + ((choiceTM (ofGuess M)).reachesIn t c c' ↔ M.reachesIn t c c') := by + intro t + induction t with + | zero => + intro c c' _ + rw [TM.reachesIn_zero_iff, TM.reachesIn_zero_iff] + exact Iff.rfl + | succ t ih => + intro c c' hbool + by_cases hhalt : c.state = M.qhalt + · have h1 : M.step c = none := by + unfold TM.step + simp [hhalt] + constructor + · intro h + rw [TM.reachesIn_succ_iff] at h + obtain ⟨c₁, hs, -⟩ := h + rw [step_ofGuess M hM hbool.read, h1] at hs + exact absurd hs (by simp) + · intro h + rw [TM.reachesIn_succ_iff] at h + obtain ⟨c₁, hs, -⟩ := h + rw [h1] at hs + exact absurd hs (by simp) + · have hstep : M.step c = some (M.stepCfg c) := TM.step_of_not_halted M hhalt + have hbool₁ : ((M.stepCfg c).work (Fin.last k)).BoolFrom t := by + rw [work_last_stepCfg M hM c hbool.read_ne_start] + exact hbool.move_right + constructor + · intro h + rw [TM.reachesIn_succ_iff] at h + obtain ⟨c₁, hs, hr⟩ := h + rw [step_ofGuess M hM hbool.read, hstep] at hs + have hs' : M.stepCfg c = c₁ := Option.some.inj hs + subst hs' + exact TM.reachesIn.step hstep ((ih _ c' hbool₁).mp hr) + · intro h + rw [TM.reachesIn_succ_iff] at h + obtain ⟨c₁, hs, hr⟩ := h + rw [hstep] at hs + have hs' : M.stepCfg c = c₁ := Option.some.inj hs + subst hs' + refine TM.reachesIn.step ?_ ((ih _ c' hbool₁).mpr hr) + rw [step_ofGuess M hM hbool.read] + exact hstep + +/-- **A run of `M` on a loaded guess tape is a trace of `NTM.ofGuess M`.** This is the transfer +that lets a nondeterministic construction be carried out deterministically: build `M`, prove +whatever is wanted of its runs with the deterministic toolkit, and read it off here as a +statement about the paths of `NTM.ofGuess M`. -/ +theorem ofGuess_simulates (M : TM (k + 1)) (hM : TM.GuessDiscipline M) (T : ℕ) + (c : Cfg (k + 1) M.Q) + (hinv : (c.work (Fin.last k)).StartInvariant) + (hhead : 1 ≤ (c.work (Fin.last k)).head) + (hbool : (c.work (Fin.last k)).BoolFrom T) : + ∃ (c' : Cfg (k + 1) M.Q) (t : ℕ), t ≤ T ∧ M.reachesIn t c c' ∧ + (t < T → M.halted c') ∧ + dropChoice c' = (ofGuess M).trace T (fun j => choiceStream c j.val) (dropChoice c) := by + obtain ⟨c', t, hle, hreach, hstop, heq⟩ := choiceTM_simulates (ofGuess M) T c hinv hhead + exact ⟨c', t, hle, (reachesIn_ofGuess_iff M hM t c c' (hbool.mono hle)).mp hreach, hstop, heq⟩ + +/-- **Reading back a loaded guess tape.** A tape whose cells from the head onward spell `g` +presents exactly `g` as its choice stream. -/ +theorem choiceStream_of_loaded {Q : Type} {c : Cfg (k + 1) Q} {g : ℕ → Bool} {T : ℕ} + (h : ∀ j < T, (c.work (Fin.last k)).cells ((c.work (Fin.last k)).head + j) = Γ.ofBool (g j)) + {j : ℕ} (hj : j < T) : choiceStream c j = g j := by + rw [choiceStream, h j hj] + cases g j <;> decide + +/-! ## Loading a guess tape -/ + +/-- The guess tape carrying `g`: cell `j + 1` holds `g j`, and the head starts on cell 1. -/ +def loadTape (g : ℕ → Bool) : Tape where + head := 1 + cells := fun j => if j = 0 then Γ.start else Γ.ofBool (g (j - 1)) + +@[simp] theorem loadTape_head (g : ℕ → Bool) : (loadTape g).head = 1 := rfl + +theorem loadTape_cells_succ (g : ℕ → Bool) (j : ℕ) : + (loadTape g).cells (j + 1) = Γ.ofBool (g j) := by + simp [loadTape] + +theorem loadTape_startInvariant (g : ℕ → Bool) : (loadTape g).StartInvariant := by + refine ⟨by simp [loadTape], fun j hj => ?_⟩ + obtain ⟨j, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [loadTape_cells_succ] + exact Γ.ofBool_ne_start _ + +theorem loadTape_boolFrom (g : ℕ → Bool) (T : ℕ) : (loadTape g).BoolFrom T := by + intro j _ + exact ⟨g j, by simp [loadTape]⟩ + +/-- The starting configuration of the deterministic machine: the input in place, every work tape +blank except the last, which carries the guesses. -/ +def loadCfg (M : TM (k + 1)) (x : List Bool) (g : ℕ → Bool) : Cfg (k + 1) M.Q where + state := M.qstart + input := Tape.init (x.map Γ.ofBool) + work := Fin.snoc (fun _ => Tape.init ([] : List Γ)) (loadTape g) + output := Tape.init ([] : List Γ) + +@[simp] theorem loadCfg_work_last (M : TM (k + 1)) (x : List Bool) (g : ℕ → Bool) : + (loadCfg M x g).work (Fin.last k) = loadTape g := by + simp [loadCfg] + +theorem dropChoice_loadCfg (M : TM (k + 1)) (x : List Bool) (g : ℕ → Bool) : + dropChoice (loadCfg M x g) = (ofGuess M).initCfg x := by + refine Cfg.ext rfl rfl ?_ rfl + funext i + simp [dropChoice, loadCfg] + +/-- **The paths of `NTM.ofGuess M` are the runs of `M` on a loaded guess tape.** This is the +form a construction uses: design `M` so that its run on guess string `g` does what the path +along `g` should do, and this reads that back as a statement about `NTM.ofGuess M`. -/ +theorem ofGuess_trace (M : TM (k + 1)) (hM : TM.GuessDiscipline M) (x : List Bool) (T : ℕ) + (g : ℕ → Bool) : + ∃ (c' : Cfg (k + 1) M.Q) (t : ℕ), t ≤ T ∧ M.reachesIn t (loadCfg M x g) c' ∧ + (t < T → M.halted c') ∧ + dropChoice c' = (ofGuess M).trace T (fun j => g j.val) ((ofGuess M).initCfg x) := by + obtain ⟨c', t, hle, hreach, hstop, heq⟩ := ofGuess_simulates M hM T (loadCfg M x g) + (by simpa using loadTape_startInvariant g) (by simp) (by simpa using loadTape_boolFrom g T) + refine ⟨c', t, hle, hreach, hstop, ?_⟩ + rw [heq] + congr 1 + · funext j + exact choiceStream_of_loaded (T := T) + (fun i _ => by simp [loadCfg, loadTape]) j.isLt + · exact dropChoice_loadCfg M x g + +end NTM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean index 2ea9cef0..8ee95467 100644 --- a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean @@ -30,6 +30,10 @@ limit, or tape frames. Clients record those endpoint facts in - `BinaryForLoopSpec.reachesIn` composes a certified loop exactly. - `BinaryForLoopSpaceSpec.prefix_withinAuxSpace` covers every run prefix. - `IsTransducer.binaryForTM` preserves one-way output safety. +- `binaryForTM_hoareTime` runs the loop from a per-index contract for its body, + for clients whose bodies come as Hoare triples rather than closed forms. +- `guessProtocol_binaryForTM` carries a body's guess-tape discipline through + the loop, so a nondeterministic body may be driven by one. -/ @@ -168,12 +172,46 @@ theorem BinaryForLoopSpaceSpec.prefix_withinAuxSpace c.WithinAuxSpace inputLength spaceBound := spaceSpec.prefix_withinAuxSpace_internal count value t c hlimit hreach htime +/-- **A count-up loop from a contract for its body.** + +`BinaryForLoopSpec` asks for a canonical configuration at every loop index, +which presumes a body whose tape effect is known in closed form. A body +assembled from Hoare triples has no such form — its contract only asserts that +some halting run exists — so this rule takes the per-index triple directly: +if the body carries `BinaryForFrame` at `value` to `BinaryForBodyPost` at +`value`, the driver runs the whole loop from counter zero to `limitValue`. -/ +theorem binaryForTM_hoareTime {body : TM n} + {counterIdx limitIdx : Fin n} (hne : counterIdx ≠ limitIdx) + (limitValue : ℕ) (bodyTime : ℕ → ℕ) (P : ℕ → TapePred n) + (hbody : ∀ value, value < limitValue → + body.HoareTime (BinaryForFrame counterIdx limitIdx limitValue P value) + (BinaryForBodyPost counterIdx limitIdx limitValue P value) + (bodyTime value)) : + (binaryForTM body counterIdx limitIdx).HoareTime + (BinaryForFrame counterIdx limitIdx limitValue P 0) + (BinaryForFrame counterIdx limitIdx limitValue P limitValue) + (binaryForLoopTime bodyTime limitValue 0 limitValue) := + binaryForTM_hoareTime_internal body counterIdx limitIdx hne limitValue + bodyTime P hbody + /-- A binary count-up loop preserves the body's one-way-output discipline. -/ theorem IsTransducer.binaryForTM {body : TM n} (hbody : body.IsTransducer) (counterIdx limitIdx : Fin n) : (binaryForTM body counterIdx limitIdx).IsTransducer := hbody.binaryForTM_internal counterIdx limitIdx +/-- **The guess protocol survives a count-up loop.** The driver rewrites every +tape it does not own and holds their heads still, so a body that consumes its +guesses only in its advancing states keeps doing so inside the loop. The +counter and the limit must not be the guess tape itself. -/ +theorem guessProtocol_binaryForTM {k : ℕ} {body : TM (k + 1)} + {Adv : body.Q → Bool} (hbody : body.GuessProtocol Adv) + (counterIdx limitIdx : Fin (k + 1)) (hcounter : counterIdx ≠ Fin.last k) + (hlimit : limitIdx ≠ Fin.last k) : + (binaryForTM body counterIdx limitIdx).GuessProtocol + (binaryForAdv Adv counterIdx limitIdx) := + guessProtocol_binaryForTM_internal hbody counterIdx limitIdx hcounter hlimit + end TM end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean index 9bbb90fe..af89ab54 100644 --- a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean @@ -6,6 +6,7 @@ Authors: Samuel Schlesinger module public import Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import Complexitylib.Models.TuringMachine.Hoare.Defs /-! # Canonical binary count-up loops — definitions @@ -280,6 +281,40 @@ structure BinaryForLoopSpaceSpec {n : ℕ} {body : TM n} (spec.iterationStartCfg value) cfg → cfg.WithinAuxSpace inputLength spaceBound +/-- The loop-carried tape condition at counter value `value`: the client +invariant `P value`, a canonical counter and preserved limit, and off-marker +heads on every tape. + +This is the precondition the driver hands the body at each iteration and the +postcondition it re-establishes before the next comparison. -/ +def BinaryForFrame {n : ℕ} (counterIdx limitIdx : Fin n) (limitValue : ℕ) + (P : ℕ → TapePred n) (value : ℕ) : TapePred n := + fun inp work out => + P value inp work out ∧ + (work counterIdx).HasBinaryNat value ∧ + (work limitIdx).HasBinaryNat limitValue ∧ + inp.read ≠ Γ.start ∧ + (∀ i, (work i).read ≠ Γ.start) ∧ + out.read ≠ Γ.start + +/-- What a loop body must establish before the driver increments the counter. + +The body leaves the counter and limit canonical and every head off the left +marker, and it promises the *next* invariant for whatever canonical +representation of `value + 1` the successor subroutine goes on to leave in the +counter slot. Stating the last clause with `Function.update` keeps the body's +obligation independent of how `binarySuccTM` lays out its result. -/ +def BinaryForBodyPost {n : ℕ} (counterIdx limitIdx : Fin n) (limitValue : ℕ) + (P : ℕ → TapePred n) (value : ℕ) : TapePred n := + fun inp work out => + (work counterIdx).HasBinaryNat value ∧ + (work limitIdx).HasBinaryNat limitValue ∧ + inp.read ≠ Γ.start ∧ + (∀ i, (work i).read ≠ Γ.start) ∧ + out.read ≠ Γ.start ∧ + ∀ t : Tape, t.HasBinaryNat (value + 1) → + P (value + 1) inp (Function.update work counterIdx t) out + end TM end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean index cecc15be..13491613 100644 --- a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean @@ -7,6 +7,7 @@ Authors: Samuel Schlesinger module public import Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Comparison public import Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Loop +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Hoare /-! # Canonical binary count-up loops — internal proofs diff --git a/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Hoare.lean b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Hoare.lean new file mode 100644 index 00000000..4b1c067c --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Hoare.lean @@ -0,0 +1,291 @@ +/- +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 Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Comparison +public import Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Control +public import Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import Complexitylib.Models.TuringMachine.Hoare +public import Complexitylib.Models.TuringMachine.Registers +public import Complexitylib.Models.TuringMachine.GuessAssembly + +/-! +# Canonical binary count-up loops — Hoare-style driver, internal proofs + +`BinaryForLoopSpec` asks a client for a canonical configuration at every loop +index, which presumes a body whose tape effect is available in closed form. +Bodies assembled from Hoare triples do not have that shape: their contracts +only assert that *some* halting run exists. This module closes the gap by +running the loop composition directly on existential contracts, so a client +needs nothing but a per-index triple for its body. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- A canonical binary tape is parked: its head sits off the left marker and +no cell to the right of cell zero holds `▷`. -/ +theorem Parked.of_hasBinaryNat {t : Tape} {value : ℕ} + (h : t.HasBinaryNat value) : Parked t := + ⟨by rw [h.2.1], Tape.HasBinaryContent.cells_ne_start h.2.2⟩ + +/-- Canonical successor turns the body's postcondition back into the loop +frame at the next counter value. -/ +private theorem binarySuccTM_binaryForFrame_hoareTime + (counterIdx limitIdx : Fin n) (hne : counterIdx ≠ limitIdx) + (limitValue : ℕ) (P : ℕ → TapePred n) (value : ℕ) : + (binarySuccTM counterIdx).HoareTime + (BinaryForBodyPost counterIdx limitIdx limitValue P value) + (BinaryForFrame counterIdx limitIdx limitValue P (value + 1)) + (binarySuccTime value) := by + intro inp work out hpre + obtain ⟨hcnt, hlim, hinp, hwork, hout, hnext⟩ := hpre + obtain ⟨c', hreach, hhalt, hinp', hother', hcnt', hout'⟩ := + binarySuccTM_reachesIn_frame counterIdx value inp work out hcnt hinp + (fun i hi => hwork i) hout + refine ⟨c', binarySuccTime value, Nat.le_refl _, hreach, hhalt, ?_⟩ + have hupd : c'.work = Function.update work counterIdx (c'.work counterIdx) := by + funext i + by_cases hi : i = counterIdx + · subst hi + rw [Function.update_self] + · rw [Function.update_of_ne hi, hother' i hi] + refine ⟨?_, hcnt', ?_, ?_, ?_, ?_⟩ + · rw [hinp', hout', hupd] + exact hnext _ hcnt' + · rw [hother' limitIdx (Ne.symm hne)] + exact hlim + · rw [hinp'] + exact hinp + · intro i + by_cases hi : i = counterIdx + · subst hi + exact (Parked.of_hasBinaryNat hcnt').read_ne_start + · rw [hother' i hi] + exact hwork i + · rw [hout'] + exact hout + +/-- The `seqTM` seam between the body and the successor preserves the body's +postcondition, since every head is off the left marker. -/ +private theorem binaryForBodyPost_transition + (counterIdx limitIdx : Fin n) (limitValue : ℕ) (P : ℕ → TapePred n) + (value : ℕ) : + ∀ inp work out, + BinaryForBodyPost counterIdx limitIdx limitValue P value inp work out → + BinaryForBodyPost counterIdx limitIdx limitValue P value + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hmid + have hinp : transitionInput inp = inp := + transitionInput_eq_self hmid.2.2.1 + have hwork : (fun i => transitionTape (work i)) = work := + funext fun i => transitionTape_eq_self (hmid.2.2.2.1 i) + have hout : transitionTape out = out := + transitionTape_eq_self hmid.2.2.2.2.1 + rw [hinp, hwork, hout] + exact hmid + +/-- One composite iteration — body, seam, successor — carries the loop frame +from `value` to `value + 1` in the advertised time. -/ +private theorem binaryForIterationTM_hoareTime + (body : TM n) (counterIdx limitIdx : Fin n) (hne : counterIdx ≠ limitIdx) + (limitValue : ℕ) (bodyTime : ℕ → ℕ) (P : ℕ → TapePred n) (value : ℕ) + (hbody : body.HoareTime + (BinaryForFrame counterIdx limitIdx limitValue P value) + (BinaryForBodyPost counterIdx limitIdx limitValue P value) + (bodyTime value)) : + (binaryForIterationTM body counterIdx).HoareTime + (BinaryForFrame counterIdx limitIdx limitValue P value) + (BinaryForFrame counterIdx limitIdx limitValue P (value + 1)) + (binaryForIterationTime bodyTime value) := + seqTM_hoareTime body (binarySuccTM counterIdx) hbody + (binaryForBodyPost_transition counterIdx limitIdx limitValue P value) + (binarySuccTM_binaryForFrame_hoareTime counterIdx limitIdx hne limitValue + P value) + +/-- The remaining count-up loop runs from any frame-satisfying start. -/ +private theorem binaryForTM_loop_hoareTime + (body : TM n) (counterIdx limitIdx : Fin n) (hne : counterIdx ≠ limitIdx) + (limitValue : ℕ) (bodyTime : ℕ → ℕ) (P : ℕ → TapePred n) + (hbody : ∀ value, value < limitValue → + body.HoareTime (BinaryForFrame counterIdx limitIdx limitValue P value) + (BinaryForBodyPost counterIdx limitIdx limitValue P value) + (bodyTime value)) : + ∀ count value, value + count = limitValue → + (binaryForTM body counterIdx limitIdx).HoareTime + (BinaryForFrame counterIdx limitIdx limitValue P value) + (BinaryForFrame counterIdx limitIdx limitValue P limitValue) + (binaryForLoopTime bodyTime limitValue value count) := by + intro count + induction count with + | zero => + intro value hvalue inp work out hframe + have hval : value = limitValue := by omega + subst hval + obtain ⟨hP, hcnt, hlim, hinp, hwork, hout⟩ := hframe + refine ⟨{ state := .inl .done, input := inp, work := work, output := out }, + binaryForCompareTime value, Nat.le_refl _, ?_, rfl, + ⟨hP, hcnt, hlim, hinp, hwork, hout⟩⟩ + exact binaryForTM_compare_reachesIn_frame_of_eq_internal body counterIdx limitIdx + hne value inp work out hcnt hlim hinp (fun i hi hj => hwork i) hout + | succ count ih => + intro value hvalue inp work out hframe + have hlt : value < limitValue := by omega + obtain ⟨hP, hcnt, hlim, hinp, hwork, hout⟩ := hframe + have hcompare := binaryForTM_compare_reachesIn_frame_of_lt_internal body counterIdx + limitIdx hne value limitValue hlt inp work out hcnt hlim hinp + (fun i hi hj => hwork i) hout + obtain ⟨c₂, t₂, ht₂, hreach₂, hhalt₂, hframe₂⟩ := + binaryForIterationTM_hoareTime body counterIdx limitIdx hne limitValue + bodyTime P value (hbody value hlt) inp work out + ⟨hP, hcnt, hlim, hinp, hwork, hout⟩ + have hlift := binaryForTM_iteration_reachesIn_internal body counterIdx + limitIdx hreach₂ + have hseam := binaryForTM_step_iteration_halt_internal body counterIdx + limitIdx c₂ hhalt₂ hframe₂.2.2.2.1 hframe₂.2.2.2.2.1 hframe₂.2.2.2.2.2 + obtain ⟨c₃, t₃, ht₃, hreach₃, hhalt₃, hpost₃⟩ := + ih (value + 1) (by omega) c₂.input c₂.work c₂.output hframe₂ + refine ⟨c₃, binaryForCompareTime limitValue + t₂ + 1 + t₃, ?_, ?_, hhalt₃, + hpost₃⟩ + · simp only [binaryForLoopTime] + omega + · have r₁ := reachesIn_trans _ hcompare hlift + have r₂ := reachesIn_trans _ r₁ (reachesIn.step hseam reachesIn.zero) + exact reachesIn_trans _ r₂ hreach₃ + +/-- **A count-up loop from a contract for its body.** A body that carries the +loop frame from `value` to the pre-successor postcondition at every index runs +the whole loop, from counter zero to the limit, within the advertised time. -/ +theorem binaryForTM_hoareTime_internal + (body : TM n) (counterIdx limitIdx : Fin n) (hne : counterIdx ≠ limitIdx) + (limitValue : ℕ) (bodyTime : ℕ → ℕ) (P : ℕ → TapePred n) + (hbody : ∀ value, value < limitValue → + body.HoareTime (BinaryForFrame counterIdx limitIdx limitValue P value) + (BinaryForBodyPost counterIdx limitIdx limitValue P value) + (bodyTime value)) : + (binaryForTM body counterIdx limitIdx).HoareTime + (BinaryForFrame counterIdx limitIdx limitValue P 0) + (BinaryForFrame counterIdx limitIdx limitValue P limitValue) + (binaryForLoopTime bodyTime limitValue 0 limitValue) := + binaryForTM_loop_hoareTime body counterIdx limitIdx hne limitValue bodyTime P + hbody limitValue 0 (Nat.zero_add limitValue) + +/-- The advancing states of a count-up loop are the body's, taken inside the +composite iteration. The driver and the counter's successor never consult the +guess tape. -/ +def binaryForAdv {k : ℕ} {body : TM (k + 1)} (Adv : body.Q → Bool) + (counterIdx limitIdx : Fin (k + 1)) : + (binaryForTM body counterIdx limitIdx).Q → Bool := + Sum.elim (fun _ => false) (seqAdv Adv (fun _ => false)) + +/-- Canonical successor never consults the guess tape. -/ +theorem guessProtocol_binarySuccTM {k : ℕ} (idx : Fin (k + 1)) + (hidx : idx ≠ Fin.last k) : + GuessProtocol (binarySuccTM idx) (fun _ => false) := by + have hne : Fin.last k ≠ idx := fun h => hidx h.symm + refine ⟨?_, ?_, ?_⟩ + · intro q hq iHead wHeads oHead + cases q with + | carry => cases hw : wHeads idx <;> simp [binarySuccTM, hw, hne] + | rewind => by_cases hs : wHeads idx = Γ.start <;> simp [binarySuccTM, hs] + | done => exact absurd rfl hq + · intro q hq iHead wHeads oHead hg + cases q with + | carry => cases hw : wHeads idx <;> simp [binarySuccTM, hw, hne, idleDir, hg] + | rewind => + by_cases hs : wHeads idx = Γ.start <;> + simp [binarySuccTM, hs, hne, idleDir, hg] + | done => exact absurd rfl hq + · intro q hq _ iHead ww oHead g g' + obtain ⟨j, rfl⟩ := Fin.exists_castSucc_eq.mpr hidx + cases q with + | carry => + simp only [binarySuccTM, Fin.snoc_castSucc] + cases hw : ww j <;> simp [visible, Fin.snoc_castSucc] + | rewind => + by_cases hs : ww j = Γ.start <;> + simp [binarySuccTM, visible, Fin.snoc_castSucc, hs] + | done => simp [binarySuccTM, visible, allIdle, Fin.snoc_castSucc] + +/-- **The guess protocol survives a count-up loop.** The driver reads and +rewrites only the counter, the limit, and whatever the body touches, so a body +that consumes its guesses in the advancing states keeps doing so inside the +loop. -/ +theorem guessProtocol_binaryForTM_internal {k : ℕ} {body : TM (k + 1)} {Adv : body.Q → Bool} + (hbody : GuessProtocol body Adv) (counterIdx limitIdx : Fin (k + 1)) + (hcounter : counterIdx ≠ Fin.last k) (hlimit : limitIdx ≠ Fin.last k) : + GuessProtocol (binaryForTM body counterIdx limitIdx) + (binaryForAdv Adv counterIdx limitIdx) := by + have hiter : GuessProtocol (binaryForIterationTM body counterIdx) + (seqAdv Adv (fun _ => false)) := + guessProtocol_seqTM hbody (guessProtocol_binarySuccTM counterIdx hcounter) + have hc : ¬ (Fin.last k = counterIdx) := fun h => hcounter h.symm + have hl : ¬ (Fin.last k = limitIdx) := fun h => hlimit h.symm + refine ⟨?_, ?_, ?_⟩ + · intro q hq iHead wHeads oHead + match q with + | .inl (.scan e) => + dsimp only [binaryForTM] + split <;> rfl + | .inl (.rewind e) => + dsimp only [binaryForTM] + split <;> rfl + | .inl .done => exact absurd rfl hq + | .inr q => + by_cases hqh : q = (binaryForIterationTM body counterIdx).qhalt + · subst hqh + simp [binaryForTM, allReadBack] + · have h := hiter.write q hqh iHead wHeads oHead + simpa [binaryForTM, hqh] using h + · intro q hq iHead wHeads oHead hg + match q with + | .inl (.scan e) => + dsimp only [binaryForTM, binaryForAdv] + split <;> simp [hc, hl, idleDir, hg] + | .inl (.rewind e) => + dsimp only [binaryForTM, binaryForAdv] + split <;> simp [hc, hl, idleDir, hg] + | .inl .done => exact absurd rfl hq + | .inr q => + by_cases hqh : q = (binaryForIterationTM body counterIdx).qhalt + · subst hqh + simp [binaryForTM, binaryForAdv, seqAdv, allReadBack, idleDir, hg, + binaryForIterationTM, seqTM] + · have h := hiter.dir q hqh iHead wHeads oHead hg + simpa [binaryForTM, binaryForAdv, hqh] using h + · intro q hq hadv iHead ww oHead g g' + obtain ⟨jc, hjc⟩ := Fin.exists_castSucc_eq.mpr hcounter + obtain ⟨jl, hjl⟩ := Fin.exists_castSucc_eq.mpr hlimit + match q with + | .inl (.scan e) => + subst hjc + subst hjl + by_cases hb : ww jc = Γ.blank ∧ ww jl = Γ.blank <;> + simp [binaryForTM, visible, Fin.snoc_castSucc, hb] + | .inl (.rewind e) => + subst hjc + subst hjl + by_cases hb : ww jc = Γ.start ∧ ww jl = Γ.start <;> + simp [binaryForTM, visible, Fin.snoc_castSucc, hb] + | .inl .done => exact absurd rfl hq + | .inr q => + by_cases hqh : q = (binaryForIterationTM body counterIdx).qhalt + · subst hqh + simp [binaryForTM, visible, allReadBack, Fin.snoc_castSucc] + · have h := hiter.indep q hqh (by simpa [binaryForAdv] using hadv) iHead ww + oHead g g' + simpa [binaryForTM, visible, hqh] using h + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/InputMatch.lean b/Complexitylib/Models/TuringMachine/Subroutines/InputMatch.lean new file mode 100644 index 00000000..2b11c59d --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/InputMatch.lean @@ -0,0 +1,573 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Hoare +public import Complexitylib.Models.TuringMachine.Combinators +public import Complexitylib.Models.TuringMachine.Subroutines.MoveLeftStep +public import Complexitylib.Models.TuringMachine.ChoiceTape +public import Complexitylib.Models.TuringMachine.GuessStream + +/-! +# Checking a guessed symbol against the input head + +A scan reads work tapes. The one thing it cannot see is the input tape, so a machine that +simulates another machine's input head has to compare the symbol under that head against what it +guessed by hand. + +`TM.inMatchTM` does exactly that, in two steps: it compares the two cells of a register against +the two bits a caller-supplied encoding assigns to the symbol under the input head, and leaves the +verdict on a result register. The input head does not move, so a simulation whose input head sits +at the simulated position keeps it there. + +## Main definitions + +- `TM.inMatchTM` — the check +- `TM.inMoveTM` — moving the input head by a guessed direction held in two one-cell registers, so + it tracks the simulated one +- `TM.copyCellTM` — copying one register's cell onto another, which is how a scan's verdict leaves + the result tape +- `TM.andCellTM` — conjoining one register's cell into another, which is how a machine with no + early exit remembers that a check failed + +## Main results + +- `TM.inMatchTM_hoareTime` — its contract: two steps, the verdict on the result register, the + compared register rewound, every other tape untouched +- `TM.inMoveTM_hoareTime` — and the move's: one step, the input head where the register says +- `TM.copyCellTM_hoareTime` — and the copy's +- `TM.andCellTM_hoareTime` — and the conjunction's +- `TM.guessProtocol_andCellTM` — the conjunction never consults the guess tape +-/ + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : ℕ} + +/-- Control states of `TM.inMatchTM`: compare the first bit, then the second, then halt. -/ +inductive InMatchPhase where + | first | second | done + deriving DecidableEq + +instance : Fintype InMatchPhase where + elems := {.first, .second, .done} + complete := fun x => by cases x <;> simp + +/-- **Check a guessed symbol against the input head.** Register `sym`, parked at cell one, holds +two bits; `expect` says which two bits the symbol under the input head should give. The verdict +lands on register `res`, and `sym` is left where it started. -/ +def inMatchTM (expect : Γ → Bool × Bool) (sym res : Fin n) : TM n where + Q := InMatchPhase + qstart := .first + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .first => + (.second, + fun i => if i = res then + (if wHeads sym = Γ.ofBool (expect iHead).1 then Γw.one else Γw.zero) + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = sym then Dir3.right else idleDir (wHeads i), idleDir oHead) + | .second => + (.done, + fun i => if i = res then + (if wHeads res = Γ.one ∧ wHeads sym = Γ.ofBool (expect iHead).2 + then Γw.one else Γw.zero) + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = sym then moveLeftDir (wHeads sym) else idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .first => + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi + simp only [] + split + · rfl + · exact idleDir_right_of_start hwi + | .second => + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi + simp only [] + split + · next heq => subst heq; exact moveLeftDir_right_of_start hwi + · exact idleDir_right_of_start hwi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The verdict `TM.inMatchTM` writes: both cells of `sym` agree with the two bits the symbol +under the input head is expected to give. -/ +def inMatchVerdict (expect : Γ → Bool × Bool) (g : Γ) (c₁ c₂ : Γ) : Bool := + decide (c₁ = Γ.ofBool (expect g).1) && decide (c₂ = Γ.ofBool (expect g).2) + +/-- The tape `TM.inMatchTM` leaves on its result register. -/ +def inMatchRes (expect : Γ → Bool × Bool) (g : Γ) (c₁ c₂ : Γ) (t : Tape) : Tape := + ⟨1, Function.update t.cells 1 (Γ.ofBool (inMatchVerdict expect g c₁ c₂))⟩ + +/-- **The contract of the input-symbol check.** Two steps; the verdict lands on cell one of the +result register, the compared register comes back to cell one with its contents intact, and every +other tape — the input tape included — is untouched. -/ +theorem inMatchTM_hoareTime (expect : Γ → Bool × Bool) (sym res : Fin n) (hsr : sym ≠ res) + (inp₀ out₀ : Tape) (W₀ : Fin n → Tape) + (hinv : ∀ i, (W₀ i).StartInvariant) (hh : ∀ i, 1 ≤ (W₀ i).head) + (hinp : inp₀.read ≠ Γ.start) (hout : out₀.read ≠ Γ.start) + (hsym : (W₀ sym).head = 1) (hres : (W₀ res).head = 1) : + (inMatchTM expect sym res).HoareTime + (fun inp work out => inp = inp₀ ∧ work = W₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ i, i ≠ res → work i = W₀ i) ∧ + work res = inMatchRes expect inp₀.read ((W₀ sym).cells 1) ((W₀ sym).cells 2) (W₀ res)) + 2 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + classical + -- What one step does to a tape parked at cell one, and to a tape it leaves alone. + have hstay : ∀ (t : Tape) (s : Γw), t.StartInvariant → t.head = 1 → + t.writeAndMove s.toΓ (idleDir t.read) = ⟨1, Function.update t.cells 1 s.toΓ⟩ := by + intro t s hinvt ht + have hns : t.read ≠ Γ.start := hinvt.read_ne_start (by omega) + rw [idleDir, if_neg hns] + refine Tape.ext ?_ ?_ + · show (t.write s.toΓ).head = 1 + rw [Tape.write_head, ht] + · show (t.write s.toΓ).cells = _ + rw [Tape.write, if_neg (by omega), ht] + have hright : ∀ (t : Tape), t.StartInvariant → t.head = 1 → + t.writeAndMove (readBackWrite t.read).toΓ Dir3.right = ⟨2, t.cells⟩ := by + intro t hinvt ht + rw [writeAndMove_readBack_of_startInvariant t hinvt] + refine Tape.ext ?_ (Tape.move_cells t Dir3.right) + show t.head + 1 = 2 + omega + have hleft2 : ∀ (t : Tape), t.StartInvariant → t.head = 2 → + t.writeAndMove (readBackWrite t.read).toΓ (moveLeftDir t.read) = ⟨1, t.cells⟩ := by + intro t hinvt ht + have hns : t.read ≠ Γ.start := hinvt.read_ne_start (by omega) + rw [writeAndMove_readBack_of_startInvariant t hinvt, moveLeftDir, if_neg hns] + refine Tape.ext ?_ (Tape.move_cells t Dir3.left) + show t.head - 1 = 1 + omega + have hidle : ∀ (t : Tape), t.StartInvariant → 1 ≤ t.head → + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + intro t hinvt ht + have hns : t.read ≠ Γ.start := hinvt.read_ne_start ht + rw [writeAndMove_readBack_of_startInvariant t hinvt, idleDir, if_neg hns] + rfl + set v₁ : Bool := decide ((work sym).cells 1 = Γ.ofBool (expect inp.read).1) with hv1 + set W1 : Fin n → Tape := fun i => + if i = res then (⟨1, Function.update (work res).cells 1 (Γ.ofBool v₁)⟩ : Tape) + else if i = sym then (⟨2, (work sym).cells⟩ : Tape) else work i with hW1 + have hsymread : (work sym).read = (work sym).cells 1 := by rw [Tape.read, hsym] + have hstep1 : (inMatchTM expect sym res).step + ⟨InMatchPhase.first, inp, work, out⟩ = some ⟨InMatchPhase.second, inp, W1, out⟩ := by + rw [TM.step_of_not_halted _ (show InMatchPhase.first ≠ InMatchPhase.done by decide)] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + · show inp.move (idleDir inp.read) = inp + exact transitionInput_eq_self hinp + · show (fun i => (work i).writeAndMove _ _) = W1 + funext i + rw [hW1] + show (work i).writeAndMove + ((if i = res then (if (work sym).read = Γ.ofBool (expect inp.read).1 + then Γw.one else Γw.zero) else readBackWrite (work i).read) : Γw).toΓ + (if i = sym then Dir3.right else idleDir (work i).read) = _ + simp only [] + by_cases hir : i = res + · have hisym : ¬ (i = sym) := fun hc => hsr (hc.symm.trans hir) + rw [if_pos hir, if_neg hisym, if_pos hir, + hstay (work i) _ (hinv i) (by rw [hir]; exact hres), hir] + refine Tape.ext rfl ?_ + show Function.update (work res).cells 1 _ = Function.update (work res).cells 1 _ + rw [hv1, hsymread] + by_cases hc : (work sym).cells 1 = Γ.ofBool (expect inp.read).1 + · rw [if_pos hc, decide_eq_true hc] + rfl + · rw [if_neg hc, decide_eq_false hc] + rfl + · rw [if_neg hir, if_neg hir] + by_cases his : i = sym + · rw [if_pos his, if_pos his, his, hright (work sym) (hinv sym) hsym] + · rw [if_neg his, if_neg his, hidle (work i) (hinv i) (hh i)] + · exact transitionTape_eq_self hout + -- The tapes after the first step are still well formed. + have hW1res : W1 res = ⟨1, Function.update (work res).cells 1 (Γ.ofBool v₁)⟩ := by + rw [hW1] + show (if res = res then _ else _) = _ + rw [if_pos rfl] + have hW1sym : W1 sym = ⟨2, (work sym).cells⟩ := by + rw [hW1] + show (if sym = res then _ else if sym = sym then _ else _) = _ + rw [if_neg hsr, if_pos rfl] + have hW1other : ∀ i, i ≠ res → i ≠ sym → W1 i = work i := by + intro i h1 h2 + rw [hW1] + show (if i = res then _ else if i = sym then _ else _) = _ + rw [if_neg h1, if_neg h2] + have hinv1 : ∀ i, (W1 i).StartInvariant := by + intro i + by_cases hir : i = res + · subst hir + rw [hW1res] + refine ⟨?_, ?_⟩ + · show Function.update (work i).cells 1 (Γ.ofBool v₁) 0 = Γ.start + rw [Function.update_of_ne (show (0 : ℕ) ≠ 1 by decide)] + exact (hinv i).1 + · intro q hq + show Function.update (work i).cells 1 (Γ.ofBool v₁) q ≠ Γ.start + by_cases hq1 : q = 1 + · rw [hq1, Function.update_self] + cases v₁ <;> exact fun hc => Γ.noConfusion hc + · rw [Function.update_of_ne hq1] + exact (hinv i).2 q hq + · by_cases his : i = sym + · subst his + rw [hW1sym] + exact ⟨(hinv i).1, (hinv i).2⟩ + · rw [hW1other i hir his] + exact hinv i + have hh1 : ∀ i, 1 ≤ (W1 i).head := by + intro i + by_cases hir : i = res + · subst hir + rw [hW1res] + · by_cases his : i = sym + · subst his + rw [hW1sym] + exact (by omega : (1 : ℕ) ≤ 2) + · rw [hW1other i hir his]; exact hh i + have hread1res : (W1 res).read = Γ.ofBool v₁ := by + rw [hW1res] + show Function.update (work res).cells 1 (Γ.ofBool v₁) 1 = _ + rw [Function.update_self] + have hread1sym : (W1 sym).read = (work sym).cells 2 := by rw [hW1sym]; rfl + set v₂ : Bool := inMatchVerdict expect inp.read ((work sym).cells 1) ((work sym).cells 2) + with hv2 + set W2 : Fin n → Tape := fun i => + if i = res then (⟨1, Function.update (work res).cells 1 (Γ.ofBool v₂)⟩ : Tape) else work i + with hW2 + have hstep2 : (inMatchTM expect sym res).step + ⟨InMatchPhase.second, inp, W1, out⟩ = some ⟨InMatchPhase.done, inp, W2, out⟩ := by + rw [TM.step_of_not_halted _ (show InMatchPhase.second ≠ InMatchPhase.done by decide)] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + · show inp.move (idleDir inp.read) = inp + exact transitionInput_eq_self hinp + · show (fun i => (W1 i).writeAndMove _ _) = W2 + funext i + rw [hW2] + show (W1 i).writeAndMove + ((if i = res then (if (W1 res).read = Γ.one ∧ (W1 sym).read + = Γ.ofBool (expect inp.read).2 then Γw.one else Γw.zero) + else readBackWrite (W1 i).read) : Γw).toΓ + (if i = sym then moveLeftDir (W1 sym).read else idleDir (W1 i).read) = _ + simp only [] + by_cases hir : i = res + · have hisym : ¬ (i = sym) := fun hc => hsr (hc.symm.trans hir) + rw [if_pos hir, if_neg hisym, if_pos hir, hir, + hstay (W1 res) _ (hinv1 res) (by rw [hW1res])] + refine Tape.ext rfl ?_ + show Function.update (W1 res).cells 1 _ = Function.update (work res).cells 1 _ + rw [hread1res, hread1sym, hW1res] + show Function.update (Function.update (work res).cells 1 (Γ.ofBool v₁)) 1 _ + = Function.update (work res).cells 1 _ + rw [Function.update_idem] + refine congrArg _ ?_ + rw [hv2, inMatchVerdict, hv1] + by_cases hc : Γ.ofBool v₁ = Γ.one ∧ (work sym).cells 2 = Γ.ofBool (expect inp.read).2 + · rw [if_pos hc] + have h1 : v₁ = true := by + rcases hc with ⟨hc1, -⟩ + by_contra hne + rw [Bool.not_eq_true] at hne + rw [hne] at hc1 + simp [Γ.ofBool] at hc1 + rw [hv1] at h1 + rw [h1, decide_eq_true hc.2] + rfl + · rw [if_neg hc] + have h2 : ¬ (decide ((work sym).cells 1 = Γ.ofBool (expect inp.read).1) && + decide ((work sym).cells 2 = Γ.ofBool (expect inp.read).2)) = true := by + intro hall + rw [Bool.and_eq_true, decide_eq_true_eq, decide_eq_true_eq] at hall + refine hc ⟨?_, hall.2⟩ + rw [hv1, decide_eq_true hall.1] + rfl + rw [Bool.not_eq_true] at h2 + rw [h2] + rfl + · rw [if_neg hir, if_neg hir] + by_cases his : i = sym + · rw [if_pos his, his, hleft2 (W1 sym) (hinv1 sym) (by rw [hW1sym])] + rw [hW1sym] + exact Tape.ext hsym.symm rfl + · rw [if_neg his, hidle (W1 i) (hinv1 i) (hh1 i)] + exact hW1other i hir his + · exact transitionTape_eq_self hout + refine ⟨⟨InMatchPhase.done, inp, W2, out⟩, 2, le_rfl, + TM.reachesIn.step hstep1 (TM.reachesIn.step hstep2 TM.reachesIn.zero), rfl, rfl, rfl, + fun i hi => ?_, ?_⟩ + · rw [hW2] + show (if i = res then _ else _) = _ + rw [if_neg hi] + · rw [hW2] + show (if res = res then _ else _) = _ + rw [if_pos rfl] + rfl + +/-! ## Moving the input head with the simulated one -/ + +/-- Control states of `TM.inMoveTM`. -/ +inductive InMovePhase where + | go | done + deriving DecidableEq + +instance : Fintype InMovePhase where + elems := {.go, .done} + complete := fun x => by cases x <;> simp + +/-- **Move the input head by the direction two registers' cells name.** A guessed cell holds a +bit, so it cannot name one of three directions on its own; a machine's transition sees every head +at once, so two one-cell registers do it in a single step. Reading `▷` still forces a move right, +as it must. -/ +def inMoveTM (decode : Γ → Γ → Dir3) (mv dir : Fin n) : TM n where + Q := InMovePhase + qstart := .go + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .go => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + (if iHead = Γ.start then Dir3.right else decode (wHeads mv) (wHeads dir)), + fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .go => + exact ⟨fun h => if_pos h, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **The contract of the input-head move.** One step; the input head moves as the register says, +and every other tape is untouched. -/ +theorem inMoveTM_hoareTime (decode : Γ → Γ → Dir3) (mv dir : Fin n) + (inp₀ out₀ : Tape) (W₀ : Fin n → Tape) + (hinv : ∀ i, (W₀ i).StartInvariant) (hh : ∀ i, 1 ≤ (W₀ i).head) + (hinp : inp₀.read ≠ Γ.start) (hout : out₀.read ≠ Γ.start) : + (inMoveTM decode mv dir).HoareTime + (fun inp work out => inp = inp₀ ∧ work = W₀ ∧ out = out₀) + (fun inp work out => + inp = inp₀.move (decode (W₀ mv).read (W₀ dir).read) ∧ work = W₀ ∧ out = out₀) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + have hidle : ∀ (t : Tape), t.StartInvariant → 1 ≤ t.head → + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + intro t hinvt ht + rw [writeAndMove_readBack_of_startInvariant t hinvt, idleDir, + if_neg (hinvt.read_ne_start ht)] + rfl + have hstep : (inMoveTM decode mv dir).step ⟨InMovePhase.go, inp, work, out⟩ + = some ⟨InMovePhase.done, inp.move (decode (work mv).read (work dir).read), work, out⟩ := by + rw [TM.step_of_not_halted _ (show InMovePhase.go ≠ InMovePhase.done by decide)] + refine congrArg some (Cfg.ext rfl ?_ ?_ (transitionTape_eq_self hout)) + · show inp.move (if inp.read = Γ.start then Dir3.right + else decode (work mv).read (work dir).read) = _ + rw [if_neg hinp] + · show (fun i => (work i).writeAndMove _ _) = work + funext i + exact hidle (work i) (hinv i) (hh i) + exact ⟨_, 1, le_rfl, TM.reachesIn.step hstep TM.reachesIn.zero, rfl, rfl, rfl, rfl⟩ + +/-! ## Copying one cell to another register -/ + +/-- **Copy the symbol under one register's head onto another register.** A scan leaves its verdict +on the machine's result tape, which no scan can read; moving it onto an ordinary register is what +lets a later check take it into account. -/ +def copyCellTM (src dst : Fin n) : TM n where + Q := InMovePhase + qstart := .go + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .go => + (.done, + fun i => if i = dst then readBackWrite (wHeads src) else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .go => exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **The contract of the cell copy.** One step; the destination's cell under its head becomes the +source's, and nothing else moves. -/ +theorem copyCellTM_hoareTime (src dst : Fin n) (inp₀ out₀ : Tape) (W₀ : Fin n → Tape) + (hinv : ∀ i, (W₀ i).StartInvariant) (hh : ∀ i, 1 ≤ (W₀ i).head) + (hinp : inp₀.read ≠ Γ.start) (hout : out₀.read ≠ Γ.start) : + (copyCellTM src dst).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ i, i ≠ dst → work i = W₀ i) ∧ + work dst = ⟨(W₀ dst).head, + Function.update (W₀ dst).cells (W₀ dst).head (readBackWrite (W₀ src).read).toΓ⟩) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + have hidle : ∀ (t : Tape), t.StartInvariant → 1 ≤ t.head → + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + intro t hinvt ht + rw [writeAndMove_readBack_of_startInvariant t hinvt, idleDir, + if_neg (hinvt.read_ne_start ht)] + rfl + have hwrite : ∀ (t : Tape) (s : Γ), t.StartInvariant → 1 ≤ t.head → + t.writeAndMove s (idleDir t.read) + = ⟨t.head, Function.update t.cells t.head s⟩ := by + intro t s hinvt ht + rw [idleDir, if_neg (hinvt.read_ne_start ht)] + refine Tape.ext ?_ ?_ + · show (t.write s).head = t.head + rw [Tape.write_head] + · show (t.write s).cells = _ + rw [Tape.write, if_neg (by omega)] + have hstep : (copyCellTM src dst).step ⟨InMovePhase.go, inp, work, out⟩ + = some ⟨InMovePhase.done, inp, + fun i => if i = dst then (⟨(work dst).head, + Function.update (work dst).cells (work dst).head + (readBackWrite (work src).read).toΓ⟩ : Tape) + else work i, out⟩ := by + rw [TM.step_of_not_halted _ (show InMovePhase.go ≠ InMovePhase.done by decide)] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinp) ?_ + (transitionTape_eq_self hout)) + funext i + show (work i).writeAndMove + ((if i = dst then readBackWrite (work src).read else readBackWrite (work i).read) : Γw).toΓ + (idleDir (work i).read) = (if i = dst then _ else _) + by_cases hi : i = dst + · rw [if_pos hi, if_pos hi, hi, hwrite (work dst) _ (hinv dst) (hh dst)] + · rw [if_neg hi, if_neg hi, hidle (work i) (hinv i) (hh i)] + refine ⟨_, 1, le_rfl, TM.reachesIn.step hstep TM.reachesIn.zero, rfl, rfl, rfl, + fun i hi => ?_, ?_⟩ + · show (if i = dst then _ else _) = work i + rw [if_neg hi] + · show (if dst = dst then _ else _) = _ + rw [if_pos rfl] + +/-- **Conjoin one register's cell into another.** The destination's cell under its head becomes +`1` exactly when both it and the source's cell held `1`. A loop driver with no early exit — such +as `TM.binaryForTM` — cannot stop at the first failed check, so its body accumulates the verdicts +here instead. -/ +def andCellTM (src dst : Fin n) : TM n where + Q := InMovePhase + qstart := .go + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .go => + (.done, + fun i => if i = dst then + (if wHeads src = Γ.one ∧ wHeads dst = Γ.one then Γw.one else Γw.zero) + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .go => exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **The contract of the cell conjunction.** One step; the destination's cell under its head +becomes the conjunction of the two cells, and nothing else moves. -/ +theorem andCellTM_hoareTime (src dst : Fin n) (inp₀ out₀ : Tape) (W₀ : Fin n → Tape) + (hinv : ∀ i, (W₀ i).StartInvariant) (hh : ∀ i, 1 ≤ (W₀ i).head) + (hinp : inp₀.read ≠ Γ.start) (hout : out₀.read ≠ Γ.start) : + (andCellTM src dst).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ work = W₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ i, i ≠ dst → work i = W₀ i) ∧ + work dst = ⟨(W₀ dst).head, + Function.update (W₀ dst).cells (W₀ dst).head + (if (W₀ src).read = Γ.one ∧ (W₀ dst).read = Γ.one then Γ.one else Γ.zero)⟩) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + have hwrite : ∀ (t : Tape) (s : Γ), t.StartInvariant → 1 ≤ t.head → + t.writeAndMove s (idleDir t.read) + = ⟨t.head, Function.update t.cells t.head s⟩ := by + intro t s hinvt ht + rw [idleDir, if_neg (hinvt.read_ne_start ht)] + refine Tape.ext ?_ ?_ + · show (t.write s).head = t.head + rw [Tape.write_head] + · show (t.write s).cells = _ + rw [Tape.write, if_neg (by omega)] + have hidle : ∀ (t : Tape), t.StartInvariant → 1 ≤ t.head → + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + intro t hinvt ht + rw [writeAndMove_readBack_of_startInvariant t hinvt, idleDir, + if_neg (hinvt.read_ne_start ht)] + rfl + have hstep : (andCellTM src dst).step ⟨InMovePhase.go, inp, work, out⟩ + = some ⟨InMovePhase.done, inp, + fun i => if i = dst then (⟨(work dst).head, + Function.update (work dst).cells (work dst).head + (if (work src).read = Γ.one ∧ (work dst).read = Γ.one then Γ.one else Γ.zero)⟩ + : Tape) + else work i, out⟩ := by + rw [TM.step_of_not_halted _ (show InMovePhase.go ≠ InMovePhase.done by decide)] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinp) ?_ + (transitionTape_eq_self hout)) + funext i + show (work i).writeAndMove + ((if i = dst then + (if (work src).read = Γ.one ∧ (work dst).read = Γ.one then Γw.one else Γw.zero) + else readBackWrite (work i).read) : Γw).toΓ + (idleDir (work i).read) = (if i = dst then _ else _) + by_cases hi : i = dst + · subst hi + rw [if_pos rfl, if_pos rfl, hwrite (work i) _ (hinv i) (hh i)] + by_cases hc : (work src).read = Γ.one ∧ (work i).read = Γ.one + · rw [if_pos hc, if_pos hc] + rfl + · rw [if_neg hc, if_neg hc] + rfl + · rw [if_neg hi, if_neg hi, hidle (work i) (hinv i) (hh i)] + refine ⟨_, 1, le_rfl, TM.reachesIn.step hstep TM.reachesIn.zero, rfl, rfl, rfl, + fun i hi => ?_, ?_⟩ + · show (if i = dst then _ else _) = work i + rw [if_neg hi] + · show (if dst = dst then _ else _) = _ + rw [if_pos rfl] + +/-- **The cell conjunction never consults the guess tape**, so it may sit inside a +nondeterministic assembly. -/ +theorem guessProtocol_andCellTM {k : ℕ} (src dst : Fin (k + 1)) + (hsrc : src ≠ Fin.last k) (hdst : dst ≠ Fin.last k) : + GuessProtocol (andCellTM src dst) (fun _ => false) := by + have hdst' : ¬ (Fin.last k = dst) := fun h => hdst h.symm + refine ⟨?_, ?_, ?_⟩ + · intro q hq iHead wHeads oHead + cases q with + | go => simp [andCellTM, hdst'] + | done => exact absurd rfl hq + · intro q hq iHead wHeads oHead hg + cases q with + | go => simp [andCellTM, idleDir, hg] + | done => exact absurd rfl hq + · intro q hq _ iHead ww oHead g g' + obtain ⟨js, hjs⟩ := Fin.exists_castSucc_eq.mpr hsrc + obtain ⟨jd, hjd⟩ := Fin.exists_castSucc_eq.mpr hdst + subst hjs + subst hjd + cases q with + | go => simp [andCellTM, visible, Fin.snoc_castSucc] + | done => simp [andCellTM, visible, allIdle, Fin.snoc_castSucc] + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean b/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean index f490587c..7c09b543 100644 --- a/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean +++ b/Complexitylib/Models/TuringMachine/Subroutines/ParkRewind.lean @@ -22,6 +22,8 @@ results. - `TM.parkRewindTM` — park everything, then rewind the input and the named work tapes - `TM.parkRewindTM_hoareTime` — its contract, through fully pinned tape states +- `TM.parkRewindWorkTM`, `TM.parkRewindWorkTM_hoareTime` — the same for the work tapes alone, + leaving the input head where the stage left it -/ @[expose] public section @@ -40,6 +42,12 @@ def parkRewindTM (targets : List (Fin n)) : TM n := /-- A tape with its marker only at cell zero, parked at `max head 1`. -/ def parkTape (t : Tape) : Tape := ⟨max t.head 1, t.cells⟩ +/-- Parking a tape whose head is already off the left marker changes nothing. -/ +theorem parkTape_eq_self {t : Tape} (h : 1 ≤ t.head) : parkTape t = t := by + cases t + simp only [parkTape, Tape.mk.injEq, and_true] + exact max_eq_left h + theorem parkTape_parked {t : Tape} (h : Tape.StartInvariant t) : Parked (parkTape t) := ⟨le_max_right _ _, fun j hj => h.2 j hj⟩ @@ -152,6 +160,66 @@ theorem parkRewindTM_hoareTime (targets : List (Fin n)) (hnodup : targets.Nodup) rfl exact seqTM_hoareTime skipTM _ hpark htrans hrest +/-- Park every head past the marker, then rewind only the named work tapes. The input tape keeps +its head — a stage whose input head is itself part of the state being simulated cannot afford to +have it rewound. -/ +def parkRewindWorkTM (targets : List (Fin n)) : TM n := + seqTM skipTM (bigSeqTM (targets.map rewindWorkTM)) + +/-- **The work-only cleanup stage's contract.** The named work tapes end at cell one with their +contents untouched; every other head ends merely parked. -/ +theorem parkRewindWorkTM_hoareTime (targets : List (Fin n)) (hnodup : targets.Nodup) (B : ℕ) + (hB : 1 ≤ B) (I₀ : Tape) (W₀ : Fin n → Tape) (O₀ : Tape) + (hI : Tape.StartInvariant I₀) (hW : ∀ i, Tape.StartInvariant (W₀ i)) + (hO : Tape.StartInvariant O₀) (hWB : ∀ j, j ∈ targets → (W₀ j).head ≤ B) : + (parkRewindWorkTM targets).HoareTime + (fun inp work out => inp = I₀ ∧ work = W₀ ∧ out = O₀) + (fun inp work out => inp = parkTape I₀ ∧ + work = (fun j => if j ∈ targets then (⟨1, (W₀ j).cells⟩ : Tape) else parkTape (W₀ j)) ∧ + out = parkTape O₀) + (1 + 1 + (targets.length * (B + 3) + 1)) := by + classical + set W1 : Fin n → Tape := fun j => parkTape (W₀ j) with hW1def + set W3 : Fin n → Tape := + fun j => if j ∈ targets then (⟨1, (W₀ j).cells⟩ : Tape) else parkTape (W₀ j) with hW3def + have hW1P : ∀ j, Parked (W1 j) := fun j => parkTape_parked (hW j) + have hI1P : Parked (parkTape I₀) := parkTape_parked hI + have hO1P : Parked (parkTape O₀) := parkTape_parked hO + have hpark : (skipTM (n := n)).HoareTime + (fun inp work out => inp = I₀ ∧ work = W₀ ∧ out = O₀) + (fun inp work out => inp = parkTape I₀ ∧ work = W1 ∧ out = parkTape O₀) 1 := by + refine (parkAll_hoareTime I₀ W₀ O₀ hI hW hO).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi, funext hw, ho⟩ + have htrans : ∀ inp work out, (inp = parkTape I₀ ∧ work = W1 ∧ out = parkTape O₀) → + (transitionInput inp = parkTape I₀ ∧ (fun i => transitionTape (work i)) = W1 ∧ + transitionTape out = parkTape O₀) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨transitionInput_eq_self hI1P.read_ne_start, + funext fun i => transitionTape_eq_self (hW1P i).read_ne_start, + transitionTape_eq_self hO1P.read_ne_start⟩ + have hrest : (bigSeqTM (targets.map rewindWorkTM)).HoareTime + (fun inp work out => inp = parkTape I₀ ∧ work = W1 ∧ out = parkTape O₀) + (fun inp work out => inp = parkTape I₀ ∧ work = W3 ∧ out = parkTape O₀) + (targets.length * (B + 3) + 1) := by + refine (rewindList_hoareTime targets hnodup B (parkTape I₀) W1 (parkTape O₀) + hI1P hO1P hW1P ?_).strengthen_post ?_ + · intro j hj + refine ⟨(hW j).1, ?_⟩ + show max (W₀ j).head 1 ≤ B + have := hWB j hj + omega + · rintro inp work out ⟨rfl, rfl, hin, hout⟩ + refine ⟨rfl, funext fun j => ?_, rfl⟩ + by_cases hj : j ∈ targets + · rw [hin j hj] + show (⟨1, (W1 j).cells⟩ : Tape) = W3 j + simp only [hW3def, if_pos hj] + rfl + · rw [hout j hj, hW3def, hW1def] + simp only [if_neg hj] + exact seqTM_hoareTime skipTM _ hpark htrans hrest + end TM end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/Scan.lean b/Complexitylib/Models/TuringMachine/Subroutines/Scan.lean new file mode 100644 index 00000000..9bdeb4c6 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/Scan.lean @@ -0,0 +1,1575 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Models.TuringMachine.Combinators +public import Complexitylib.Models.TuringMachine.ChoiceTape +public import Complexitylib.Models.TuringMachine.Hoare.Defs +public import Complexitylib.Models.TuringMachine.Tape.Encoding +public import Mathlib.Data.Fintype.Prod + +/-! +# Scanning several tapes in lockstep with a finite control + +Most of what a machine does to a fixed-width register is a scan: check that a layout is +well formed, read a bounded amount of information out of it, compare it against another +register, rewrite it. Each of those is a finite automaton walking the register from left to +right, and none of them can be written with `TM.loopTM`, whose body forgets its control state +between iterations. + +`Complexity.Scanner` is that automaton, and `Complexity.TM.twoPassTM` runs it. The scan is two +passes: rightward to the first blank, gathering into the control state, then leftward back to the +left marker, this time checking what it passes against everything the rightward pass learned. A +single verdict bit is left on a result tape. Two passes is what makes the pattern useful — one +pass cannot act on what it has not yet read. + +The scan only ever reads. That costs nothing, because on a nondeterministic machine anything that +would have to be computed can instead be guessed and checked — and checking is a scan. Tape +contents are therefore invariant across a scan, which is what keeps its contract short. + +All the tapes move together, so a column of the scan is the tuple of symbols under the heads. +Tape `0` is the one whose blank ends the rightward pass; the others are read for as long as it +lasts. + +## Main definitions + +- `Complexity.Scanner` — a two-pass finite-state transducer over `j + 1` tapes +- `Complexity.TM.twoPassTM` — the machine that runs it +- `Complexity.Scanner.runR`, `Complexity.Scanner.runL`, `Complexity.Scanner.run` — what a scan + computes +- `Complexity.Scanner.prefixed` — read parameters off the first cells, then run the check they + choose +- `Complexity.Scanner.bitsStep` — the reader that puts several registers' leading bits in the + control +- `Complexity.Scanner.chunkRun`, `Complexity.Scanner.chunkStepCell` — folding three columns at a + time +- `Complexity.Scanner.comap` — run a check on a wider tape set by naming its columns +- `Complexity.Scanner.upTo`, `Complexity.Scanner.after` — freeze a check once it has read its own + cells, or start it after a prefix, so checks of different lengths and positions share a scan +- `Complexity.Scanner.all`, `Complexity.Scanner.or` — run several checks in one scan, conjoining + or disjoining their verdicts +- `Complexity.Scanner.eq`, `Complexity.Scanner.eq_range_run` — the comparison scanner, and what + it decides when restricted to a range of cells +- `Complexity.Scanner.isConst`, `Complexity.Scanner.isConst_cell`, + `Complexity.Scanner.isNotConst`, `Complexity.Scanner.isNotConst_cell` — checking one cell + against a fixed symbol, or against its failing to be one +- `Complexity.Scanner.isConst_range_run`, `Complexity.Scanner.isNotConst_range_run` — the same + over a range of cells, which is how a field is tested for being all zeros +- `Complexity.Scanner.plusOne` — the increment-check scanner +- `Complexity.Scanner.andAll`, `Complexity.Scanner.andSome`, `Complexity.Scanner.andFirst`, + `Complexity.Scanner.firstCol` — the scanners that combine verdicts + +## Main results + +- `Complexity.TM.checkTM`, `Complexity.TM.checkTM_hoareTime` — a check run on the whole register + set, reading the columns its map names +- `Complexity.TM.twoPassCfg_run` — a scan of a length-`len` tape takes `2 * len + 3` steps and + halts with the automaton's verdict on the result tape, every other tape untouched +- `Complexity.TM.twoPassTM_hoareTime` — the same as a Hoare triple, for composition +- `Complexity.Scanner.eq_run` — the smallest example: comparing two of the tapes +- `Complexity.Scanner.prefixed_run` — a parameterized scan reports what its parameters chose +- `Complexity.Scanner.bitsStep_run` — what the field reader has read +- `Complexity.Scanner.cellFold_chunk` — three cells make a chunk +- `Complexity.Scanner.cellFold_shift`, `Complexity.Scanner.runR_eq_cellFold` — a check proved at + the start of a scan applies wherever the scan puts it +- `Complexity.Scanner.plusOne_run` — one scan checks that one register holds one more than + another +- `Complexity.Scanner.andAll_run`, `Complexity.Scanner.andSome_run`, + `Complexity.Scanner.andFirst_run`, `Complexity.Scanner.firstCol_run` — and one scan reports + any function of the verdicts +-/ + +@[expose] public section + +namespace Complexity + +/-- A two-pass finite-state transducer over `j + 1` tapes scanned in lockstep. The rightward pass +only reads; the leftward pass may rewrite the column it is on. -/ +structure Scanner (j : ℕ) where + /-- The control states of the automaton. -/ + σ : Type + [decEqσ : DecidableEq σ] + [finσ : Fintype σ] + /-- Where the rightward pass starts. -/ + start : σ + /-- The rightward pass: read a column, update the state. -/ + stepR : σ → (Fin (j + 1) → Γ) → σ + /-- The leftward pass: read a column, update the state. -/ + stepL : σ → (Fin (j + 1) → Γ) → σ + /-- The verdict left on the result tape. -/ + emit : σ → Bool + +attribute [instance] Scanner.decEqσ Scanner.finσ + +namespace Scanner + +variable {j : ℕ} + +/-- The state after the rightward pass has read cells `1` through `p`. -/ +def runR (S : Scanner j) (cols : ℕ → Fin (j + 1) → Γ) : ℕ → S.σ + | 0 => S.start + | p + 1 => S.stepR (runR S cols p) (cols (p + 1)) + +/-- The state the leftward pass ends in, having read cells `p` down to `1`. -/ +def runL (S : Scanner j) (cols : ℕ → Fin (j + 1) → Γ) : ℕ → S.σ → S.σ + | 0, s => s + | p + 1, s => S.runL cols p (S.stepL s (cols (p + 1))) + +/-- **What a whole scan computes**: the rightward pass over cells `1 … len`, then the leftward +pass back over `len … 1`. -/ +def run (S : Scanner j) (cols : ℕ → Fin (j + 1) → Γ) (len : ℕ) : S.σ := + S.runL cols len (S.runR cols len) + +/-! ## Scanners that only read on the way out + +When everything a check needs is available before the cells it has to check — which is arranged by +laying the parameters out in the first few cells of the scan and starting the data after them — +the leftward pass has nothing to do. -/ + +/-- A scanner whose leftward pass is idle. -/ +def ofRight {j : ℕ} (τ : Type) [DecidableEq τ] [Fintype τ] (start : τ) + (step : τ → (Fin (j + 1) → Γ) → τ) (emit : τ → Bool) : Scanner j where + σ := τ + start := start + stepR := step + stepL s _ := s + emit := emit + +@[simp] theorem ofRight_runL {j : ℕ} (τ : Type) [DecidableEq τ] [Fintype τ] (start : τ) + (step : τ → (Fin (j + 1) → Γ) → τ) (emit : τ → Bool) (cols : ℕ → Fin (j + 1) → Γ) + (p : ℕ) (s : τ) : (ofRight τ start step emit).runL cols p s = s := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL]; exact ih _ + +theorem ofRight_run {j : ℕ} (τ : Type) [DecidableEq τ] [Fintype τ] (start : τ) + (step : τ → (Fin (j + 1) → Γ) → τ) (emit : τ → Bool) (cols : ℕ → Fin (j + 1) → Γ) + (len : ℕ) : + (ofRight τ start step emit).run cols len = (ofRight τ start step emit).runR cols len := by + rw [run, ofRight_runL] + +/-! ## Running a scanner on a wider tape set + +A check is written against the few registers it reads. Running it on a machine that has many +registers is a matter of saying which columns those are — not of moving the registers next to one +another, and not of giving each check its own copy of them. -/ + +/-- Read a scanner's columns through a map: the same automaton, run on a wider tape set. -/ +def comap {j jj : ℕ} (S : Scanner j) (f : Fin (j + 1) → Fin (jj + 1)) : Scanner jj where + σ := S.σ + decEqσ := S.decEqσ + finσ := S.finσ + start := S.start + stepR s cols := S.stepR s (fun i => cols (f i)) + stepL s cols := S.stepL s (fun i => cols (f i)) + emit := S.emit + +@[simp] theorem comap_emit {j jj : ℕ} (S : Scanner j) (f : Fin (j + 1) → Fin (jj + 1)) : + (S.comap f).emit = S.emit := rfl + +theorem comap_runR {j jj : ℕ} (S : Scanner j) (f : Fin (j + 1) → Fin (jj + 1)) + (cols : ℕ → Fin (jj + 1) → Γ) (p : ℕ) : + (S.comap f).runR cols p = S.runR (fun q i => cols q (f i)) p := by + induction p with + | zero => rfl + | succ p ih => rw [runR, runR, ih]; rfl + +theorem comap_runL {j jj : ℕ} (S : Scanner j) (f : Fin (j + 1) → Fin (jj + 1)) + (cols : ℕ → Fin (jj + 1) → Γ) (p : ℕ) (s : S.σ) : + (S.comap f).runL cols p s = S.runL (fun q i => cols q (f i)) p s := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL, runL, ih]; rfl + +/-- **A scanner run through a map reads exactly the columns the map names.** -/ +theorem comap_run {j jj : ℕ} (S : Scanner j) (f : Fin (j + 1) → Fin (jj + 1)) + (cols : ℕ → Fin (jj + 1) → Γ) (len : ℕ) : + (S.comap f).run cols len = S.run (fun q i => cols q (f i)) len := by + rw [run, run, comap_runR, comap_runL] + +/-! ## Stopping a check early + +Checks read different numbers of cells, but a machine's scan has one length. A right-only check +can simply be frozen once it has read the cells it cares about: the columns past that point are +read and discarded, so a short check and a long one can share a scan. -/ + +/-- A scanner whose leftward pass does nothing — the shape of every check built with +`Complexity.Scanner.ofRight` or `Complexity.Scanner.prefixed`. -/ +def RightOnly {j : ℕ} (S : Scanner j) : Prop := ∀ s cols, S.stepL s cols = s + +theorem rightOnly_ofRight {j : ℕ} (τ : Type) [DecidableEq τ] [Fintype τ] (start : τ) + (step : τ → (Fin (j + 1) → Γ) → τ) (emit : τ → Bool) : + RightOnly (ofRight (j := j) τ start step emit) := fun _ _ => rfl + +theorem rightOnly_comap {j jj : ℕ} {S : Scanner j} (h : RightOnly S) + (f : Fin (j + 1) → Fin (jj + 1)) : RightOnly (S.comap f) := fun s _ => h s _ + +/-- A right-only scanner's leftward pass leaves the state alone. -/ +theorem runL_of_rightOnly {j : ℕ} {S : Scanner j} (hS : RightOnly S) + (cols : ℕ → Fin (j + 1) → Γ) : ∀ (p : ℕ) (s : S.σ), S.runL cols p s = s := by + intro p + induction p with + | zero => intro s; rfl + | succ p ih => intro s; rw [runL, hS, ih] + +/-- The saturating position counter a frozen check carries. -/ +def upToIdx (w p : ℕ) : Fin (w + 1) := ⟨min p w, by omega⟩ + +/-- Run a scanner over the first `w` cells, then freeze. -/ +def upTo {j : ℕ} (S : Scanner j) (w : ℕ) : Scanner j where + σ := S.σ × Fin (w + 1) + decEqσ := instDecidableEqProd + finσ := instFintypeProd _ _ + start := (S.start, upToIdx w 0) + stepR s cols := + if h : s.2.val < w then (S.stepR s.1 cols, ⟨s.2.val + 1, by omega⟩) else s + stepL s cols := (S.stepL s.1 cols, s.2) + emit s := S.emit s.1 + +theorem upTo_runR {j : ℕ} (S : Scanner j) (w : ℕ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) : + (S.upTo w).runR cols p = (S.runR cols (min p w), upToIdx w p) := by + induction p with + | zero => rfl + | succ p ih => + have hstep : (S.upTo w).runR cols (p + 1) + = (S.upTo w).stepR ((S.upTo w).runR cols p) (cols (p + 1)) := rfl + rw [hstep, ih] + by_cases hpw : p < w + · have hmin : min p w = p := by omega + have hmin' : min (p + 1) w = p + 1 := by omega + have hlt : ((upToIdx w p : Fin (w + 1)) : ℕ) < w := by + show min p w < w + omega + show (if h : ((upToIdx w p : Fin (w + 1)) : ℕ) < w then + (S.stepR (S.runR cols (min p w)) (cols (p + 1)), + (⟨((upToIdx w p : Fin (w + 1)) : ℕ) + 1, by omega⟩ : Fin (w + 1))) + else (S.runR cols (min p w), upToIdx w p)) = _ + rw [dif_pos hlt] + refine Prod.ext ?_ (Fin.ext ?_) + · show S.stepR (S.runR cols (min p w)) (cols (p + 1)) = S.runR cols (min (p + 1) w) + rw [hmin, hmin'] + rfl + · show ((upToIdx w p : Fin (w + 1)) : ℕ) + 1 = ((upToIdx w (p + 1) : Fin (w + 1)) : ℕ) + show min p w + 1 = min (p + 1) w + omega + · have hge : ¬ ((upToIdx w p : Fin (w + 1)) : ℕ) < w := by + show ¬ min p w < w + omega + show (if h : ((upToIdx w p : Fin (w + 1)) : ℕ) < w then + (S.stepR (S.runR cols (min p w)) (cols (p + 1)), + (⟨((upToIdx w p : Fin (w + 1)) : ℕ) + 1, by omega⟩ : Fin (w + 1))) + else (S.runR cols (min p w), upToIdx w p)) = _ + rw [dif_neg hge] + refine Prod.ext ?_ (Fin.ext ?_) + · show S.runR cols (min p w) = S.runR cols (min (p + 1) w) + rw [show min (p + 1) w = min p w by omega] + · show min p w = min (p + 1) w + omega + +theorem upTo_runL {j : ℕ} (S : Scanner j) (w : ℕ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) + (s : (S.upTo w).σ) : (S.upTo w).runL cols p s = (S.runL cols p s.1, s.2) := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL, ih]; rfl + +/-- **A frozen check gives the verdict it would have given on its own cells.** -/ +theorem upTo_emit_run {j : ℕ} (S : Scanner j) (hS : RightOnly S) (w len : ℕ) (hw : w ≤ len) + (cols : ℕ → Fin (j + 1) → Γ) : + (S.upTo w).emit ((S.upTo w).run cols len) = S.emit (S.run cols w) := by + rw [run, upTo_runL, upTo_runR, run, runL_of_rightOnly hS, runL_of_rightOnly hS] + show S.emit (S.runR cols (min len w)) = S.emit (S.runR cols w) + rw [min_eq_right hw] + +/-- Skip the first `w` cells, then run a scanner over the rest. Together with +`Complexity.Scanner.upTo` this restricts a check to any range of cells, which is what pins a +guessed value against a field that does not sit at the start of its register. -/ +def after {j : ℕ} (S : Scanner j) (w : ℕ) : Scanner j where + σ := S.σ × Fin (w + 1) + decEqσ := instDecidableEqProd + finσ := instFintypeProd _ _ + start := (S.start, upToIdx w 0) + stepR s cols := + if h : s.2.val < w then (s.1, ⟨s.2.val + 1, by omega⟩) else (S.stepR s.1 cols, s.2) + stepL s cols := (S.stepL s.1 cols, s.2) + emit s := S.emit s.1 + +theorem rightOnly_after {j : ℕ} {S : Scanner j} (h : RightOnly S) (w : ℕ) : + RightOnly (S.after w) := fun s cols => Prod.ext (h s.1 cols) rfl + +theorem after_runR {j : ℕ} (S : Scanner j) (w : ℕ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) : + (S.after w).runR cols p = (S.runR (fun q => cols (w + q)) (p - w), upToIdx w p) := by + induction p with + | zero => rw [show (0 : ℕ) - w = 0 from Nat.zero_sub w]; rfl + | succ p ih => + have hstep : (S.after w).runR cols (p + 1) + = (S.after w).stepR ((S.after w).runR cols p) (cols (p + 1)) := rfl + rw [hstep, ih] + by_cases hpw : p < w + · have hlt : ((upToIdx w p : Fin (w + 1)) : ℕ) < w := by + show min p w < w + omega + show (if h : ((upToIdx w p : Fin (w + 1)) : ℕ) < w then + (S.runR (fun q => cols (w + q)) (p - w), + (⟨((upToIdx w p : Fin (w + 1)) : ℕ) + 1, by omega⟩ : Fin (w + 1))) + else (S.stepR (S.runR (fun q => cols (w + q)) (p - w)) (cols (p + 1)), + upToIdx w p)) = _ + rw [dif_pos hlt] + refine Prod.ext ?_ (Fin.ext ?_) + · show S.runR (fun q => cols (w + q)) (p - w) + = S.runR (fun q => cols (w + q)) (p + 1 - w) + rw [show p + 1 - w = p - w by omega] + · show ((upToIdx w p : Fin (w + 1)) : ℕ) + 1 = ((upToIdx w (p + 1) : Fin (w + 1)) : ℕ) + show min p w + 1 = min (p + 1) w + omega + · have hge : ¬ ((upToIdx w p : Fin (w + 1)) : ℕ) < w := by + show ¬ min p w < w + omega + show (if h : ((upToIdx w p : Fin (w + 1)) : ℕ) < w then + (S.runR (fun q => cols (w + q)) (p - w), + (⟨((upToIdx w p : Fin (w + 1)) : ℕ) + 1, by omega⟩ : Fin (w + 1))) + else (S.stepR (S.runR (fun q => cols (w + q)) (p - w)) (cols (p + 1)), + upToIdx w p)) = _ + rw [dif_neg hge] + refine Prod.ext ?_ (Fin.ext ?_) + · show S.stepR (S.runR (fun q => cols (w + q)) (p - w)) (cols (p + 1)) + = S.runR (fun q => cols (w + q)) (p + 1 - w) + rw [show p + 1 - w = (p - w) + 1 by omega] + show _ = S.stepR (S.runR (fun q => cols (w + q)) (p - w)) (cols (w + ((p - w) + 1))) + rw [show w + ((p - w) + 1) = p + 1 by omega] + · show min p w = min (p + 1) w + omega + +theorem after_runL {j : ℕ} (S : Scanner j) (w : ℕ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) + (s : (S.after w).σ) : (S.after w).runL cols p s = (S.runL cols p s.1, s.2) := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL, ih]; rfl + +/-- **A check that skips a prefix reads the cells after it.** -/ +theorem after_emit_run {j : ℕ} (S : Scanner j) (hS : RightOnly S) (w len : ℕ) + (cols : ℕ → Fin (j + 1) → Γ) : + (S.after w).emit ((S.after w).run cols len) + = S.emit (S.run (fun q => cols (w + q)) (len - w)) := by + rw [run, after_runL, after_runR, run, runL_of_rightOnly hS, runL_of_rightOnly hS] + rfl + +/-- **A check restricted to a range of cells.** -/ +theorem range_emit_run {j : ℕ} (S : Scanner j) (hS : RightOnly S) (w₁ w₂ len : ℕ) + (hw : w₂ ≤ len) (cols : ℕ → Fin (j + 1) → Γ) : + ((S.after w₁).upTo w₂).emit (((S.after w₁).upTo w₂).run cols len) + = S.emit (S.run (fun q => cols (w₁ + q)) (w₂ - w₁)) := by + rw [upTo_emit_run _ (rightOnly_after hS w₁) w₂ len hw, after_emit_run S hS] + +/-! ## Running several checks in one scan + +A machine has one result tape, and a two-pass scan writes it at the very end. Rather than give +each check its own tape and combine the verdicts afterwards, the checks run *together*: one +automaton whose state is the tuple of theirs, whose verdict is their conjunction. Each component +still runs exactly the scan it would have run alone, so the lemmas about the individual checks +apply unchanged. -/ + +/-- Run several scanners at once, emitting the conjunction of their verdicts. -/ +noncomputable def all {jj : ℕ} (n : ℕ) (S : Fin n → Scanner jj) : Scanner jj where + σ := ∀ i, (S i).σ + decEqσ := Classical.decEq _ + finσ := Pi.instFintype + start := fun i => (S i).start + stepR s cols := fun i => (S i).stepR (s i) cols + stepL s cols := fun i => (S i).stepL (s i) cols + emit s := decide (∀ i, (S i).emit (s i) = true) + +theorem all_runR {jj : ℕ} (n : ℕ) (S : Fin n → Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) + (p : ℕ) (i : Fin n) : (all n S).runR cols p i = (S i).runR cols p := by + induction p with + | zero => rfl + | succ p ih => rw [runR, runR, ← ih]; rfl + +theorem all_runL {jj : ℕ} (n : ℕ) (S : Fin n → Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) + (p : ℕ) (s : (all n S).σ) (i : Fin n) : + (all n S).runL cols p s i = (S i).runL cols p (s i) := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL, runL, ih]; rfl + +/-- **Each component of a joint scan runs its own scan.** -/ +theorem all_run {jj : ℕ} (n : ℕ) (S : Fin n → Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) + (len : ℕ) (i : Fin n) : (all n S).run cols len i = (S i).run cols len := by + rw [run, run, all_runL, all_runR] + +/-- **A joint scan accepts exactly when every component does.** -/ +theorem all_emit_run {jj : ℕ} (n : ℕ) (S : Fin n → Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) + (len : ℕ) : (all n S).emit ((all n S).run cols len) = true ↔ + ∀ i, (S i).emit ((S i).run cols len) = true := by + show decide (∀ i, (S i).emit ((all n S).run cols len i) = true) = true ↔ _ + rw [decide_eq_true_eq] + constructor + · intro h i; rw [← all_run]; exact h i + · intro h i; rw [all_run]; exact h i + +/-- Run two scanners at once, emitting the disjunction of their verdicts: the walk's step either +keeps its configuration or advances it. -/ +def or {jj : ℕ} (S T : Scanner jj) : Scanner jj where + σ := S.σ × T.σ + start := (S.start, T.start) + stepR s cols := (S.stepR s.1 cols, T.stepR s.2 cols) + stepL s cols := (S.stepL s.1 cols, T.stepL s.2 cols) + emit s := S.emit s.1 || T.emit s.2 + +theorem or_runR {jj : ℕ} (S T : Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) (p : ℕ) : + (S.or T).runR cols p = (S.runR cols p, T.runR cols p) := by + induction p with + | zero => rfl + | succ p ih => rw [runR, ih]; rfl + +theorem or_runL {jj : ℕ} (S T : Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) (p : ℕ) + (s : S.σ × T.σ) : (S.or T).runL cols p s = (S.runL cols p s.1, T.runL cols p s.2) := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL, ih]; rfl + +/-- **A disjunctive scan accepts exactly when one of its halves does.** -/ +theorem or_emit_run {jj : ℕ} (S T : Scanner jj) (cols : ℕ → Fin (jj + 1) → Γ) (len : ℕ) : + (S.or T).emit ((S.or T).run cols len) = true ↔ + S.emit (S.run cols len) = true ∨ T.emit (T.run cols len) = true := by + show (S.emit _ || T.emit _) = true ↔ _ + rw [run, or_runL, or_runR] + simp [run] + +/-! ## Reading parameters before checking + +A check usually needs a few values — a symbol to compare against, a direction to move — that are +themselves on a register. Laying them out in the first cells of the scan and starting the data +after them lets one scan do both: read the parameters into the control, then run a check chosen by +them. -/ + +/-- The accumulated parameters after reading `p` columns. -/ +def auxRun {j : ℕ} {α : Type} (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) + (cols : ℕ → Fin (j + 1) → Γ) : ℕ → α + | 0 => a₀ + | p + 1 => readStep (auxRun a₀ readStep cols p) (cols (p + 1)) + +/-- The state of the parameterized check after `q` columns beyond the parameter block. -/ +def mainRun {j : ℕ} {α τ : Type} (c : ℕ) (a : α) (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) + (cols : ℕ → Fin (j + 1) → Γ) (t₀ : τ) : ℕ → τ + | 0 => t₀ + | q + 1 => mainStep a (mainRun c a mainStep cols t₀ q) (cols (c + q + 1)) + +/-- **Read `c` columns of parameters, then check.** -/ +def prefixed {j : ℕ} (c : ℕ) (α τ : Type) [DecidableEq α] [Fintype α] [DecidableEq τ] + [Fintype τ] (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) (t₀ : α → τ) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (emit : α → τ → Bool) : Scanner j := + ofRight (Fin (c + 1) × α × τ) (⟨0, Nat.zero_lt_succ c⟩, a₀, t₀ a₀) + (fun s col => + if h : s.1.val < c then + let a' := readStep s.2.1 col + (⟨s.1.val + 1, by omega⟩, a', if s.1.val + 1 = c then t₀ a' else s.2.2) + else (s.1, s.2.1, mainStep s.2.1 s.2.2 col)) + (fun s => emit s.2.1 s.2.2) + +variable {j : ℕ} {α τ : Type} [DecidableEq α] [Fintype α] [DecidableEq τ] [Fintype τ] + +theorem rightOnly_prefixed (c : ℕ) (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) (t₀ : α → τ) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (emit : α → τ → Bool) : + RightOnly (prefixed c α τ a₀ readStep t₀ mainStep emit) := fun _ _ => rfl + +theorem prefixed_stepR (c : ℕ) (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) (t₀ : α → τ) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (emit : α → τ → Bool) + (s : Fin (c + 1) × α × τ) (col : Fin (j + 1) → Γ) : + (prefixed c α τ a₀ readStep t₀ mainStep emit).stepR s col + = if h : s.1.val < c then + (⟨s.1.val + 1, by omega⟩, readStep s.2.1 col, + if s.1.val + 1 = c then t₀ (readStep s.2.1 col) else s.2.2) + else (s.1, s.2.1, mainStep s.2.1 s.2.2 col) := rfl + +/-- Through the parameter block, the scan is just accumulating parameters. -/ +theorem prefixed_runR_le (c : ℕ) (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) (t₀ : α → τ) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (emit : α → τ → Bool) + (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p ≤ c, ((prefixed c α τ a₀ readStep t₀ mainStep emit).runR cols p).1.val = p ∧ + ((prefixed c α τ a₀ readStep t₀ mainStep emit).runR cols p).2.1 + = auxRun a₀ readStep cols p := by + intro p + induction p with + | zero => intro _; exact ⟨rfl, rfl⟩ + | succ p ih => + intro hp + obtain ⟨h1, h2⟩ := ih (by omega) + have hlt : ((prefixed c α τ a₀ readStep t₀ mainStep emit).runR cols p).1.val < c := by + rw [h1]; omega + constructor + · rw [runR, prefixed_stepR, dif_pos hlt] + simpa using h1 + · rw [runR, prefixed_stepR, dif_pos hlt, auxRun, h2] + +end Scanner + +namespace Scanner + +variable {j : ℕ} {α τ : Type} [DecidableEq α] [Fintype α] [DecidableEq τ] [Fintype τ] + +/-- Past the parameter block, the scan runs the check the parameters chose. -/ +theorem prefixed_runR (c : ℕ) (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) (t₀ : α → τ) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (emit : α → τ → Bool) + (cols : ℕ → Fin (j + 1) → Γ) (hc : 0 < c) : + ∀ q : ℕ, (prefixed c α τ a₀ readStep t₀ mainStep emit).runR cols (c + q) + = (⟨c, Nat.lt_succ_self c⟩, auxRun a₀ readStep cols c, + mainRun c (auxRun a₀ readStep cols c) mainStep cols + (t₀ (auxRun a₀ readStep cols c)) q) := by + intro q + induction q with + | zero => + obtain ⟨c', hc'⟩ : ∃ c', c = c' + 1 := ⟨c - 1, by omega⟩ + subst hc' + obtain ⟨h1, h2⟩ := prefixed_runR_le (c' + 1) a₀ readStep t₀ mainStep emit cols c' (by omega) + have hlt : ((prefixed (c' + 1) α τ a₀ readStep t₀ mainStep emit).runR cols c').1.val + < c' + 1 := by rw [h1]; omega + rw [Nat.add_zero, runR, prefixed_stepR, dif_pos hlt, h2, mainRun] + refine Prod.ext ?_ (Prod.ext ?_ ?_) + · exact Fin.ext (by simpa using h1) + · rw [auxRun] + · rw [if_pos (by omega), auxRun] + | succ q ih => + have hnot : ¬ ((prefixed c α τ a₀ readStep t₀ mainStep emit).runR cols (c + q)).1.val + < c := by + rw [ih] + exact Nat.lt_irrefl c + rw [show c + (q + 1) = (c + q) + 1 by omega, runR, prefixed_stepR, dif_neg hnot, ih, + mainRun] + +/-- **What a parameterized scan reports**: the check the parameters chose, run on the data after +them. -/ +theorem prefixed_run (c : ℕ) (a₀ : α) (readStep : α → (Fin (j + 1) → Γ) → α) (t₀ : α → τ) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (emit : α → τ → Bool) + (cols : ℕ → Fin (j + 1) → Γ) (hc : 0 < c) (q : ℕ) : + (prefixed c α τ a₀ readStep t₀ mainStep emit).emit + ((prefixed c α τ a₀ readStep t₀ mainStep emit).run cols (c + q)) + = emit (auxRun a₀ readStep cols c) + (mainRun c (auxRun a₀ readStep cols c) mainStep cols + (t₀ (auxRun a₀ readStep cols c)) q) := by + have hrunL : ∀ s : Fin (c + 1) × α × τ, + (prefixed c α τ a₀ readStep t₀ mainStep emit).runL cols (c + q) s = s := fun s => + ofRight_runL (Fin (c + 1) × α × τ) _ _ _ cols (c + q) s + rw [run, hrunL, prefixed_runR c a₀ readStep t₀ mainStep emit cols hc q] + rfl + +/-! ## Reading fixed-width fields into the control + +The parameters a check needs — a state, a symbol, a direction — sit in the first few cells of +their own registers. This reads all of them at once: `s` registers, `w` cells each, into a table +of bits the check can consult. -/ + +/-- The bit a scan sees on a register at a given cell. -/ +def bitAt {j : ℕ} (cols : ℕ → Fin (j + 1) → Γ) (a : Fin (j + 1)) (p : ℕ) : Bool := + decide (cols p a = Γ.one) + +/-- Read the first `w` cells of each of `s` registers into a table of bits. -/ +def bitsStep {j : ℕ} (s w : ℕ) (regs : Fin s → Fin (j + 1)) + (x : Fin (w + 1) × (Fin s → Fin w → Bool)) (col : Fin (j + 1) → Γ) : + Fin (w + 1) × (Fin s → Fin w → Bool) := + if h : x.1.val < w then + (⟨x.1.val + 1, by omega⟩, + fun t => Function.update (x.2 t) ⟨x.1.val, h⟩ (decide (col (regs t) = Γ.one))) + else x + +/-- **A field reader sees only the registers it names.** Two scans whose named registers agree +read the same table — which is what makes several checks reading the same parameter register +agree on the parameters. -/ +theorem auxRun_bitsStep_congr {j s w : ℕ} (regs : Fin s → Fin (j + 1)) + (cols cols' : ℕ → Fin (j + 1) → Γ) (h : ∀ q t, cols q (regs t) = cols' q (regs t)) + (x₀ : Fin s → Fin w → Bool) : ∀ p : ℕ, + auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (bitsStep s w regs) cols p + = auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (bitsStep s w regs) cols' p := by + intro p + induction p with + | zero => rfl + | succ p ih => + rw [auxRun, auxRun, ih] + simp only [bitsStep, h (p + 1)] + +/-- **What the field reader has read.** After `p ≤ w` columns the table holds the first `p` bits +of every register. -/ +theorem bitsStep_run {j : ℕ} (s w : ℕ) (regs : Fin s → Fin (j + 1)) + (cols : ℕ → Fin (j + 1) → Γ) (x₀ : Fin s → Fin w → Bool) : + ∀ p ≤ w, + (auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (bitsStep s w regs) cols p).1.val = p ∧ + ∀ (t : Fin s) (i : Fin w), i.val < p → + (auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (bitsStep s w regs) cols p).2 t i + = bitAt cols (regs t) (i.val + 1) := by + intro p + induction p with + | zero => intro _; exact ⟨rfl, fun _ _ h => absurd h (by omega)⟩ + | succ p ih => + intro hp + obtain ⟨h1, h2⟩ := ih (by omega) + have hlt : (auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (bitsStep s w regs) cols p).1.val < w := by + rw [h1]; omega + rw [auxRun, bitsStep, dif_pos hlt] + refine ⟨by simpa using h1, fun t i hi => ?_⟩ + dsimp only + rcases Nat.lt_or_ge i.val p with h | h + · rw [Function.update_of_ne, h2 t i h] + intro hcontra + rw [hcontra, h1] at h + exact absurd h (by omega) + · have hip : i.val = p := by omega + have hieq : i = ⟨(auxRun (⟨0, Nat.zero_lt_succ w⟩, x₀) (bitsStep s w regs) cols p).1.val, + hlt⟩ := by + apply Fin.ext + rw [h1, hip] + rw [hieq, Function.update_self, bitAt, h1] + +/-! ## Folding three columns at a time + +A marked block stores each cell as a chunk of three bits — the head marker first, so that a +rightward pass knows whether the head is on a cell before it reads that cell's symbol. Checks on +such a block are naturally written a chunk at a time, and `Complexity.Scanner.cellFold_chunk` says +that a cell-level fold which buffers two columns and acts on the third computes exactly the +chunk-level fold. -/ + +/-- A plain fold over the columns from `off + 1` onwards. -/ +def cellFold {j : ℕ} {σ : Type} (g : σ → (Fin (j + 1) → Γ) → σ) (cols : ℕ → Fin (j + 1) → Γ) + (off : ℕ) (s₀ : σ) : ℕ → σ + | 0 => s₀ + | q + 1 => g (cellFold g cols off s₀ q) (cols (off + q + 1)) + +theorem mainRun_eq_cellFold {j : ℕ} {α τ : Type} (c : ℕ) (a : α) + (mainStep : α → τ → (Fin (j + 1) → Γ) → τ) (cols : ℕ → Fin (j + 1) → Γ) (t₀ : τ) : + ∀ q : ℕ, mainRun c a mainStep cols t₀ q = cellFold (mainStep a) cols c t₀ q := by + intro q + induction q with + | zero => rfl + | succ q ih => rw [mainRun, cellFold, ih] + +/-- A fold started later is the same fold on shifted columns, so a check proved at the start of a +scan applies wherever the scan puts it. -/ +theorem cellFold_shift {j : ℕ} {σ : Type} (g : σ → (Fin (j + 1) → Γ) → σ) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (s₀ : σ) : + ∀ p : ℕ, cellFold g cols off s₀ p = cellFold g (fun t => cols (off + t)) 0 s₀ p := by + intro p + induction p with + | zero => rfl + | succ p ih => + rw [cellFold, cellFold, ih] + simp only [Nat.zero_add, Nat.add_assoc] + +/-- A scanner's rightward pass is a plain fold. -/ +theorem runR_eq_cellFold {j : ℕ} (S : Scanner j) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, S.runR cols p = cellFold S.stepR cols 0 S.start p := by + intro p + induction p with + | zero => rfl + | succ p ih => + rw [runR, ih, cellFold] + simp only [Nat.zero_add] + +/-- A fold that consumes three columns at a time. -/ +def chunkRun {j : ℕ} {χ : Type} + (f : χ → (Fin (j + 1) → Γ) → (Fin (j + 1) → Γ) → (Fin (j + 1) → Γ) → χ) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (x₀ : χ) : ℕ → χ + | 0 => x₀ + | p + 1 => + f (chunkRun f cols off x₀ p) (cols (off + 3 * p + 1)) (cols (off + 3 * p + 2)) + (cols (off + 3 * p + 3)) + +/-- The cell-level step that buffers two columns and acts on the third. -/ +def chunkStepCell {j : ℕ} {χ : Type} + (f : χ → (Fin (j + 1) → Γ) → (Fin (j + 1) → Γ) → (Fin (j + 1) → Γ) → χ) + (s : Fin 3 × (Fin (j + 1) → Γ) × (Fin (j + 1) → Γ) × χ) (col : Fin (j + 1) → Γ) : + Fin 3 × (Fin (j + 1) → Γ) × (Fin (j + 1) → Γ) × χ := + if s.1 = 0 then (1, col, s.2.2.1, s.2.2.2) + else if s.1 = 1 then (2, s.2.1, col, s.2.2.2) + else (0, s.2.1, s.2.2.1, f s.2.2.2 s.2.1 s.2.2.1 col) + +/-- **Three cells make a chunk.** -/ +theorem cellFold_chunk {j : ℕ} {χ : Type} + (f : χ → (Fin (j + 1) → Γ) → (Fin (j + 1) → Γ) → (Fin (j + 1) → Γ) → χ) + (cols : ℕ → Fin (j + 1) → Γ) (off : ℕ) (x₀ : χ) (u v : Fin (j + 1) → Γ) : + ∀ p : ℕ, + (cellFold (chunkStepCell f) cols off (0, u, v, x₀) (3 * p)).1 = 0 ∧ + (cellFold (chunkStepCell f) cols off (0, u, v, x₀) (3 * p)).2.2.2 + = chunkRun f cols off x₀ p := by + intro p + induction p with + | zero => exact ⟨rfl, rfl⟩ + | succ p ih => + obtain ⟨h0, hx⟩ := ih + have hstep : 3 * (p + 1) = 3 * p + 1 + 1 + 1 := by omega + rw [hstep, cellFold, cellFold, cellFold] + have e0 : chunkStepCell f (cellFold (chunkStepCell f) cols off (0, u, v, x₀) (3 * p)) + (cols (off + 3 * p + 1)) + = (1, cols (off + 3 * p + 1), + (cellFold (chunkStepCell f) cols off (0, u, v, x₀) (3 * p)).2.2.1, + chunkRun f cols off x₀ p) := by + rw [chunkStepCell, if_pos h0, hx] + rw [e0] + have e1 : chunkStepCell f + (1, cols (off + 3 * p + 1), + (cellFold (chunkStepCell f) cols off (0, u, v, x₀) (3 * p)).2.2.1, + chunkRun f cols off x₀ p) (cols (off + (3 * p + 1) + 1)) + = (2, cols (off + 3 * p + 1), cols (off + (3 * p + 1) + 1), + chunkRun f cols off x₀ p) := by + rw [chunkStepCell] + simp + rw [e1, chunkStepCell] + refine ⟨by simp, ?_⟩ + simp only [chunkRun] + rw [show off + (3 * p + 1) + 1 = off + 3 * p + 2 by omega, + show off + (3 * p + 2) + 1 = off + 3 * p + 3 by omega] + rfl + +/-! ## A first scanner: register equality -/ + +/-- Compare two of the scanned tapes cell by cell. -/ +def eq (j : ℕ) (a b : Fin (j + 1)) : Scanner j where + σ := Bool + start := true + stepR s cols := s && decide (cols a = cols b) + stepL s _ := s + emit := id + +theorem rightOnly_eq (j : ℕ) (a b : Fin (j + 1)) : RightOnly (eq j a b) := fun _ _ => rfl + +@[simp] theorem eq_runL (j : ℕ) (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) + (s : Bool) : (eq j a b).runL cols p s = s := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL]; exact ih _ + +theorem eq_runR (j : ℕ) (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (eq j a b).runR cols p = true ↔ ∀ q, 1 ≤ q → q ≤ p → cols q a = cols q b := by + intro p + induction p with + | zero => simpa [runR, eq] using fun q h1 h2 => absurd h1 (by omega) + | succ p ih => + rw [runR] + show ((eq j a b).runR cols p && decide (cols (p + 1) a = cols (p + 1) b)) = true ↔ _ + rw [Bool.and_eq_true, decide_eq_true_eq] + constructor + · rintro ⟨hall, hlast⟩ q h1 h2 + rcases Nat.lt_or_ge q (p + 1) with hlt | hge + · exact ih.mp hall q h1 (by omega) + · rw [show q = p + 1 by omega] + exact hlast + · intro hall + exact ⟨ih.mpr fun q h1 h2 => hall q h1 (by omega), hall (p + 1) (by omega) le_rfl⟩ + +/-- **What the equality scanner reports.** -/ +theorem eq_run (j : ℕ) (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (len : ℕ) : + (eq j a b).run cols len = true ↔ ∀ q, 1 ≤ q → q ≤ len → cols q a = cols q b := by + rw [run, eq_runL, eq_runR] + +/-- **A comparison restricted to a range of cells decides equality there.** This is how a small +guessed register is pinned against a field sitting anywhere inside a bigger one. -/ +theorem eq_range_run (j : ℕ) (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) + (w₁ w₂ len : ℕ) (hw : w₂ ≤ len) : + (((eq j a b).after w₁).upTo w₂).emit ((((eq j a b).after w₁).upTo w₂).run cols len) = true ↔ + ∀ q, w₁ < q → q ≤ w₂ → cols q a = cols q b := by + rw [range_emit_run _ (rightOnly_eq j a b) w₁ w₂ len hw] + show (eq j a b).run (fun q => cols (w₁ + q)) (w₂ - w₁) = true ↔ _ + rw [eq_run] + constructor + · intro h q h1 h2 + have := h (q - w₁) (by omega) (by omega) + rwa [show w₁ + (q - w₁) = q by omega] at this + · intro h q h1 h2 + exact h (w₁ + q) (by omega) (by omega) + +/-- Check that a register carries a fixed symbol. Frozen to one cell by +`Complexity.Scanner.upTo` this reads a single cell, which is how a one-cell register — a +direction, say — is checked against a constant. -/ +def isConst (j : ℕ) (a : Fin (j + 1)) (g : Γ) : Scanner j := + ofRight Bool true (fun s cols => s && decide (cols a = g)) id + +theorem isConst_runR (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (isConst j a g).runR cols p = true ↔ ∀ q, 1 ≤ q → q ≤ p → cols q a = g := by + intro p + induction p with + | zero => simpa [runR, isConst, ofRight] using fun q h1 h2 => absurd h1 (by omega) + | succ p ih => + rw [runR] + show ((isConst j a g).runR cols p && decide (cols (p + 1) a = g)) = true ↔ _ + rw [Bool.and_eq_true, decide_eq_true_eq] + constructor + · rintro ⟨hall, hlast⟩ q h1 h2 + rcases Nat.lt_or_ge q (p + 1) with hlt | hge + · exact ih.mp hall q h1 (by omega) + · rw [show q = p + 1 by omega] + exact hlast + · intro h + exact ⟨ih.mpr fun q h1 h2 => h q h1 (by omega), h (p + 1) (by omega) le_rfl⟩ + +theorem isConst_runL (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) + (s : Bool) : (isConst j a g).runL cols p s = s := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL]; exact ih _ + +theorem isConst_run (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) (len : ℕ) : + (isConst j a g).run cols len = true ↔ ∀ q, 1 ≤ q → q ≤ len → cols q a = g := by + rw [run, isConst_runL, isConst_runR] + +theorem rightOnly_isConst (j : ℕ) (a : Fin (j + 1)) (g : Γ) : RightOnly (isConst j a g) := + fun _ _ => rfl + +/-- **A check over a prefix of cells.** -/ +theorem isConst_upTo_run (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) + (w len : ℕ) (hlen : w ≤ len) : + ((isConst j a g).upTo w).emit (((isConst j a g).upTo w).run cols len) = true ↔ + ∀ q, 1 ≤ q → q ≤ w → cols q a = g := by + rw [upTo_emit_run _ (rightOnly_isConst j a g) w len hlen] + show (isConst j a g).run cols w = true ↔ _ + rw [isConst_run] + +/-- **A one-cell check.** -/ +theorem isConst_cell (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) (len : ℕ) + (hlen : 1 ≤ len) : + ((isConst j a g).upTo 1).emit (((isConst j a g).upTo 1).run cols len) = true ↔ + cols 1 a = g := by + rw [isConst_upTo_run j a g cols 1 len hlen] + exact ⟨fun h => h 1 le_rfl le_rfl, fun h q h1 h2 => by rw [show q = 1 by omega]; exact h⟩ + +/-- Check that a register does **not** carry a fixed symbol. Frozen to one cell this is the +negation of `Complexity.Scanner.isConst`, which is what a loop's test needs when a failed check +should stop it. -/ +def isNotConst (j : ℕ) (a : Fin (j + 1)) (g : Γ) : Scanner j := + ofRight Bool false (fun s cols => s || decide (cols a ≠ g)) id + +theorem isNotConst_runR (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (isNotConst j a g).runR cols p = true ↔ ∃ q, 1 ≤ q ∧ q ≤ p ∧ cols q a ≠ g := by + intro p + induction p with + | zero => simp [runR, isNotConst, ofRight] + | succ p ih => + rw [runR] + show ((isNotConst j a g).runR cols p || decide (cols (p + 1) a ≠ g)) = true ↔ _ + rw [Bool.or_eq_true, decide_eq_true_eq] + constructor + · rintro (hall | hlast) + · obtain ⟨q, h1, h2, h3⟩ := ih.mp hall + exact ⟨q, h1, by omega, h3⟩ + · exact ⟨p + 1, by omega, le_rfl, hlast⟩ + · rintro ⟨q, h1, h2, h3⟩ + rcases Nat.lt_or_ge q (p + 1) with hlt | hge + · exact Or.inl (ih.mpr ⟨q, h1, by omega, h3⟩) + · exact Or.inr (by rw [show p + 1 = q by omega]; exact h3) + +theorem isNotConst_runL (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) + (s : Bool) : (isNotConst j a g).runL cols p s = s := by + induction p generalizing s with + | zero => rfl + | succ p ih => rw [runL]; exact ih _ + +theorem rightOnly_isNotConst (j : ℕ) (a : Fin (j + 1)) (g : Γ) : + RightOnly (isNotConst j a g) := fun _ _ => rfl + +/-- **A one-cell inequality check.** -/ +theorem isNotConst_cell (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) + (len : ℕ) (hlen : 1 ≤ len) : + ((isNotConst j a g).upTo 1).emit (((isNotConst j a g).upTo 1).run cols len) = true ↔ + cols 1 a ≠ g := by + rw [upTo_emit_run _ (rightOnly_isNotConst j a g) 1 len hlen] + show (isNotConst j a g).run cols 1 = true ↔ _ + rw [run, isNotConst_runL, isNotConst_runR] + exact ⟨fun ⟨q, h1, h2, h3⟩ => by rwa [show q = 1 by omega] at h3, + fun h => ⟨1, le_rfl, le_rfl, h⟩⟩ + +/-- **A constant check restricted to a range of cells.** -/ +theorem isConst_range_run (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) + (w₁ w₂ len : ℕ) (hw : w₂ ≤ len) : + (((isConst j a g).after w₁).upTo w₂).emit + ((((isConst j a g).after w₁).upTo w₂).run cols len) = true ↔ + ∀ q, w₁ < q → q ≤ w₂ → cols q a = g := by + rw [range_emit_run _ (rightOnly_isConst j a g) w₁ w₂ len hw] + show (isConst j a g).run (fun q => cols (w₁ + q)) (w₂ - w₁) = true ↔ _ + rw [isConst_run] + constructor + · intro h q h1 h2 + have := h (q - w₁) (by omega) (by omega) + rwa [show w₁ + (q - w₁) = q by omega] at this + · intro h q h1 h2 + exact h (w₁ + q) (by omega) (by omega) + +/-- **A difference check restricted to a range of cells.** -/ +theorem isNotConst_range_run (j : ℕ) (a : Fin (j + 1)) (g : Γ) (cols : ℕ → Fin (j + 1) → Γ) + (w₁ w₂ len : ℕ) (hw : w₂ ≤ len) : + (((isNotConst j a g).after w₁).upTo w₂).emit + ((((isNotConst j a g).after w₁).upTo w₂).run cols len) = true ↔ + ∃ q, w₁ < q ∧ q ≤ w₂ ∧ cols q a ≠ g := by + rw [range_emit_run _ (rightOnly_isNotConst j a g) w₁ w₂ len hw] + show (isNotConst j a g).run (fun q => cols (w₁ + q)) (w₂ - w₁) = true ↔ _ + rw [run, isNotConst_runL, isNotConst_runR] + constructor + · rintro ⟨q, h1, h2, h3⟩ + exact ⟨w₁ + q, by omega, by omega, h3⟩ + · rintro ⟨q, h1, h2, h3⟩ + refine ⟨q - w₁, by omega, by omega, ?_⟩ + rwa [show w₁ + (q - w₁) = q by omega] + +/-! ## A scanner that takes a conjunction + +Each check writes its verdict to its own register; one more scan over those registers reports +whether they all said yes. -/ + +/-- Report whether every scanned tape carries `Γ.one` throughout. -/ +def andAll (j : ℕ) : Scanner j := + ofRight Bool true (fun s cols => s && decide (∀ i, cols i = Γ.one)) id + +@[simp] theorem andAll_stepR (j : ℕ) (s : Bool) (cols : Fin (j + 1) → Γ) : + (andAll j).stepR s cols = (s && decide (∀ i, cols i = Γ.one)) := rfl + +theorem andAll_runR (j : ℕ) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (andAll j).runR cols p = true ↔ + ∀ q, 1 ≤ q → q ≤ p → ∀ i, cols q i = Γ.one := by + intro p + induction p with + | zero => exact ⟨fun _ q h1 h2 => absurd h1 (by omega), fun _ => rfl⟩ + | succ p ih => + rw [runR] + show ((andAll j).runR cols p && decide (∀ i, cols (p + 1) i = Γ.one)) = true ↔ _ + rw [Bool.and_eq_true, decide_eq_true_eq] + constructor + · rintro ⟨hall, hlast⟩ q h1 h2 + rcases Nat.lt_or_ge q (p + 1) with h | h + · exact ih.mp hall q h1 (by omega) + · have hqp : q = p + 1 := by omega + rw [hqp] + exact hlast + · intro hall + exact ⟨ih.mpr fun q h1 h2 => hall q h1 (by omega), hall (p + 1) (by omega) le_rfl⟩ + +/-- **What the conjunction scanner reports.** -/ +theorem andAll_run (j : ℕ) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) : + (andAll j).run cols p = true ↔ ∀ q, 1 ≤ q → q ≤ p → ∀ i, cols q i = Γ.one := by + have hrunL : ∀ s : Bool, (andAll j).runL cols p s = s := fun s => + ofRight_runL Bool _ _ _ cols p s + rw [run, hrunL, andAll_runR] + +/-- Report whether the *designated* tapes all carry `Γ.one`. The verdict registers of a +composite check are scattered — each check owns a contiguous block, so their result tapes are +not adjacent — so the combining scan reads every tape and looks only at the ones it is told +to. -/ +def andSome (j : ℕ) (P : Fin (j + 1) → Bool) : Scanner j := + ofRight Bool true (fun s cols => s && decide (∀ i, P i = true → cols i = Γ.one)) id + +@[simp] theorem andSome_stepR (j : ℕ) (P : Fin (j + 1) → Bool) (s : Bool) + (cols : Fin (j + 1) → Γ) : + (andSome j P).stepR s cols = (s && decide (∀ i, P i = true → cols i = Γ.one)) := rfl + +theorem andSome_runR (j : ℕ) (P : Fin (j + 1) → Bool) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (andSome j P).runR cols p = true ↔ + ∀ q, 1 ≤ q → q ≤ p → ∀ i, P i = true → cols q i = Γ.one := by + intro p + induction p with + | zero => exact ⟨fun _ q h1 h2 => absurd h1 (by omega), fun _ => rfl⟩ + | succ p ih => + rw [runR] + show ((andSome j P).runR cols p && + decide (∀ i, P i = true → cols (p + 1) i = Γ.one)) = true ↔ _ + rw [Bool.and_eq_true, decide_eq_true_eq] + constructor + · rintro ⟨hall, hlast⟩ q h1 h2 + rcases Nat.lt_or_ge q (p + 1) with h | h + · exact ih.mp hall q h1 (by omega) + · have hqp : q = p + 1 := by omega + rw [hqp] + exact hlast + · intro hall + exact ⟨ih.mpr fun q h1 h2 => hall q h1 (by omega), hall (p + 1) (by omega) le_rfl⟩ + +/-- **What the selective conjunction scanner reports.** -/ +theorem andSome_run (j : ℕ) (P : Fin (j + 1) → Bool) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) : + (andSome j P).run cols p = true ↔ + ∀ q, 1 ≤ q → q ≤ p → ∀ i, P i = true → cols q i = Γ.one := by + have hrunL : ∀ s : Bool, (andSome j P).runL cols p s = s := fun s => + ofRight_runL Bool _ _ _ cols p s + rw [run, hrunL, andSome_runR] + +/-- Report whether the designated tapes carry `Γ.one` in their **first** cell. A verdict register +holds a single bit and blanks after it, so a scan whose length is set by some longer register must +look only at the first column. -/ +def andFirst (j : ℕ) (P : Fin (j + 1) → Bool) : Scanner j := + ofRight (Bool × Bool) (true, false) + (fun s cols => + (if s.2 then s.1 else s.1 && decide (∀ i, P i = true → cols i = Γ.one), true)) + (fun s => s.1) + +theorem andFirst_runR (j : ℕ) (P : Fin (j + 1) → Bool) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (andFirst j P).runR cols p + = (if p = 0 then true else decide (∀ i, P i = true → cols 1 i = Γ.one), + decide (0 < p)) := by + intro p + induction p with + | zero => rfl + | succ p ih => + rw [runR, ih] + show (if (decide (0 < p)) then _ else _, true) = _ + rcases Nat.eq_zero_or_pos p with hp | hp + · subst hp + simp + · rw [if_pos (by simpa using hp)] + simp [Nat.ne_of_gt hp] + +/-- **What the first-cell conjunction scanner reports.** -/ +theorem andFirst_run (j : ℕ) (P : Fin (j + 1) → Bool) (cols : ℕ → Fin (j + 1) → Γ) (p : ℕ) + (hp : 0 < p) : + (andFirst j P).emit ((andFirst j P).run cols p) = true ↔ + ∀ i, P i = true → cols 1 i = Γ.one := by + have hrunL : ∀ s : Bool × Bool, (andFirst j P).runL cols p s = s := fun s => + ofRight_runL (Bool × Bool) _ _ _ cols p s + rw [run, hrunL, andFirst_runR] + show (if p = 0 then true else decide (∀ i, P i = true → cols 1 i = Γ.one)) = true ↔ _ + rw [if_neg (by omega), decide_eq_true_eq] + +/-- Report an arbitrary function of the **first** column. Verdict registers hold a single bit +each, so a composite decision — "these checks all passed, *or* those did" — is a function of one +column, however long the scan turns out to be. -/ +def firstCol (j : ℕ) (f : (Fin (j + 1) → Γ) → Bool) : Scanner j := + ofRight (Bool × Bool) (true, false) + (fun s cols => (if s.2 then s.1 else f cols, true)) (fun s => s.1) + +theorem firstCol_runR (j : ℕ) (f : (Fin (j + 1) → Γ) → Bool) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, (firstCol j f).runR cols p + = (if p = 0 then true else f (cols 1), decide (0 < p)) := by + intro p + induction p with + | zero => rfl + | succ p ih => + rw [runR, ih] + show (if (decide (0 < p)) then _ else _, true) = _ + rcases Nat.eq_zero_or_pos p with hp | hp + · subst hp + simp + · rw [if_pos (by simpa using hp)] + simp [Nat.ne_of_gt hp] + +/-- **What the first-column scanner reports.** -/ +theorem firstCol_run (j : ℕ) (f : (Fin (j + 1) → Γ) → Bool) (cols : ℕ → Fin (j + 1) → Γ) + (p : ℕ) (hp : 0 < p) : + (firstCol j f).emit ((firstCol j f).run cols p) = f (cols 1) := by + have hrunL : ∀ s : Bool × Bool, (firstCol j f).runL cols p s = s := fun s => + ofRight_runL (Bool × Bool) _ _ _ cols p s + rw [run, hrunL, firstCol_runR] + show (if p = 0 then true else f (cols 1)) = _ + rw [if_neg (by omega)] + +/-! ## A scanner that checks an increment + +Registers hold little-endian bits, so a scan meets them least significant first — which is the +order an increment carries in. -/ + +/-- The value of the first `p` bits of a register, read little-endian. -/ +def valUpTo (f : ℕ → Bool) : ℕ → ℕ + | 0 => 0 + | p + 1 => valUpTo f p + (if f (p + 1) then 2 ^ p else 0) + +/-- Check that register `b` holds one more than register `a`. -/ +def plusOne (j : ℕ) (a b : Fin (j + 1)) : Scanner j := + ofRight (Bool × Bool) (true, true) + (fun s cols => + let ba := decide (cols a = Γ.one) + let bb := decide (cols b = Γ.one) + (ba && s.1, s.2 && decide (bb = (xor ba s.1)))) + (fun s => !s.1 && s.2) + +/-- The value of `p` bits fits in `p` bits. -/ +theorem valUpTo_lt (f : ℕ → Bool) : ∀ p : ℕ, valUpTo f p < 2 ^ p := by + intro p + induction p with + | zero => simp [valUpTo] + | succ p ih => + have hpow : (2 : ℕ) ^ (p + 1) = 2 ^ p + 2 ^ p := by rw [pow_succ]; omega + rw [valUpTo] + split <;> omega + +/-- **The invariant of the increment check.** The carry is exactly "every bit of `a` so far was +one", and the running verdict says exactly that the bits of `b` so far are those of `a + 1`. -/ +theorem plusOne_runR (j : ℕ) (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) : + ∀ p : ℕ, ∃ c v : Bool, (plusOne j a b).runR cols p = (c, v) ∧ + (c = true ↔ valUpTo (bitAt cols a) p + 1 = 2 ^ p) ∧ + (v = true ↔ valUpTo (bitAt cols b) p + (if c then 2 ^ p else 0) + = valUpTo (bitAt cols a) p + 1) := by + intro p + induction p with + | zero => exact ⟨true, true, rfl, by simp [valUpTo], by simp [valUpTo]⟩ + | succ p ih => + obtain ⟨c, v, hrun, hcar, hinv⟩ := ih + have hpow : (0 : ℕ) < 2 ^ p := Nat.two_pow_pos p + have hpow2 : (2 : ℕ) ^ (p + 1) = 2 ^ p + 2 ^ p := by rw [pow_succ]; omega + have hlA : valUpTo (bitAt cols a) p < 2 ^ p := valUpTo_lt _ p + have hlB : valUpTo (bitAt cols b) p < 2 ^ p := valUpTo_lt _ p + refine ⟨bitAt cols a (p + 1) && c, + v && decide (bitAt cols b (p + 1) = xor (bitAt cols a (p + 1)) c), ?_, ?_, ?_⟩ + · rw [runR, hrun] + rfl + · cases c <;> cases hA : bitAt cols a (p + 1) <;> + simp_all [valUpTo] <;> omega + · simp only [valUpTo, Bool.and_eq_true, decide_eq_true_eq] + cases c <;> cases v <;> + simp only [Bool.false_eq_true, if_true, if_false, Bool.xor_false, Bool.xor_true, + true_iff, false_iff] at hinv hcar ⊢ <;> + cases hA : bitAt cols a (p + 1) <;> cases hB : bitAt cols b (p + 1) <;> + simp_all <;> + omega + +/-- **What the increment scanner reports.** -/ +theorem plusOne_run (j : ℕ) (a b : Fin (j + 1)) (cols : ℕ → Fin (j + 1) → Γ) (len : ℕ) : + (plusOne j a b).emit ((plusOne j a b).run cols len) = true ↔ + valUpTo (bitAt cols b) len = valUpTo (bitAt cols a) len + 1 := by + obtain ⟨c, v, hrun, hcar, hinv⟩ := plusOne_runR j a b cols len + have hrunL : ∀ (s : Bool × Bool), (plusOne j a b).runL cols len s = s := fun s => + ofRight_runL (Bool × Bool) _ _ _ cols len s + have hrun' : (plusOne j a b).run cols len = (c, v) := by + rw [run, hrunL, hrun] + rw [hrun'] + have hlB : valUpTo (bitAt cols b) len < 2 ^ len := valUpTo_lt _ len + clear hrun hrun' hrunL + show (!c && v) = true ↔ _ + cases c <;> cases v <;> + simp only [Bool.not_true, Bool.not_false, Bool.false_and, Bool.true_and, + Bool.false_eq_true, if_true, if_false, true_iff, false_iff] at hcar hinv ⊢ <;> + omega + +end Scanner + +namespace TM + +variable {j : ℕ} + +/-- The control phases of `TM.twoPassTM`. -/ +inductive TwoPassPhase where + /-- Walking right to the first blank of tape `0`. -/ + | right + /-- Walking back left to the left marker. -/ + | left + /-- Publishing the verdict. -/ + | emit + /-- Halted. -/ + | done + deriving DecidableEq + +instance : Fintype TwoPassPhase where + elems := {.right, .left, .emit, .done} + complete := fun x => by cases x <;> simp + +/-- The control states of the scanning machine: a phase and the automaton's own state. -/ +abbrev TwoPassQ (S : Scanner j) : Type := TwoPassPhase × S.σ + +instance (S : Scanner j) : DecidableEq (TwoPassQ S) := by + haveI := S.decEqσ + exact inferInstanceAs (DecidableEq (TwoPassPhase × S.σ)) + +instance (S : Scanner j) : Fintype (TwoPassQ S) := by + haveI := S.finσ + exact inferInstanceAs (Fintype (TwoPassPhase × S.σ)) + +/-- **The scanning machine.** Work tapes `0 … j` are scanned in lockstep and work tape `j + 1` +receives the verdict. -/ +def twoPassTM (S : Scanner j) : TM (j + 2) := + { Q := TwoPassQ S + qstart := (.right, S.start) + qhalt := (.done, S.start) + δ := fun q iHead wHeads oHead => + let syms : Fin (j + 1) → Γ := fun i => wHeads i.castSucc + let keep : Fin (j + 2) → Γw := fun i => readBackWrite (wHeads i) + let idle : Fin (j + 2) → Dir3 := fun i => idleDir (wHeads i) + let lastIdle : Dir3 := idleDir (wHeads (Fin.last (j + 1))) + match q with + | (.right, s) => + if syms 0 = Γ.blank then + ((TwoPassPhase.left, s), keep, readBackWrite oHead, idleDir iHead, + Fin.snoc (fun i => moveLeftDir (syms i)) lastIdle, idleDir oHead) + else + ((TwoPassPhase.right, S.stepR s syms), keep, readBackWrite oHead, idleDir iHead, + Fin.snoc (fun _ => Dir3.right) lastIdle, idleDir oHead) + | (.left, s) => + if syms 0 = Γ.start then + ((TwoPassPhase.emit, s), keep, readBackWrite oHead, idleDir iHead, + Fin.snoc (fun _ => Dir3.right) lastIdle, idleDir oHead) + else + ((TwoPassPhase.left, S.stepL s syms), keep, readBackWrite oHead, idleDir iHead, + Fin.snoc (fun i => moveLeftDir (syms i)) lastIdle, idleDir oHead) + | (.emit, s) => + ((TwoPassPhase.done, S.start), + Fin.snoc (fun i => readBackWrite (syms i)) (if S.emit s then Γw.one else Γw.zero), + readBackWrite oHead, idleDir iHead, idle, idleDir oHead) + | (.done, s) => allIdle (TwoPassPhase.done, s) iHead wHeads oHead + δ_right_of_start := by + rintro ⟨p, s⟩ iHead wHeads oHead + have hsnocR : ∀ (d : Fin (j + 1) → Dir3) (e : Dir3), + (∀ i' : Fin (j + 1), wHeads i'.castSucc = Γ.start → d i' = Dir3.right) → + (wHeads (Fin.last (j + 1)) = Γ.start → e = Dir3.right) → + ∀ (i : Fin (j + 2)), wHeads i = Γ.start → + (Fin.snoc d e : Fin (j + 2) → Dir3) i = Dir3.right := by + intro d e hd he i + refine Fin.lastCases ?_ ?_ i + · intro hlast + rw [Fin.snoc_last] + exact he hlast + · intro i' hcs + rw [Fin.snoc_castSucc] + exact hd i' hcs + cases p with + | right => + dsimp only + split + · exact ⟨idleDir_right_of_start, fun i hi => + hsnocR _ _ (fun _ h => moveLeftDir_right_of_start h) + (fun h => idleDir_right_of_start h) i hi, idleDir_right_of_start⟩ + · exact ⟨idleDir_right_of_start, fun i hi => + hsnocR _ _ (fun _ _ => rfl) (fun h => idleDir_right_of_start h) i hi, + idleDir_right_of_start⟩ + | left => + dsimp only + split + · exact ⟨idleDir_right_of_start, fun i hi => + hsnocR _ _ (fun _ _ => rfl) (fun h => idleDir_right_of_start h) i hi, + idleDir_right_of_start⟩ + · exact ⟨idleDir_right_of_start, fun i hi => + hsnocR _ _ (fun _ h => moveLeftDir_right_of_start h) + (fun h => idleDir_right_of_start h) i hi, idleDir_right_of_start⟩ + | emit => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + | done => exact rightOfStart_allIdle iHead wHeads oHead } + +/-! ## What one step does -/ + +private theorem move_idle {t : Tape} (h : t.read ≠ Γ.start) : t.move (idleDir t.read) = t := by + rw [idleDir, if_neg h] + rfl + +private theorem tape_keep {t : Tape} (h : t.read ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack _ h, idleDir, if_neg h] + rfl + +private theorem tape_right {t : Tape} (h : t.read ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) Dir3.right = ⟨t.head + 1, t.cells⟩ := by + rw [writeAndMove_readBack _ h] + rfl + +private theorem tape_left {t : Tape} (h : t.read ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) (moveLeftDir t.read) = ⟨t.head - 1, t.cells⟩ := by + rw [writeAndMove_readBack _ h, moveLeftDir, if_neg h] + rfl + +/-- The column of symbols under the scanned heads when they are all at cell `h`. -/ +def scanCol (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) : Fin (j + 1) → Γ := fun i => cells i h + +/-- A configuration of the scanning machine: every scanned head at cell `h`. -/ +def twoPassCfg (S : Scanner j) (q : TwoPassQ S) (inp : Tape) (cells : Fin (j + 1) → ℕ → Γ) + (h : ℕ) (res out : Tape) : Cfg (j + 2) (twoPassTM S).Q where + state := q + input := inp + work := Fin.snoc (fun i => (⟨h, cells i⟩ : Tape)) res + output := out + +/-- The tapes a scan leaves alone: their heads are off the left marker, so every step writes them +back unchanged and idles them. -/ +structure ScanOk (inp res out : Tape) : Prop where + /-- The input head is off the left marker. -/ + inp : inp.read ≠ Γ.start + /-- The result head is off the left marker. -/ + res : res.read ≠ Γ.start + /-- The output head is off the left marker. -/ + out : out.read ≠ Γ.start + +private theorem work_read (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res : Tape) + (i : Fin (j + 1)) : + ((Fin.snoc (fun i => (⟨h, cells i⟩ : Tape)) res : Fin (j + 2) → Tape) i.castSucc).read + = cells i h := by + rw [Fin.snoc_castSucc] + rfl + +private theorem work_read_last (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res : Tape) : + ((Fin.snoc (fun i => (⟨h, cells i⟩ : Tape)) res : Fin (j + 2) → Tape) + (Fin.last (j + 1))).read = res.read := by + rw [Fin.snoc_last] + +/-- The rightward pass, while tape `0` has not run out. -/ +theorem twoPassCfg_step_right (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) + (hok : ScanOk inp res out) (hc : ∀ i, cells i h ≠ Γ.start) (hne : cells 0 h ≠ Γ.blank) : + (twoPassTM S).stepCfg (twoPassCfg S (TwoPassPhase.right, s) inp cells h res out) + = twoPassCfg S (TwoPassPhase.right, S.stepR s (scanCol cells h)) inp cells (h + 1) + res out := by + refine Cfg.ext ?_ ?_ ?_ ?_ + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hne, if_false] + rfl + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hne, if_false] + exact move_idle hok.inp + · funext i + refine Fin.lastCases ?_ ?_ i + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hne, if_false] + simp only [Fin.snoc_last] + exact tape_keep hok.res + · intro i' + simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hne, if_false] + simp only [Fin.snoc_castSucc] + exact tape_right (show (⟨h, cells i'⟩ : Tape).read ≠ Γ.start from hc i') + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hne, if_false] + exact tape_keep hok.out + +private theorem tape_start_right {t : Tape} (hh : t.head = 0) (g : Γ) : + t.writeAndMove g Dir3.right = ⟨1, t.cells⟩ := by + show (t.write g).move Dir3.right = _ + rw [Tape.write, if_pos hh] + show (⟨t.head + 1, t.cells⟩ : Tape) = _ + rw [hh] + +/-- The turn: tape `0` has run out, so the scan starts back. -/ +theorem twoPassCfg_step_turn (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) + (hok : ScanOk inp res out) (hc : ∀ i, cells i h ≠ Γ.start) (hb : cells 0 h = Γ.blank) : + (twoPassTM S).stepCfg (twoPassCfg S (TwoPassPhase.right, s) inp cells h res out) + = twoPassCfg S (TwoPassPhase.left, s) inp cells (h - 1) res out := by + refine Cfg.ext ?_ ?_ ?_ ?_ + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hb, if_true] + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hb, if_true] + exact move_idle hok.inp + · funext i + refine Fin.lastCases ?_ ?_ i + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hb, if_true] + simp only [Fin.snoc_last] + exact tape_keep hok.res + · intro i' + simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hb, if_true] + simp only [Fin.snoc_castSucc] + exact tape_left (show (⟨h, cells i'⟩ : Tape).read ≠ Γ.start from hc i') + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hb, if_true] + exact tape_keep hok.out + +/-- The leftward pass, while the left marker is not yet in sight. -/ +theorem twoPassCfg_step_left (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) + (hok : ScanOk inp res out) (hc : ∀ i, cells i h ≠ Γ.start) : + (twoPassTM S).stepCfg (twoPassCfg S (TwoPassPhase.left, s) inp cells h res out) + = twoPassCfg S (TwoPassPhase.left, S.stepL s (scanCol cells h)) inp cells (h - 1) + res out := by + have hns : ¬ (cells 0 h = Γ.start) := hc 0 + refine Cfg.ext ?_ ?_ ?_ ?_ + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hns, if_false] + rfl + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hns, if_false] + exact move_idle hok.inp + · funext i + refine Fin.lastCases ?_ ?_ i + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hns, if_false] + simp only [Fin.snoc_last] + exact tape_keep hok.res + · intro i' + simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hns, if_false] + simp only [Fin.snoc_castSucc] + exact tape_left (show (⟨h, cells i'⟩ : Tape).read ≠ Γ.start from hc i') + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hns, if_false] + exact tape_keep hok.out + +/-- The leftward pass reaches the marker and the scan turns to publishing. -/ +theorem twoPassCfg_step_stop (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (res out : Tape) + (hok : ScanOk inp res out) (hs : ∀ i, cells i 0 = Γ.start) : + (twoPassTM S).stepCfg (twoPassCfg S (TwoPassPhase.left, s) inp cells 0 res out) + = twoPassCfg S (TwoPassPhase.emit, s) inp cells 1 res out := by + have hst : cells 0 0 = Γ.start := hs 0 + refine Cfg.ext ?_ ?_ ?_ ?_ + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hst, if_true] + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hst, if_true] + exact move_idle hok.inp + · funext i + refine Fin.lastCases ?_ ?_ i + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hst, if_true] + simp only [Fin.snoc_last] + exact tape_keep hok.res + · intro i' + simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hst, if_true] + simp only [Fin.snoc_castSucc] + exact tape_start_right (show (⟨0, cells i'⟩ : Tape).head = 0 from rfl) _ + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read, hst, if_true] + exact tape_keep hok.out + +/-- Publishing the verdict: one bit onto the result tape, then halt. -/ +theorem twoPassCfg_step_emit (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) + (hok : ScanOk inp res out) (hc : ∀ i, cells i h ≠ Γ.start) : + (twoPassTM S).stepCfg (twoPassCfg S (TwoPassPhase.emit, s) inp cells h res out) + = twoPassCfg S (TwoPassPhase.done, S.start) inp cells h + (res.write (Γ.ofBool (S.emit s))) out := by + refine Cfg.ext ?_ ?_ ?_ ?_ + · simp only [TM.stepCfg, twoPassCfg, twoPassTM] + · simp only [TM.stepCfg, twoPassCfg, twoPassTM] + exact move_idle hok.inp + · funext i + refine Fin.lastCases ?_ ?_ i + · simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read_last] + simp only [Fin.snoc_last] + show res.writeAndMove _ (idleDir res.read) = _ + rw [idleDir, if_neg hok.res] + cases hb : S.emit s <;> rfl + · intro i' + simp only [TM.stepCfg, twoPassCfg, twoPassTM, work_read] + simp only [Fin.snoc_castSucc] + exact tape_keep (show (⟨h, cells i'⟩ : Tape).read ≠ Γ.start from hc i') + · simp only [TM.stepCfg, twoPassCfg, twoPassTM] + exact tape_keep hok.out + +/-! ## What a whole scan does -/ + +/-- The tape shape a scan expects: every tape carries its left marker and nothing else does, and +tape `0` runs for exactly `len` cells. -/ +structure ScanTape (cells : Fin (j + 1) → ℕ → Γ) (len : ℕ) : Prop where + /-- Cell zero of every scanned tape is the left marker. -/ + start : ∀ i, cells i 0 = Γ.start + /-- No other cell is. -/ + ne_start : ∀ i q, 1 ≤ q → cells i q ≠ Γ.start + /-- Tape `0` is non-blank throughout its length. -/ + ne_blank : ∀ q, 1 ≤ q → q ≤ len → cells 0 q ≠ Γ.blank + /-- And blank immediately after. -/ + blank : cells 0 (len + 1) = Γ.blank + +private theorem not_halted_right (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) : + (twoPassCfg S (TwoPassPhase.right, s) inp cells h res out).state ≠ (twoPassTM S).qhalt := by + intro hq + exact TwoPassPhase.noConfusion (congrArg Prod.fst hq) + +private theorem not_halted_left (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) : + (twoPassCfg S (TwoPassPhase.left, s) inp cells h res out).state ≠ (twoPassTM S).qhalt := by + intro hq + exact TwoPassPhase.noConfusion (congrArg Prod.fst hq) + +private theorem not_halted_emit (S : Scanner j) (s : S.σ) (inp : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) (res out : Tape) : + (twoPassCfg S (TwoPassPhase.emit, s) inp cells h res out).state ≠ (twoPassTM S).qhalt := by + intro hq + exact TwoPassPhase.noConfusion (congrArg Prod.fst hq) + +/-- **The rightward pass.** -/ +theorem twoPassCfg_run_right (S : Scanner j) (inp res out : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (len : ℕ) + (hok : ScanOk inp res out) (ht : ScanTape cells len) : + ∀ d p, p + d = len → + (twoPassTM S).reachesIn d + (twoPassCfg S (TwoPassPhase.right, S.runR (scanCol cells) p) inp cells (p + 1) res out) + (twoPassCfg S (TwoPassPhase.right, S.runR (scanCol cells) len) inp cells (len + 1) + res out) := by + intro d + induction d with + | zero => + intro p hp + rw [show p = len by omega] + exact reachesIn.zero + | succ d ih => + intro p hp + have hne : cells 0 (p + 1) ≠ Γ.blank := ht.ne_blank (p + 1) (by omega) (by omega) + have hc : ∀ i, cells i (p + 1) ≠ Γ.start := fun i => ht.ne_start i (p + 1) (by omega) + refine reachesIn.step ?_ (ih (p + 1) (by omega)) + rw [step_of_not_halted _ (not_halted_right S _ inp cells (p + 1) res out), + twoPassCfg_step_right S _ inp cells (p + 1) res out hok hc hne] + rfl + +/-- **The leftward pass.** -/ +theorem twoPassCfg_run_left (S : Scanner j) (inp res out : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (len : ℕ) + (hok : ScanOk inp res out) (ht : ScanTape cells len) : + ∀ (h : ℕ) (s : S.σ), + (twoPassTM S).reachesIn h + (twoPassCfg S (TwoPassPhase.left, s) inp cells h res out) + (twoPassCfg S (TwoPassPhase.left, S.runL (scanCol cells) h s) inp cells 0 res out) := by + intro h + induction h with + | zero => intro s; exact reachesIn.zero + | succ h ih => + intro s + have hc : ∀ i, cells i (h + 1) ≠ Γ.start := fun i => ht.ne_start i (h + 1) (by omega) + refine reachesIn.step ?_ (ih _) + rw [step_of_not_halted _ (not_halted_left S _ inp cells (h + 1) res out), + twoPassCfg_step_left S _ inp cells (h + 1) res out hok hc] + rfl + +/-- **A whole scan.** Started with every scanned head on cell one, the machine walks tape `0` to +its first blank and back, and halts with the automaton's verdict written on the result tape. +Nothing else on any tape moves. -/ +theorem twoPassCfg_run (S : Scanner j) (inp res out : Tape) + (cells : Fin (j + 1) → ℕ → Γ) (len : ℕ) + (hok : ScanOk inp res out) (ht : ScanTape cells len) : + (twoPassTM S).reachesIn (2 * len + 3) + (twoPassCfg S (twoPassTM S).qstart inp cells 1 res out) + (twoPassCfg S (TwoPassPhase.done, S.start) inp cells 1 + (res.write (Γ.ofBool (S.emit (S.run (scanCol cells) len)))) out) := by + have hcL : ∀ i, cells i (len + 1) ≠ Γ.start := fun i => ht.ne_start i (len + 1) (by omega) + have hc1 : ∀ i, cells i 1 ≠ Γ.start := fun i => ht.ne_start i 1 (by omega) + have hstart : (twoPassCfg S (twoPassTM S).qstart inp cells 1 res out) + = twoPassCfg S (TwoPassPhase.right, S.runR (scanCol cells) 0) inp cells (0 + 1) res out := + rfl + have hturn : (twoPassTM S).reachesIn 1 + (twoPassCfg S (TwoPassPhase.right, S.runR (scanCol cells) len) inp cells (len + 1) res out) + (twoPassCfg S (TwoPassPhase.left, S.runR (scanCol cells) len) inp cells len res out) := by + refine reachesIn.step ?_ reachesIn.zero + rw [step_of_not_halted _ (not_halted_right S _ inp cells (len + 1) res out), + twoPassCfg_step_turn S _ inp cells (len + 1) res out hok hcL ht.blank] + rfl + have hstop : (twoPassTM S).reachesIn 1 + (twoPassCfg S (TwoPassPhase.left, S.run (scanCol cells) len) inp cells 0 res out) + (twoPassCfg S (TwoPassPhase.emit, S.run (scanCol cells) len) inp cells 1 res out) := by + refine reachesIn.step ?_ reachesIn.zero + rw [step_of_not_halted _ (not_halted_left S _ inp cells 0 res out), + twoPassCfg_step_stop S _ inp cells res out hok ht.start] + have hemit : (twoPassTM S).reachesIn 1 + (twoPassCfg S (TwoPassPhase.emit, S.run (scanCol cells) len) inp cells 1 res out) + (twoPassCfg S (TwoPassPhase.done, S.start) inp cells 1 + (res.write (Γ.ofBool (S.emit (S.run (scanCol cells) len)))) out) := by + refine reachesIn.step ?_ reachesIn.zero + rw [step_of_not_halted _ (not_halted_emit S _ inp cells 1 res out), + twoPassCfg_step_emit S _ inp cells 1 res out hok hc1] + have hcount : 2 * len + 3 = len + (1 + (len + (1 + 1))) := by omega + rw [hstart, hcount] + refine (twoPassTM S).reachesIn_trans (twoPassCfg_run_right S inp res out cells len hok ht len 0 + (by omega)) ?_ + refine (twoPassTM S).reachesIn_trans hturn ?_ + refine (twoPassTM S).reachesIn_trans (twoPassCfg_run_left S inp res out cells len hok ht len _) + ?_ + exact (twoPassTM S).reachesIn_trans hstop hemit + +/-- A scan ends halted. -/ +theorem twoPassCfg_halted (S : Scanner j) (inp : Tape) (cells : Fin (j + 1) → ℕ → Γ) (h : ℕ) + (res out : Tape) : + (twoPassTM S).halted (twoPassCfg S (TwoPassPhase.done, S.start) inp cells h res out) := rfl + +/-- **The scan as a Hoare triple**, which is the form `TM.seqTM` and `TM.loopTM` compose. -/ +theorem twoPassTM_hoareTime (S : Scanner j) (cells : Fin (j + 1) → ℕ → Γ) (len : ℕ) + (inp₀ out₀ res₀ : Tape) (hok : ScanOk inp₀ res₀ out₀) (ht : ScanTape cells len) : + (twoPassTM S).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) res₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) + (res₀.write (Γ.ofBool (S.emit (S.run (scanCol cells) len))))) + (2 * len + 3) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨_, 2 * len + 3, le_rfl, twoPassCfg_run S _ _ _ cells len hok ht, + twoPassCfg_halted S _ cells 1 _ _, rfl, rfl, rfl⟩ + +/-- **A check on the whole register set.** The scanner names the columns it reads, so a check +needs neither its registers moved next to one another nor a private copy of them. -/ +def checkTM {jd jj : ℕ} (S : Scanner jd) (f : Fin (jd + 1) → Fin (jj + 1)) : TM (jj + 2) := + twoPassTM (S.comap f) + +/-- **Its contract**: the verdict of the scanner, read off the named columns. -/ +theorem checkTM_hoareTime {jd jj : ℕ} (S : Scanner jd) (f : Fin (jd + 1) → Fin (jj + 1)) + (cells : Fin (jj + 1) → ℕ → Γ) (len : ℕ) (inp₀ out₀ res₀ : Tape) + (hok : ScanOk inp₀ res₀ out₀) (ht : ScanTape cells len) : + (checkTM S f).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) res₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work = Fin.snoc (fun i => (⟨1, cells i⟩ : Tape)) + (res₀.write (Γ.ofBool (S.emit (S.run (fun q i => cells (f i) q) len))))) + (2 * len + 3) := by + have h := twoPassTM_hoareTime (S.comap f) cells len inp₀ out₀ res₀ hok ht + simpa only [Scanner.comap_run, Scanner.comap_emit, scanCol] using h + +end TM + +end Complexity diff --git a/ROADMAP.md b/ROADMAP.md index 036881ed..133165b4 100644 --- a/ROADMAP.md +++ b/ROADMAP.md @@ -1228,10 +1228,15 @@ syntax. - [ ] Prove closure and normal-form lemmas for deterministic and nondeterministic space, including configuration counting. -- [ ] Formalize Savitch's theorem with an explicit recursive reachability machine: - `NSPACE(S) subset DSPACE(S^2)` under suitable constructibility and lower-bound - hypotheses. -- [ ] Derive `NPSPACE = PSPACE` in the library's polynomial-union convention. +- [x] Formalize Savitch's theorem, as a polynomial-time stack recursion iterated in + place rather than an explicit machine (`Complexity.savStep`, `Complexity.Sav.step`, + `Complexity.Sav.run_frame`, `Complexity.accB_cfgCode`, + `Complexity.SpaceIter.mem_PSPACE_of_iterate`). +- [x] Derive `NPSPACE = PSPACE` in the library's polynomial-union convention + (`Complexity.NPSPACE_subset_PSPACE`, `Complexity.PSPACE_eq_NPSPACE`). +- [x] Prove `IP ⊆ PSPACE` by evaluating the protocol's game tree with a stack walk + (`Complexity.IP_subset_PSPACE`; `Protocol.gval`, `Complexity.IPM.step`, + `Complexity.IPM.ipStep`). - [ ] Define alternating machines or an equivalent bounded game semantics. - [ ] Prove polynomial-time alternation equals PSPACE, or first prove a bounded configuration-game characterization. diff --git a/scripts/AxiomGuard.lean b/scripts/AxiomGuard.lean index f79d683d..bd5a84cf 100644 --- a/scripts/AxiomGuard.lean +++ b/scripts/AxiomGuard.lean @@ -74,6 +74,15 @@ def headlineTheorems : List Name := [ `Complexity.UniformPPoly_eq_P, `Complexity.RP_subset_NP, `Complexity.BPP_subset_PP, + `Complexity.NL_subset_P, + `Complexity.PSPACE_subset_EXP, + `Complexity.PP_subset_PSPACE, + `Complexity.PH_subset_PSPACE, + -- Savitch's theorem + `Complexity.NPSPACE_subset_PSPACE, + `Complexity.PSPACE_eq_NPSPACE, + -- the easy half of Shamir's theorem + `Complexity.IP_subset_PSPACE, -- Circuit lower and upper bounds `Complexity.shannon_lower_bound_circuit, `Complexity.shannon_sizeComplexity, From eff5da7b2991eb7e74684e0c652e404387c55b88 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Sat, 22 Aug 2026 15:48:04 -0700 Subject: [PATCH 17/24] pcp class statement --- Complexitylib/Classes.lean | 1 + Complexitylib/Classes/PCP.lean | 178 +++++++++++++++++++++++++++++++++ 2 files changed, 179 insertions(+) create mode 100644 Complexitylib/Classes/PCP.lean diff --git a/Complexitylib/Classes.lean b/Complexitylib/Classes.lean index 0a9d2bc2..23946522 100644 --- a/Complexitylib/Classes.lean +++ b/Complexitylib/Classes.lean @@ -54,6 +54,7 @@ public import Complexitylib.Classes.PPoly.Uniform.Preprocessing public import Complexitylib.Classes.PPoly.Uniform.Containment public import Complexitylib.Classes.NP public import Complexitylib.Classes.Interactive +public import Complexitylib.Classes.PCP public import Complexitylib.Classes.Randomized public import Complexitylib.Classes.Randomized.GoodSeed public import Complexitylib.Classes.Randomized.CircuitAmplification diff --git a/Complexitylib/Classes/PCP.lean b/Complexitylib/Classes/PCP.lean new file mode 100644 index 00000000..644a4351 --- /dev/null +++ b/Complexitylib/Classes/PCP.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.EventProb +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.P.Cobham.Internal.ConsBit +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.Vec +public import Complexitylib.Classes.P.Preimage +public import Complexitylib.Circuits.BitString +public import Complexitylib.Encoding.DataEncode + +/-! +# Probabilistically checkable proofs: `PCP[r(n), q(n)]` + +⚠️ Unreviewed by Bolton + +`PCP r q` is the class of languages with a probabilistically checkable proof +system: a polynomial-time verifier that, on an input of length `n`, flips +`r n` coins, reads at most `q n` bits of a proof string, always accepts a +correct proof of a member, and rejects every purported proof of a non-member +with probability at least `1/2`. This is the class `PCP[r(n), q(n)]` of +Arora–Barak, Definition 11.5, and of +: "the class of problems for +which a probabilistically checkable proof of a solution can be given, such that +the proof can be checked in polynomial time using `r(n)` bits of randomness and +by reading `q(n)` bits of the proof, correct proofs are always accepted, and +incorrect proofs are rejected with probability at least `1/2`." + +As in `Complexitylib.Classes.Interactive`, the verifier is machine-free: its +two computations are a query-selection function in `FP` and a verdict language +in `P`, both applied to encoded tuples. The verifier is *non-adaptive* — the +positions it reads are a function of the input and the coins alone, not of +earlier answers — which is the standard choice (Arora–Barak, Definition 11.5) +and costs only a `2^q` blow-up in query count against the adaptive variant. + +## Main definitions + +- `PCPVerifier` — query positions as an `FP`-computable function of the encoded + input and coins, and a verdict in `P` on the input, the coins, and the bits + read +- `PCPVerifier.Accepts`, `PCPVerifier.acceptEvent` +- `PCP` — the class `PCP[r(n), q(n)]` + +## Main results + +- `PCP_mono` — more coins or more queries only enlarge the class +- `P_subset_PCP` — the definition contains `P` for every `r` and `q`: the + verifier reads nothing and ignores its coins + +## Conventions + +The verifier uses *exactly* `r n` coins, never fewer: a verifier wanting fewer +can ignore the surplus, so this loses nothing, and it keeps the coin count a +parameter of the class rather than a field the verifier could smuggle +non-uniform information into. The query count is an upper bound `≤ q n` since +the position list is produced by the `FP` function and carries no hidden +information. + +The proof is a finite string; a position beyond its end reads as `false`. This +is no restriction, as the verifier's positions are polynomially many bits long, +so a proof of length `q n · 2 ^ r n` suffices, matching the usual convention. + +Completeness `1` and soundness `1/2` are hard-wired, following the +`PCP[r, q]` convention rather than the `2/3`–`1/3` of +`Complexitylib.Classes.Randomized`. + +## TODO + +- Prove the PCP theorem. +-/ + +@[expose] public section + +namespace Complexity + +/-! ## Verifiers -/ + +/-- A (non-adaptive) PCP verifier: from the encoded input and coins it computes +a list of proof positions in polynomial time, and from the input, the coins, and +the bits found there it decides in polynomial time. -/ +structure PCPVerifier where + /-- The proof positions queried on input `x` with coins `r`. -/ + positions : List Bool → List Bool → List ℕ + /-- That computation is polynomial-time, as a function of `pair x r` producing + the `DataEncode` bitstring of the position list. -/ + positions_mem : ∃ f ∈ FP, ∀ x r : List Bool, + f (pair x r) = DataEncode.bitstringEncode (positions x r) + /-- The verdict, on `pair (pair x r) a` where `a` lists the bits read. -/ + verdict : Language + /-- That verdict is polynomial-time decidable. -/ + verdict_mem : verdict ∈ P + +namespace PCPVerifier + +/-- The bits of the proof `π` at the listed positions; a position past the end +of the proof reads as `false`. -/ +def answers (π : List Bool) (ps : List ℕ) : List Bool := + ps.map fun i => π.getD i false + +/-- The verifier accepts input `x` and proof `π` with coins `r`. -/ +def Accepts (V : PCPVerifier) (x π r : List Bool) : Prop := + pair (pair x r) (answers π (V.positions x r)) ∈ V.verdict + +open Classical in +/-- The coin strings of length `t` on which `V` accepts `x` with proof `π`. -/ +noncomputable def acceptEvent (V : PCPVerifier) (t : ℕ) (x π : List Bool) : + Finset (Fin t → Bool) := + Finset.univ.filter fun r => V.Accepts x π (BitString.toList r) + +/-- The verifier reads at most `q n` bits of the proof on inputs of length `n`, +whatever its coins. -/ +def QueryBounded (V : PCPVerifier) (q : ℕ → ℕ) : Prop := + ∀ x r : List Bool, (V.positions x r).length ≤ q x.length + +end PCPVerifier + +/-! ## The class -/ + +/-- **`PCP[r(n), q(n)]`**: languages with a polynomial-time verifier using `r n` +random bits and reading at most `q n` bits of the proof, such that a member has +a proof the verifier always accepts, while every proof of a non-member is +rejected with probability at least `1/2`. -/ +def PCP (r q : ℕ → ℕ) : Set Language := + {L | ∃ V : PCPVerifier, V.QueryBounded q ∧ + (∀ x ∈ L, ∃ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) = 1) ∧ + (∀ x ∉ L, ∀ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) ≤ 1 / 2)} + +/-! ## Elementary properties -/ + +/-- Every constant string function is polynomial-time. -/ +private theorem const_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := by + induction c with + | nil => exact Cobham.const_nil_mem_FP + | cons b c ih => + have := mem_FP_comp ih (Cobham.cons_mem_FP b) + simpa [Function.comp] using this + +/-- The verifier that reads no bits of the proof, ignores its coins, and +decides `L` on the input it recovers from the encoded view. -/ +private noncomputable def inputVerifier (L : Language) (hL : L ∈ P) : PCPVerifier where + positions _ _ := [] + positions_mem := + ⟨fun _ => DataEncode.bitstringEncode ([] : List ℕ), + const_mem_FP _, fun _ _ => rfl⟩ + verdict := (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L + verdict_mem := by + refine mem_P_preimage ?_ hL + exact mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +/-- **`P ⊆ PCP[r, q]`** for every `r` and `q`: the verifier never looks at the +proof or its coins. -/ +theorem P_subset_PCP (r q : ℕ → ℕ) : P ⊆ PCP r q := by + intro L hL + refine ⟨inputVerifier L hL, fun _ _ => by simp [inputVerifier], ?_, ?_⟩ + · intro x hx + refine ⟨[], ?_⟩ + have hev : (inputVerifier L hL).acceptEvent (r x.length) x [] = Finset.univ := by + ext ρ + simp [PCPVerifier.acceptEvent, PCPVerifier.Accepts, inputVerifier, hx] + rw [hev, eventProb_univ] + · intro x hx π + have hev : (inputVerifier L hL).acceptEvent (r x.length) x π = ∅ := by + ext ρ + simp [PCPVerifier.acceptEvent, PCPVerifier.Accepts, inputVerifier, hx] + rw [hev, eventProb_empty] + norm_num + +/-- More queries only enlarge the class. -/ +theorem PCP_mono_queries {r q q' : ℕ → ℕ} (hq : ∀ n, q n ≤ q' n) : + PCP r q ⊆ PCP r q' := by + rintro L ⟨V, hV, hc, hs⟩ + exact ⟨V, fun x ρ => (hV x ρ).trans (hq _), hc, hs⟩ + +end Complexity From e4384e2a6d85895960f0e350123a7cdbe735a5d2 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Sun, 23 Aug 2026 21:38:42 -0700 Subject: [PATCH 18/24] claude theorem draft --- Complexitylib/Classes/PCP.lean | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/Complexitylib/Classes/PCP.lean b/Complexitylib/Classes/PCP.lean index 644a4351..e9502470 100644 --- a/Complexitylib/Classes/PCP.lean +++ b/Complexitylib/Classes/PCP.lean @@ -5,6 +5,7 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.EventProb +public import Complexitylib.Classes.NP public import Complexitylib.Classes.P.Composition public import Complexitylib.Classes.P.Cobham.Internal.ConsBit public import Complexitylib.Classes.P.Cobham.Internal.FstBlock @@ -50,6 +51,7 @@ and costs only a `2^q` blow-up in query count against the adaptive variant. - `PCP_mono` — more coins or more queries only enlarge the class - `P_subset_PCP` — the definition contains `P` for every `r` and `q`: the verifier reads nothing and ignores its coins +- `PCP_theorem` — the statement `NP = PCP[O(log n), O(1)]`, currently `sorry` ## Conventions @@ -175,4 +177,14 @@ theorem PCP_mono_queries {r q q' : ℕ → ℕ} (hq : ∀ n, q n ≤ q' n) : rintro L ⟨V, hV, hc, hs⟩ exact ⟨V, fun x ρ => (hV x ρ).trans (hq _), hc, hs⟩ +/-! ## The PCP theorem -/ + +/-- **The PCP theorem**, as stated on +: `NP = PCP[O(log n), O(1)]`. The +big-O classes are unions over all functions `r =O log` and `q =O 1` in the +library's `BigO` (eventual domination up to a constant). -/ +theorem PCP_theorem : + NP = ⋃ (r : ℕ → ℕ) (_ : r =O Nat.log 2) (q : ℕ → ℕ) (_ : q =O fun _ => 1), PCP r q := by + sorry + end Complexity From 603ff39b06a2ba1ca8216e9a87c8a397b707b8d4 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Fri, 28 Aug 2026 19:15:27 -0700 Subject: [PATCH 19/24] claude: "The PCP theorem is proved." --- Complexitylib/Classes/PCP.lean | 188 +-- Complexitylib/Classes/PCP/Defs.lean | 197 +++ Complexitylib/Classes/PCP/Internal.lean | 108 ++ .../Classes/PCP/Internal/AlgCSPModel.lean | 319 +++++ .../Classes/PCP/Internal/AlgCompose.lean | 104 ++ .../Classes/PCP/Internal/AlgEdge.lean | 443 ++++++ .../Classes/PCP/Internal/AlgFamily.lean | 254 ++++ .../Classes/PCP/Internal/AlgFormula.lean | 93 ++ .../Classes/PCP/Internal/AlgGap.lean | 164 +++ .../Classes/PCP/Internal/AlgGapAll.lean | 189 +++ .../Classes/PCP/Internal/AlgGapCSP.lean | 196 +++ .../Classes/PCP/Internal/AlgGraph.lean | 226 +++ .../Classes/PCP/Internal/AlgInit.lean | 280 ++++ .../Classes/PCP/Internal/AlgIter.lean | 66 + .../Classes/PCP/Internal/AlgKey.lean | 244 ++++ .../Classes/PCP/Internal/AlgKeyFn.lean | 672 +++++++++ .../Classes/PCP/Internal/AlgKilled.lean | 542 ++++++++ .../Classes/PCP/Internal/AlgLevel.lean | 316 +++++ .../Classes/PCP/Internal/AlgLog.lean | 239 ++++ .../Classes/PCP/Internal/AlgPCP.lean | 207 +++ .../Classes/PCP/Internal/AlgPosNum.lean | 303 ++++ .../Classes/PCP/Internal/AlgPreRel.lean | 204 +++ .../Classes/PCP/Internal/AlgPreRot.lean | 797 +++++++++++ .../Classes/PCP/Internal/AlgPreprocess.lean | 257 ++++ .../Classes/PCP/Internal/AlgRound.lean | 177 +++ .../Classes/PCP/Internal/AlgStep.lean | 275 ++++ .../Classes/PCP/Internal/AlgUniform.lean | 131 ++ .../Classes/PCP/Internal/AlgWalk.lean | 208 +++ .../Classes/PCP/Internal/AlphabetLift.lean | 99 ++ .../Classes/PCP/Internal/Amplification.lean | 186 +++ .../Classes/PCP/Internal/Arithmetize.lean | 359 +++++ .../Classes/PCP/Internal/BaseAlg.lean | 483 +++++++ .../Classes/PCP/Internal/BinToUnary.lean | 121 ++ .../Classes/PCP/Internal/BitwiseFP.lean | 124 ++ .../PCP/Internal/BoundNotConstructible.lean | 148 ++ .../Classes/PCP/Internal/BoundedQuant.lean | 86 ++ .../Classes/PCP/Internal/CNFCount.lean | 202 +++ .../Classes/PCP/Internal/CNFMaxVar.lean | 159 +++ .../Classes/PCP/Internal/CNFSegment.lean | 407 ++++++ .../Classes/PCP/Internal/CNFTokens.lean | 319 +++++ .../Classes/PCP/Internal/CSPVerifier.lean | 509 +++++++ .../Classes/PCP/Internal/Cheeger.lean | 584 ++++++++ .../Classes/PCP/Internal/Clique.lean | 90 ++ .../Classes/PCP/Internal/CloudCount.lean | 109 ++ .../PCP/Internal/CloudDisagreement.lean | 316 +++++ .../Classes/PCP/Internal/CoinEnum.lean | 148 ++ .../Classes/PCP/Internal/Compose.lean | 416 ++++++ .../Classes/PCP/Internal/ConsistencyLang.lean | 473 +++++++ .../Classes/PCP/Internal/ConstraintGraph.lean | 234 ++++ .../Classes/PCP/Internal/CubeBlocks.lean | 368 +++++ .../Classes/PCP/Internal/DartCorrelation.lean | 540 +++++++ .../Classes/PCP/Internal/DataScan.lean | 350 +++++ .../Classes/PCP/Internal/DataScanSpec.lean | 207 +++ .../Classes/PCP/Internal/DegreeReduction.lean | 314 +++++ .../PCP/Internal/DegreeReductionSound.lean | 295 ++++ Complexitylib/Classes/PCP/Internal/Dinur.lean | 363 +++++ .../Classes/PCP/Internal/Disagreement.lean | 133 ++ .../Classes/PCP/Internal/EdgeExpansion.lean | 144 ++ .../Classes/PCP/Internal/Expander.lean | 151 ++ .../PCP/Internal/ExpanderAssemble.lean | 290 ++++ .../Classes/PCP/Internal/ExpanderExists.lean | 112 ++ .../Classes/PCP/Internal/ExpanderMerge.lean | 470 +++++++ .../Classes/PCP/Internal/ExpanderPad.lean | 278 ++++ .../Classes/PCP/Internal/ExpanderRandom.lean | 219 +++ .../Classes/PCP/Internal/ExpanderizeCSP.lean | 181 +++ .../Classes/PCP/Internal/FamilyFin.lean | 401 ++++++ .../Classes/PCP/Internal/FiniteKey.lean | 106 ++ .../Classes/PCP/Internal/FinsetPlurality.lean | 55 + .../Classes/PCP/Internal/GapReduction.lean | 73 + .../Classes/PCP/Internal/GapTheorem.lean | 118 ++ .../PCP/Internal/GuessVerifyGeneric.lean | 162 +++ .../Classes/PCP/Internal/Hadamard.lean | 769 ++++++++++ .../Classes/PCP/Internal/HadamardTester.lean | 363 +++++ .../Classes/PCP/Internal/KilledCSP.lean | 229 +++ .../PCP/Internal/KilledFirstMoment.lean | 1235 +++++++++++++++++ .../Classes/PCP/Internal/KilledPlurality.lean | 290 ++++ .../Classes/PCP/Internal/KilledWalk.lean | 404 ++++++ .../Classes/PCP/Internal/LengthMod.lean | 129 ++ .../Classes/PCP/Internal/ListEncode.lean | 166 +++ .../Classes/PCP/Internal/LocalTest.lean | 298 ++++ .../Classes/PCP/Internal/Margulis.lean | 80 ++ .../Classes/PCP/Internal/Materialize.lean | 281 ++++ .../Classes/PCP/Internal/MaxLoop.lean | 188 +++ .../Classes/PCP/Internal/MergeGen.lean | 486 +++++++ .../Classes/PCP/Internal/Mixing.lean | 191 +++ .../Classes/PCP/Internal/NatEncode.lean | 200 +++ .../Classes/PCP/Internal/NumEnc.lean | 350 +++++ .../Classes/PCP/Internal/NumEncPi.lean | 176 +++ .../Classes/PCP/Internal/PCPtoSAT.lean | 373 +++++ Complexitylib/Classes/PCP/Internal/Pad.lean | 111 ++ .../Classes/PCP/Internal/PadCSP.lean | 163 +++ .../Classes/PCP/Internal/PadGraph.lean | 121 ++ .../Classes/PCP/Internal/PadVerts.lean | 90 ++ .../Classes/PCP/Internal/PermArith.lean | 256 ++++ .../Classes/PCP/Internal/PermCount.lean | 213 +++ .../Classes/PCP/Internal/PermGraph.lean | 150 ++ .../Classes/PCP/Internal/Plurality.lean | 129 ++ .../Classes/PCP/Internal/PosScan.lean | 140 ++ .../Classes/PCP/Internal/PositionsFP.lean | 113 ++ Complexitylib/Classes/PCP/Internal/Power.lean | 201 +++ .../Classes/PCP/Internal/PowerCSP.lean | 244 ++++ .../Classes/PCP/Internal/PoweringBound.lean | 433 ++++++ .../Classes/PCP/Internal/Preprocess.lean | 203 +++ .../Classes/PCP/Internal/RankCount.lean | 131 ++ .../Classes/PCP/Internal/RegCSP.lean | 206 +++ .../Classes/PCP/Internal/RegularGraph.lean | 275 ++++ .../Classes/PCP/Internal/SecondMoment.lean | 97 ++ .../Classes/PCP/Internal/SelfLoops.lean | 198 +++ .../Classes/PCP/Internal/SizedExpander.lean | 137 ++ .../PCP/Internal/SizedExpanderize.lean | 121 ++ .../Classes/PCP/Internal/SquareVerifier.lean | 352 +++++ .../Classes/PCP/Internal/StripTrailing.lean | 168 +++ .../Classes/PCP/Internal/SubsetNP.lean | 388 ++++++ .../Classes/PCP/Internal/SubsetNPFinal.lean | 154 ++ .../Classes/PCP/Internal/SymbolCodec.lean | 61 + .../Classes/PCP/Internal/TesterChecks.lean | 237 ++++ .../Classes/PCP/Internal/TesterCore.lean | 294 ++++ .../Classes/PCP/Internal/TesterInput.lean | 222 +++ .../PCP/Internal/ThreeSATReduction.lean | 276 ++++ .../Classes/PCP/Internal/TowerFamily.lean | 281 ++++ .../Classes/PCP/Internal/TowerFin.lean | 497 +++++++ .../Classes/PCP/Internal/TowerTable.lean | 327 +++++ .../Classes/PCP/Internal/UnaryDivMod.lean | 267 ++++ .../Classes/PCP/Internal/UnaryExp.lean | 113 ++ .../Classes/PCP/Internal/UnaryList.lean | 417 ++++++ Complexitylib/Classes/PCP/Internal/Union.lean | 220 +++ .../Classes/PCP/Internal/VerifierLang.lean | 267 ++++ Complexitylib/Classes/PCP/Internal/Walk.lean | 108 ++ .../Classes/PCP/Internal/WalkDart.lean | 336 +++++ .../Classes/PCP/Internal/WalkPath.lean | 230 +++ .../Classes/PCP/Internal/WalkSplit.lean | 325 +++++ .../Classes/PCP/Internal/ZigZag.lean | 914 ++++++++++++ .../PCP/Internal/ZigZagBaseExists.lean | 100 ++ .../Classes/PCP/Internal/ZigZagTower.lean | 169 +++ scripts/AxiomGuard.lean | 4 + 135 files changed, 34805 insertions(+), 163 deletions(-) create mode 100644 Complexitylib/Classes/PCP/Defs.lean create mode 100644 Complexitylib/Classes/PCP/Internal.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgCSPModel.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgCompose.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgEdge.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgFamily.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgFormula.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgGap.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgGapAll.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgGraph.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgInit.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgIter.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgKey.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgKilled.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgLevel.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgLog.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgPCP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgPosNum.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgPreRel.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgPreRot.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgRound.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgStep.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgUniform.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlgWalk.lean create mode 100644 Complexitylib/Classes/PCP/Internal/AlphabetLift.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Amplification.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Arithmetize.lean create mode 100644 Complexitylib/Classes/PCP/Internal/BaseAlg.lean create mode 100644 Complexitylib/Classes/PCP/Internal/BinToUnary.lean create mode 100644 Complexitylib/Classes/PCP/Internal/BitwiseFP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/BoundNotConstructible.lean create mode 100644 Complexitylib/Classes/PCP/Internal/BoundedQuant.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CNFCount.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CNFSegment.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CNFTokens.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CSPVerifier.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Cheeger.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Clique.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CloudCount.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CoinEnum.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Compose.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean create mode 100644 Complexitylib/Classes/PCP/Internal/CubeBlocks.lean create mode 100644 Complexitylib/Classes/PCP/Internal/DartCorrelation.lean create mode 100644 Complexitylib/Classes/PCP/Internal/DataScan.lean create mode 100644 Complexitylib/Classes/PCP/Internal/DataScanSpec.lean create mode 100644 Complexitylib/Classes/PCP/Internal/DegreeReduction.lean create mode 100644 Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Dinur.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Disagreement.lean create mode 100644 Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Expander.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderExists.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderPad.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/FamilyFin.lean create mode 100644 Complexitylib/Classes/PCP/Internal/FiniteKey.lean create mode 100644 Complexitylib/Classes/PCP/Internal/FinsetPlurality.lean create mode 100644 Complexitylib/Classes/PCP/Internal/GapReduction.lean create mode 100644 Complexitylib/Classes/PCP/Internal/GapTheorem.lean create mode 100644 Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Hadamard.lean create mode 100644 Complexitylib/Classes/PCP/Internal/HadamardTester.lean create mode 100644 Complexitylib/Classes/PCP/Internal/KilledCSP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean create mode 100644 Complexitylib/Classes/PCP/Internal/KilledPlurality.lean create mode 100644 Complexitylib/Classes/PCP/Internal/KilledWalk.lean create mode 100644 Complexitylib/Classes/PCP/Internal/LengthMod.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ListEncode.lean create mode 100644 Complexitylib/Classes/PCP/Internal/LocalTest.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Margulis.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Materialize.lean create mode 100644 Complexitylib/Classes/PCP/Internal/MaxLoop.lean create mode 100644 Complexitylib/Classes/PCP/Internal/MergeGen.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Mixing.lean create mode 100644 Complexitylib/Classes/PCP/Internal/NatEncode.lean create mode 100644 Complexitylib/Classes/PCP/Internal/NumEnc.lean create mode 100644 Complexitylib/Classes/PCP/Internal/NumEncPi.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Pad.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PadCSP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PadGraph.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PadVerts.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PermArith.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PermCount.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PermGraph.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Plurality.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PosScan.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PositionsFP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Power.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PowerCSP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/PoweringBound.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Preprocess.lean create mode 100644 Complexitylib/Classes/PCP/Internal/RankCount.lean create mode 100644 Complexitylib/Classes/PCP/Internal/RegCSP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/RegularGraph.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SecondMoment.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SelfLoops.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SizedExpander.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SquareVerifier.lean create mode 100644 Complexitylib/Classes/PCP/Internal/StripTrailing.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SubsetNP.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean create mode 100644 Complexitylib/Classes/PCP/Internal/SymbolCodec.lean create mode 100644 Complexitylib/Classes/PCP/Internal/TesterChecks.lean create mode 100644 Complexitylib/Classes/PCP/Internal/TesterCore.lean create mode 100644 Complexitylib/Classes/PCP/Internal/TesterInput.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean create mode 100644 Complexitylib/Classes/PCP/Internal/TowerFamily.lean create mode 100644 Complexitylib/Classes/PCP/Internal/TowerFin.lean create mode 100644 Complexitylib/Classes/PCP/Internal/TowerTable.lean create mode 100644 Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean create mode 100644 Complexitylib/Classes/PCP/Internal/UnaryExp.lean create mode 100644 Complexitylib/Classes/PCP/Internal/UnaryList.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Union.lean create mode 100644 Complexitylib/Classes/PCP/Internal/VerifierLang.lean create mode 100644 Complexitylib/Classes/PCP/Internal/Walk.lean create mode 100644 Complexitylib/Classes/PCP/Internal/WalkDart.lean create mode 100644 Complexitylib/Classes/PCP/Internal/WalkPath.lean create mode 100644 Complexitylib/Classes/PCP/Internal/WalkSplit.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ZigZag.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean create mode 100644 Complexitylib/Classes/PCP/Internal/ZigZagTower.lean diff --git a/Complexitylib/Classes/PCP.lean b/Complexitylib/Classes/PCP.lean index e9502470..8217d5e9 100644 --- a/Complexitylib/Classes/PCP.lean +++ b/Complexitylib/Classes/PCP.lean @@ -4,187 +4,49 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Bolton Bailey -/ module -public import Complexitylib.Classes.EventProb -public import Complexitylib.Classes.NP -public import Complexitylib.Classes.P.Composition -public import Complexitylib.Classes.P.Cobham.Internal.ConsBit -public import Complexitylib.Classes.P.Cobham.Internal.FstBlock -public import Complexitylib.Classes.P.Cobham.Internal.Vec -public import Complexitylib.Classes.P.Preimage -public import Complexitylib.Circuits.BitString -public import Complexitylib.Encoding.DataEncode +public import Complexitylib.Classes.PCP.Defs +public import Complexitylib.Classes.PCP.Internal.AlgPCP +public import Complexitylib.Classes.PCP.Internal.SubsetNPFinal /-! -# Probabilistically checkable proofs: `PCP[r(n), q(n)]` +# The PCP theorem -⚠️ Unreviewed by Bolton +`PCP r q` and its verifiers are defined in `Complexitylib.Classes.PCP.Defs`; +this file states and proves the theorem itself. -`PCP r q` is the class of languages with a probabilistically checkable proof -system: a polynomial-time verifier that, on an input of length `n`, flips -`r n` coins, reads at most `q n` bits of a proof string, always accepts a -correct proof of a member, and rejects every purported proof of a non-member -with probability at least `1/2`. This is the class `PCP[r(n), q(n)]` of -Arora–Barak, Definition 11.5, and of -: "the class of problems for -which a probabilistically checkable proof of a solution can be given, such that -the proof can be checked in polynomial time using `r(n)` bits of randomness and -by reading `q(n)` bits of the proof, correct proofs are always accepted, and -incorrect proofs are rejected with probability at least `1/2`." - -As in `Complexitylib.Classes.Interactive`, the verifier is machine-free: its -two computations are a query-selection function in `FP` and a verdict language -in `P`, both applied to encoded tuples. The verifier is *non-adaptive* — the -positions it reads are a function of the input and the coins alone, not of -earlier answers — which is the standard choice (Arora–Barak, Definition 11.5) -and costs only a `2^q` blow-up in query count against the adaptive variant. - -## Main definitions - -- `PCPVerifier` — query positions as an `FP`-computable function of the encoded - input and coins, and a verdict in `P` on the input, the coins, and the bits - read -- `PCPVerifier.Accepts`, `PCPVerifier.acceptEvent` -- `PCP` — the class `PCP[r(n), q(n)]` +Both inclusions are hard work. `NP ⊆ PCP[O(log n), O(1)]` is Dinur's gap +amplification, carried out by the modules under `PCP/Internal`: a formula +becomes a constraint graph, the graph is amplified logarithmically many times +until its unsatisfiability value is a constant, and a verifier reads one edge of +the result. `PCP[O(log n), O(1)] ⊆ NP` guesses the whole proof table. ## Main results -- `PCP_mono` — more coins or more queries only enlarge the class -- `P_subset_PCP` — the definition contains `P` for every `r` and `q`: the - verifier reads nothing and ignores its coins -- `PCP_theorem` — the statement `NP = PCP[O(log n), O(1)]`, currently `sorry` - -## Conventions - -The verifier uses *exactly* `r n` coins, never fewer: a verifier wanting fewer -can ignore the surplus, so this loses nothing, and it keeps the coin count a -parameter of the class rather than a field the verifier could smuggle -non-uniform information into. The query count is an upper bound `≤ q n` since -the position list is produced by the `FP` function and carries no hidden -information. - -The proof is a finite string; a position beyond its end reads as `false`. This -is no restriction, as the verifier's positions are polynomially many bits long, -so a proof of length `q n · 2 ^ r n` suffices, matching the usual convention. - -Completeness `1` and soundness `1/2` are hard-wired, following the -`PCP[r, q]` convention rather than the `2/3`–`1/3` of -`Complexitylib.Classes.Randomized`. - -## TODO - -- Prove the PCP theorem. +- `Complexity.PCP_theorem` — `NP = PCP[O(log n), O(1)]` -/ @[expose] public section namespace Complexity -/-! ## Verifiers -/ - -/-- A (non-adaptive) PCP verifier: from the encoded input and coins it computes -a list of proof positions in polynomial time, and from the input, the coins, and -the bits found there it decides in polynomial time. -/ -structure PCPVerifier where - /-- The proof positions queried on input `x` with coins `r`. -/ - positions : List Bool → List Bool → List ℕ - /-- That computation is polynomial-time, as a function of `pair x r` producing - the `DataEncode` bitstring of the position list. -/ - positions_mem : ∃ f ∈ FP, ∀ x r : List Bool, - f (pair x r) = DataEncode.bitstringEncode (positions x r) - /-- The verdict, on `pair (pair x r) a` where `a` lists the bits read. -/ - verdict : Language - /-- That verdict is polynomial-time decidable. -/ - verdict_mem : verdict ∈ P - -namespace PCPVerifier - -/-- The bits of the proof `π` at the listed positions; a position past the end -of the proof reads as `false`. -/ -def answers (π : List Bool) (ps : List ℕ) : List Bool := - ps.map fun i => π.getD i false - -/-- The verifier accepts input `x` and proof `π` with coins `r`. -/ -def Accepts (V : PCPVerifier) (x π r : List Bool) : Prop := - pair (pair x r) (answers π (V.positions x r)) ∈ V.verdict - -open Classical in -/-- The coin strings of length `t` on which `V` accepts `x` with proof `π`. -/ -noncomputable def acceptEvent (V : PCPVerifier) (t : ℕ) (x π : List Bool) : - Finset (Fin t → Bool) := - Finset.univ.filter fun r => V.Accepts x π (BitString.toList r) - -/-- The verifier reads at most `q n` bits of the proof on inputs of length `n`, -whatever its coins. -/ -def QueryBounded (V : PCPVerifier) (q : ℕ → ℕ) : Prop := - ∀ x r : List Bool, (V.positions x r).length ≤ q x.length - -end PCPVerifier - -/-! ## The class -/ - -/-- **`PCP[r(n), q(n)]`**: languages with a polynomial-time verifier using `r n` -random bits and reading at most `q n` bits of the proof, such that a member has -a proof the verifier always accepts, while every proof of a non-member is -rejected with probability at least `1/2`. -/ -def PCP (r q : ℕ → ℕ) : Set Language := - {L | ∃ V : PCPVerifier, V.QueryBounded q ∧ - (∀ x ∈ L, ∃ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) = 1) ∧ - (∀ x ∉ L, ∀ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) ≤ 1 / 2)} - -/-! ## Elementary properties -/ - -/-- Every constant string function is polynomial-time. -/ -private theorem const_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := by - induction c with - | nil => exact Cobham.const_nil_mem_FP - | cons b c ih => - have := mem_FP_comp ih (Cobham.cons_mem_FP b) - simpa [Function.comp] using this - -/-- The verifier that reads no bits of the proof, ignores its coins, and -decides `L` on the input it recovers from the encoded view. -/ -private noncomputable def inputVerifier (L : Language) (hL : L ∈ P) : PCPVerifier where - positions _ _ := [] - positions_mem := - ⟨fun _ => DataEncode.bitstringEncode ([] : List ℕ), - const_mem_FP _, fun _ _ => rfl⟩ - verdict := (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L - verdict_mem := by - refine mem_P_preimage ?_ hL - exact mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - -/-- **`P ⊆ PCP[r, q]`** for every `r` and `q`: the verifier never looks at the -proof or its coins. -/ -theorem P_subset_PCP (r q : ℕ → ℕ) : P ⊆ PCP r q := by - intro L hL - refine ⟨inputVerifier L hL, fun _ _ => by simp [inputVerifier], ?_, ?_⟩ - · intro x hx - refine ⟨[], ?_⟩ - have hev : (inputVerifier L hL).acceptEvent (r x.length) x [] = Finset.univ := by - ext ρ - simp [PCPVerifier.acceptEvent, PCPVerifier.Accepts, inputVerifier, hx] - rw [hev, eventProb_univ] - · intro x hx π - have hev : (inputVerifier L hL).acceptEvent (r x.length) x π = ∅ := by - ext ρ - simp [PCPVerifier.acceptEvent, PCPVerifier.Accepts, inputVerifier, hx] - rw [hev, eventProb_empty] - norm_num - -/-- More queries only enlarge the class. -/ -theorem PCP_mono_queries {r q q' : ℕ → ℕ} (hq : ∀ n, q n ≤ q' n) : - PCP r q ⊆ PCP r q' := by - rintro L ⟨V, hV, hc, hs⟩ - exact ⟨V, fun x ρ => (hV x ρ).trans (hq _), hc, hs⟩ - /-! ## The PCP theorem -/ /-- **The PCP theorem**, as stated on : `NP = PCP[O(log n), O(1)]`. The big-O classes are unions over all functions `r =O log` and `q =O 1` in the -library's `BigO` (eventual domination up to a constant). -/ +library's `BigO` (eventual domination up to a constant), with the randomness +bound required to be `Constructible` — see that definition for why the +requirement cannot be dropped. -/ theorem PCP_theorem : - NP = ⋃ (r : ℕ → ℕ) (_ : r =O Nat.log 2) (q : ℕ → ℕ) (_ : q =O fun _ => 1), PCP r q := by - sorry + NP = ⋃ (r : ℕ → ℕ) (_ : r =O Nat.log 2) (_ : Constructible r) + (q : ℕ → ℕ) (_ : q =O fun _ => 1), PCP r q := by + ext L + simp only [Set.mem_iUnion] + constructor + · intro hL + obtain ⟨r, qc, hrlog, hrc, hq1, hmem⟩ := exists_pcp_of_mem_NP hL + exact ⟨r, hrlog, hrc, qc, hq1, hmem⟩ + · rintro ⟨r, hrlog, hrc, qc, hq1, hmem⟩ + exact PCP_subset_NP hrc hrlog hq1 hmem end Complexity diff --git a/Complexitylib/Classes/PCP/Defs.lean b/Complexitylib/Classes/PCP/Defs.lean new file mode 100644 index 00000000..99c93608 --- /dev/null +++ b/Complexitylib/Classes/PCP/Defs.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.EventProb +public import Complexitylib.Classes.NP +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.P.Cobham.Internal.ConsBit +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.Vec +public import Complexitylib.Classes.P.Preimage +public import Complexitylib.Circuits.BitString +public import Complexitylib.Encoding.DataEncode + +/-! +# Probabilistically checkable proofs: definitions + +⚠️ Unreviewed by Bolton + +`PCP r q` is the class of languages with a probabilistically checkable proof +system: a polynomial-time verifier that, on an input of length `n`, flips +`r n` coins, reads at most `q n` bits of a proof string, always accepts a +correct proof of a member, and rejects every purported proof of a non-member +with probability at least `1/2`. This is the class `PCP[r(n), q(n)]` of +Arora–Barak, Definition 11.5, and of +: "the class of problems for +which a probabilistically checkable proof of a solution can be given, such that +the proof can be checked in polynomial time using `r(n)` bits of randomness and +by reading `q(n)` bits of the proof, correct proofs are always accepted, and +incorrect proofs are rejected with probability at least `1/2`." + +As in `Complexitylib.Classes.Interactive`, the verifier is machine-free: its +two computations are a query-selection function in `FP` and a verdict language +in `P`, both applied to encoded tuples. The verifier is *non-adaptive* — the +positions it reads are a function of the input and the coins alone, not of +earlier answers — which is the standard choice (Arora–Barak, Definition 11.5) +and costs only a `2^q` blow-up in query count against the adaptive variant. + +## Main definitions + +- `PCPVerifier` — query positions as an `FP`-computable function of the encoded + input and coins, and a verdict in `P` on the input, the coins, and the bits + read +- `PCPVerifier.Accepts`, `PCPVerifier.acceptEvent` +- `PCP` — the class `PCP[r(n), q(n)]` + +## Main results + +- `PCP_mono` — more coins or more queries only enlarge the class +- `P_subset_PCP` — the definition contains `P` for every `r` and `q`: the + verifier reads nothing and ignores its coins +- `Constructible` — a resource bound that can be written out in unary + +## Conventions + +The verifier uses *exactly* `r n` coins, never fewer: a verifier wanting fewer +can ignore the surplus, so this loses nothing, and it keeps the coin count a +parameter of the class rather than a field the verifier could smuggle +non-uniform information into. The query count is an upper bound `≤ q n` since +the position list is produced by the `FP` function and carries no hidden +information. + +The proof is a finite string; a position beyond its end reads as `false`. This +is no restriction, as the verifier's positions are polynomially many bits long, +so a proof of length `q n · 2 ^ r n` suffices, matching the usual convention. + +Completeness `1` and soundness `1/2` are hard-wired, following the +`PCP[r, q]` convention rather than the `2/3`–`1/3` of +`Complexitylib.Classes.Randomized`. + +## TODO + +- Prove the PCP theorem. +-/ + +@[expose] public section + +namespace Complexity + +/-! ## Verifiers -/ + +/-- A (non-adaptive) PCP verifier: from the encoded input and coins it computes +a list of proof positions in polynomial time, and from the input, the coins, and +the bits found there it decides in polynomial time. -/ +structure PCPVerifier where + /-- The proof positions queried on input `x` with coins `r`. -/ + positions : List Bool → List Bool → List ℕ + /-- That computation is polynomial-time, as a function of `pair x r` producing + the `DataEncode` bitstring of the position list. -/ + positions_mem : ∃ f ∈ FP, ∀ x r : List Bool, + f (pair x r) = DataEncode.bitstringEncode (positions x r) + /-- The verdict, on `pair (pair x r) a` where `a` lists the bits read. -/ + verdict : Language + /-- That verdict is polynomial-time decidable. -/ + verdict_mem : verdict ∈ P + +namespace PCPVerifier + +/-- The bits of the proof `π` at the listed positions; a position past the end +of the proof reads as `false`. -/ +def answers (π : List Bool) (ps : List ℕ) : List Bool := + ps.map fun i => π.getD i false + +/-- The verifier accepts input `x` and proof `π` with coins `r`. -/ +def Accepts (V : PCPVerifier) (x π r : List Bool) : Prop := + pair (pair x r) (answers π (V.positions x r)) ∈ V.verdict + +open Classical in +/-- The coin strings of length `t` on which `V` accepts `x` with proof `π`. -/ +noncomputable def acceptEvent (V : PCPVerifier) (t : ℕ) (x π : List Bool) : + Finset (Fin t → Bool) := + Finset.univ.filter fun r => V.Accepts x π (BitString.toList r) + +/-- The verifier reads at most `q n` bits of the proof on inputs of length `n`, +whatever its coins. -/ +def QueryBounded (V : PCPVerifier) (q : ℕ → ℕ) : Prop := + ∀ x r : List Bool, (V.positions x r).length ≤ q x.length + +end PCPVerifier + +/-! ## The class -/ + +/-- **`PCP[r(n), q(n)]`**: languages with a polynomial-time verifier using `r n` +random bits and reading at most `q n` bits of the proof, such that a member has +a proof the verifier always accepts, while every proof of a non-member is +rejected with probability at least `1/2`. -/ +def PCP (r q : ℕ → ℕ) : Set Language := + {L | ∃ V : PCPVerifier, V.QueryBounded q ∧ + (∀ x ∈ L, ∃ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) = 1) ∧ + (∀ x ∉ L, ∀ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) ≤ 1 / 2)} + +/-! ## Elementary properties -/ + +/-- Every constant string function is polynomial-time. -/ +private theorem const_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := by + induction c with + | nil => exact Cobham.const_nil_mem_FP + | cons b c ih => + have := mem_FP_comp ih (Cobham.cons_mem_FP b) + simpa [Function.comp] using this + +/-- The verifier that reads no bits of the proof, ignores its coins, and +decides `L` on the input it recovers from the encoded view. -/ +private noncomputable def inputVerifier (L : Language) (hL : L ∈ P) : PCPVerifier where + positions _ _ := [] + positions_mem := + ⟨fun _ => DataEncode.bitstringEncode ([] : List ℕ), + const_mem_FP _, fun _ _ => rfl⟩ + verdict := (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L + verdict_mem := by + refine mem_P_preimage ?_ hL + exact mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +/-- **`P ⊆ PCP[r, q]`** for every `r` and `q`: the verifier never looks at the +proof or its coins. -/ +theorem P_subset_PCP (r q : ℕ → ℕ) : P ⊆ PCP r q := by + intro L hL + refine ⟨inputVerifier L hL, fun _ _ => by simp [inputVerifier], ?_, ?_⟩ + · intro x hx + refine ⟨[], ?_⟩ + have hev : (inputVerifier L hL).acceptEvent (r x.length) x [] = Finset.univ := by + ext ρ + simp [PCPVerifier.acceptEvent, PCPVerifier.Accepts, inputVerifier, hx] + rw [hev, eventProb_univ] + · intro x hx π + have hev : (inputVerifier L hL).acceptEvent (r x.length) x π = ∅ := by + ext ρ + simp [PCPVerifier.acceptEvent, PCPVerifier.Accepts, inputVerifier, hx] + rw [hev, eventProb_empty] + norm_num + +/-- More queries only enlarge the class. -/ +theorem PCP_mono_queries {r q q' : ℕ → ℕ} (hq : ∀ n, q n ≤ q' n) : + PCP r q ⊆ PCP r q' := by + rintro L ⟨V, hV, hc, hs⟩ + exact ⟨V, fun x ρ => (hV x ρ).trans (hq _), hc, hs⟩ + +/-! ## Constructible bounds -/ + +/-- A resource bound is **constructible** when it can be written out in unary in +polynomial time. + +Some such requirement is not optional. `PCP r q` constrains the verifier but says +nothing about `r`, so without it the union below is not a complexity class at +all: `Complexitylib.Classes.PCP.Internal.BoundNotConstructible` proves that for +*every* set `A ⊆ ℕ`, computable or not, the language of inputs whose length lies +in `A` satisfies the `PCP` conditions with `r` the indicator of `A` — a bound +that is `O(1)`, hence `O(log n)`. That puts continuum-many languages in the +union while `NP` is countable, so the unrestricted equation is false. Textbook +statements of the theorem carry the same requirement tacitly, by taking the +bounds to be constructible functions. -/ +def Constructible (r : ℕ → ℕ) : Prop := + (fun x : List Bool => List.replicate (r x.length) true) ∈ FP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal.lean b/Complexitylib/Classes/PCP/Internal.lean new file mode 100644 index 00000000..3de5d284 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgCSPModel +public import Complexitylib.Classes.PCP.Internal.AlphabetLift +public import Complexitylib.Classes.PCP.Internal.Amplification +public import Complexitylib.Classes.PCP.Internal.Arithmetize +public import Complexitylib.Classes.PCP.Internal.BaseAlg +public import Complexitylib.Classes.PCP.Internal.BinToUnary +public import Complexitylib.Classes.PCP.Internal.BitwiseFP +public import Complexitylib.Classes.PCP.Internal.BoundNotConstructible +public import Complexitylib.Classes.PCP.Internal.BoundedQuant +public import Complexitylib.Classes.PCP.Internal.CNFCount +public import Complexitylib.Classes.PCP.Internal.CNFMaxVar +public import Complexitylib.Classes.PCP.Internal.CNFSegment +public import Complexitylib.Classes.PCP.Internal.CNFTokens +public import Complexitylib.Classes.PCP.Internal.CSPVerifier +public import Complexitylib.Classes.PCP.Internal.Cheeger +public import Complexitylib.Classes.PCP.Internal.Clique +public import Complexitylib.Classes.PCP.Internal.CloudDisagreement +public import Complexitylib.Classes.PCP.Internal.CoinEnum +public import Complexitylib.Classes.PCP.Internal.Compose +public import Complexitylib.Classes.PCP.Internal.ConsistencyLang +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph +public import Complexitylib.Classes.PCP.Internal.CubeBlocks +public import Complexitylib.Classes.PCP.Internal.DartCorrelation +public import Complexitylib.Classes.PCP.Internal.DataScan +public import Complexitylib.Classes.PCP.Internal.DataScanSpec +public import Complexitylib.Classes.PCP.Internal.DegreeReduction +public import Complexitylib.Classes.PCP.Internal.DegreeReductionSound +public import Complexitylib.Classes.PCP.Internal.Dinur +public import Complexitylib.Classes.PCP.Internal.Disagreement +public import Complexitylib.Classes.PCP.Internal.EdgeExpansion +public import Complexitylib.Classes.PCP.Internal.Expander +public import Complexitylib.Classes.PCP.Internal.ExpanderAssemble +public import Complexitylib.Classes.PCP.Internal.ExpanderExists +public import Complexitylib.Classes.PCP.Internal.ExpanderMerge +public import Complexitylib.Classes.PCP.Internal.ExpanderPad +public import Complexitylib.Classes.PCP.Internal.ExpanderRandom +public import Complexitylib.Classes.PCP.Internal.ExpanderizeCSP +public import Complexitylib.Classes.PCP.Internal.FiniteKey +public import Complexitylib.Classes.PCP.Internal.FinsetPlurality +public import Complexitylib.Classes.PCP.Internal.GapReduction +public import Complexitylib.Classes.PCP.Internal.GapTheorem +public import Complexitylib.Classes.PCP.Internal.GuessVerifyGeneric +public import Complexitylib.Classes.PCP.Internal.Hadamard +public import Complexitylib.Classes.PCP.Internal.HadamardTester +public import Complexitylib.Classes.PCP.Internal.KilledCSP +public import Complexitylib.Classes.PCP.Internal.KilledFirstMoment +public import Complexitylib.Classes.PCP.Internal.KilledPlurality +public import Complexitylib.Classes.PCP.Internal.KilledWalk +public import Complexitylib.Classes.PCP.Internal.LengthMod +public import Complexitylib.Classes.PCP.Internal.ListEncode +public import Complexitylib.Classes.PCP.Internal.LocalTest +public import Complexitylib.Classes.PCP.Internal.MaxLoop +public import Complexitylib.Classes.PCP.Internal.MergeGen +public import Complexitylib.Classes.PCP.Internal.Mixing +public import Complexitylib.Classes.PCP.Internal.NatEncode +public import Complexitylib.Classes.PCP.Internal.PCPtoSAT +public import Complexitylib.Classes.PCP.Internal.Pad +public import Complexitylib.Classes.PCP.Internal.PadCSP +public import Complexitylib.Classes.PCP.Internal.PadVerts +public import Complexitylib.Classes.PCP.Internal.PermArith +public import Complexitylib.Classes.PCP.Internal.PermCount +public import Complexitylib.Classes.PCP.Internal.PermGraph +public import Complexitylib.Classes.PCP.Internal.Plurality +public import Complexitylib.Classes.PCP.Internal.PosScan +public import Complexitylib.Classes.PCP.Internal.PositionsFP +public import Complexitylib.Classes.PCP.Internal.Power +public import Complexitylib.Classes.PCP.Internal.PowerCSP +public import Complexitylib.Classes.PCP.Internal.PoweringBound +public import Complexitylib.Classes.PCP.Internal.Preprocess +public import Complexitylib.Classes.PCP.Internal.RegCSP +public import Complexitylib.Classes.PCP.Internal.RegularGraph +public import Complexitylib.Classes.PCP.Internal.SecondMoment +public import Complexitylib.Classes.PCP.Internal.SelfLoops +public import Complexitylib.Classes.PCP.Internal.SizedExpander +public import Complexitylib.Classes.PCP.Internal.SizedExpanderize +public import Complexitylib.Classes.PCP.Internal.SquareVerifier +public import Complexitylib.Classes.PCP.Internal.StripTrailing +public import Complexitylib.Classes.PCP.Internal.SubsetNP +public import Complexitylib.Classes.PCP.Internal.SubsetNPFinal +public import Complexitylib.Classes.PCP.Internal.SymbolCodec +public import Complexitylib.Classes.PCP.Internal.TesterChecks +public import Complexitylib.Classes.PCP.Internal.TesterCore +public import Complexitylib.Classes.PCP.Internal.TesterInput +public import Complexitylib.Classes.PCP.Internal.ThreeSATReduction +public import Complexitylib.Classes.PCP.Internal.TowerFamily +public import Complexitylib.Classes.PCP.Internal.UnaryDivMod +public import Complexitylib.Classes.PCP.Internal.UnaryExp +public import Complexitylib.Classes.PCP.Internal.Union +public import Complexitylib.Classes.PCP.Internal.VerifierLang +public import Complexitylib.Classes.PCP.Internal.Walk +public import Complexitylib.Classes.PCP.Internal.WalkDart +public import Complexitylib.Classes.PCP.Internal.WalkPath +public import Complexitylib.Classes.PCP.Internal.WalkSplit +public import Complexitylib.Classes.PCP.Internal.ZigZag +public import Complexitylib.Classes.PCP.Internal.ZigZagTower + +/-! +# Aggregation: the internals of the PCP development + +Every module of Dinur's proof, so that the whole tree is reachable from a single +build target. Aggregation files carry no definitions. +-/ diff --git a/Complexitylib/Classes/PCP/Internal/AlgCSPModel.lean b/Complexitylib/Classes/PCP/Internal/AlgCSPModel.lean new file mode 100644 index 00000000..0cdc9bd5 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgCSPModel.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CSPVerifier +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph + +/-! +# Proofs as assignments + +The proof a PCP verifier reads is an assignment written out: one fixed-width +block per vertex. This module sets up that correspondence — how to cut a proof +into blocks, how to write an assignment as a proof, and that the two are +inverse. + +## Main definitions + +- `Complexity.blockOf` — the block a proof carries at a vertex +- `Complexity.proofOf` — the proof an assignment writes + +## Main results + +- `Complexity.blockOf_proofOf` — reading back what was written +- `Complexity.answers_posVal` — the verifier reads exactly the two endpoint + blocks +- `Complexity.AlgCSP.Models` — an algorithmic graph agrees with a real one +- `Complexity.AlgCSP.Models.sat_of_satisfiable` — completeness transfers +-/ + +@[expose] public section + +namespace Complexity + +/-- The block a proof carries at a vertex, when symbols occupy `w` bits. -/ +def blockOf (w : ℕ) (π : List Bool) (v : ℕ) : List Bool := (π.drop (v * w)).take w + +/-- The proof an assignment writes: the blocks of the first `n` vertices, one +after another. -/ +def proofOf (n : ℕ) (f : ℕ → List Bool) : List Bool := (List.range n).flatMap f + +theorem length_proofOf {w : ℕ} {f : ℕ → List Bool} (hf : ∀ i, (f i).length = w) : + ∀ n, (proofOf n f).length = n * w := by + intro n + induction n with + | zero => simp [proofOf] + | succ n ih => + rw [proofOf, List.range_succ, List.flatMap_append, List.length_append] + rw [proofOf] at ih + rw [ih] + simp [hf n] + ring + +/-- **Reading back what was written.** -/ +theorem blockOf_proofOf {w : ℕ} {f : ℕ → List Bool} (hf : ∀ i, (f i).length = w) : + ∀ (n v : ℕ), v < n → blockOf w (proofOf n f) v = f v := by + intro n + induction n with + | zero => intro v hv; omega + | succ n ih => + intro v hv + have hsplit : proofOf (n + 1) f = proofOf n f ++ f n := by + rw [proofOf, proofOf, List.range_succ, List.flatMap_append] + simp + have hlen : (proofOf n f).length = n * w := length_proofOf hf n + rcases Nat.lt_or_ge v n with hlt | hge + · have hvw : v * w + w ≤ n * w := by + have : (v + 1) * w ≤ n * w := Nat.mul_le_mul_right _ (by omega) + rw [Nat.add_mul, Nat.one_mul] at this + omega + rw [blockOf, hsplit, List.drop_append_of_le_length (by omega), + List.take_append_of_le_length (by rw [List.length_drop, hlen]; omega)] + exact ih v hlt + · have hvn : v = n := by omega + subst hvn + rw [blockOf, hsplit, show v * w = (proofOf v f).length from hlen.symm, + List.drop_left, List.take_of_length_le (by rw [hf])] + +theorem length_blockOf {w : ℕ} {π : List Bool} {v : ℕ} (h : (v + 1) * w ≤ π.length) : + (blockOf w π v).length = w := by + rw [blockOf, List.length_take, List.length_drop] + have : v * w + w ≤ π.length := by + rw [Nat.add_mul, Nat.one_mul] at h + omega + omega + +theorem getElem_blockOf {w : ℕ} {π : List Bool} {v j : ℕ} (h : (v + 1) * w ≤ π.length) + (hj : j < w) : + (blockOf w π v)[j]'(by rw [length_blockOf h]; exact hj) = π.getD (v * w + j) false := by + have hlt : v * w + j < π.length := by + rw [Nat.add_mul, Nat.one_mul] at h + omega + simp only [blockOf] + rw [List.getElem_take, List.getElem_drop, List.getD_eq_getElem?_getD, + List.getElem?_eq_getElem hlt] + rfl + +/-- **The verifier reads exactly the two endpoint blocks.** -/ +theorem answers_posVal (A : AlgCSP) (x π : List Bool) (e : ℕ) + (h0 : (A.vert false x e + 1) * A.width ≤ π.length) + (h1 : (A.vert true x e + 1) * A.width ≤ π.length) : + PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x e)) + = blockOf A.width π (A.vert false x e) ++ blockOf A.width π (A.vert true x e) := by + have hb0 : (blockOf A.width π (A.vert false x e)).length = A.width := length_blockOf h0 + have hb1 : (blockOf A.width π (A.vert true x e)).length = A.width := length_blockOf h1 + refine List.ext_getElem ?_ fun j hj1 hj2 => ?_ + · rw [PCPVerifier.answers, List.length_map, List.length_map, List.length_range, + List.length_append, hb0, hb1] + ring + · have hj : j < 2 * A.width := by + rw [PCPVerifier.answers, List.length_map, List.length_map, List.length_range] at hj1 + exact hj1 + have hans : PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x e)) + = ((List.range (2 * A.width)).map (A.posVal x e)).map (fun i => π.getD i false) := + rfl + simp only [hans] + rw [List.getElem_map, List.getElem_map, List.getElem_range] + by_cases hlow : j < A.width + · rw [List.getElem_append_left (by rw [hb0]; exact hlow), getElem_blockOf h0 hlow, + AlgCSP.posVal, if_pos hlow] + simp [hlow] + · have hge : (blockOf A.width π (A.vert false x e)).length ≤ j := by + rw [hb0]; omega + rw [List.getElem_append_right hge] + simp only [hb0] + rw [getElem_blockOf h1 (by omega), AlgCSP.posVal, if_neg hlow] + simp [hlow] + +/-! ### Padding a proof -/ + +theorem answers_append_false (π : List Bool) (k : ℕ) (ps : List ℕ) : + PCPVerifier.answers π ps + = PCPVerifier.answers (π ++ List.replicate k false) ps := by + have hget : ∀ i, π.getD i false = (π ++ List.replicate k false).getD i false := by + intro i + by_cases hi : i < π.length + · rw [List.getD_eq_getElem?_getD, List.getD_eq_getElem?_getD, + List.getElem?_eq_getElem hi, + List.getElem?_eq_getElem (by rw [List.length_append]; omega), + List.getElem_append_left hi] + · rw [List.getD_eq_getElem?_getD, List.getElem?_eq_none (by omega)] + by_cases hi2 : i < (π ++ List.replicate k false).length + · rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hi2, + List.getElem_append_right (by omega)] + simp + · rw [List.getD_eq_getElem?_getD, List.getElem?_eq_none (by omega)] + show ps.map (fun i => π.getD i false) = ps.map _ + exact List.map_congr_left fun i _ => hget i + +/-! ### Agreement with a real constraint graph -/ + +namespace AlgCSP + +/-- An algorithmic graph agrees with a real one: same edges, same endpoints, +and the constraint means the same thing once symbols are decoded. -/ +structure Models (A : AlgCSP) {α : Type} (G : List Bool → ConstraintGraph α) + (enc : α → List Bool) (dec : List Bool → α) : Prop where + /-- The edge counts agree. -/ + numEdges_eq : ∀ x, A.numEdges x = (G x).numEdges + /-- The first endpoint agrees. -/ + tail_eq : ∀ (x : List Bool) (e : ℕ) (he : e < (G x).numEdges), + A.vert false x e = ((G x).tail ⟨e, he⟩).val + /-- The second endpoint agrees. -/ + head_eq : ∀ (x : List Bool) (e : ℕ) (he : e < (G x).numEdges), + A.vert true x e = ((G x).head ⟨e, he⟩).val + /-- Symbols occupy exactly the block width. -/ + length_enc : ∀ s : α, (enc s).length = A.width + /-- Decoding inverts encoding. -/ + dec_enc : ∀ s : α, dec (enc s) = s + /-- The constraint agrees on blocks. -/ + ok_iff : ∀ (x : List Bool) (e : ℕ) (he : e < (G x).numEdges) (u v : List Bool), + u.length = A.width → v.length = A.width → + (pair (pair x (List.replicate e true)) (u ++ v) ∈ A.ok + ↔ (G x).rel ⟨e, he⟩ (dec u) (dec v) = true) + +variable {A : AlgCSP} {α : Type} [Inhabited α] {G : List Bool → ConstraintGraph α} + {enc : α → List Bool} {dec : List Bool → α} + +/-- The proof an assignment writes. -/ +def assignProof (enc : α → List Bool) [Inhabited α] + (n : ℕ) (a : Fin n → α) : List Bool := + proofOf n (fun v => if h : v < n then enc (a ⟨v, h⟩) else enc default) + +theorem length_assignProof (hM : A.Models G enc dec) (n : ℕ) (a : Fin n → α) : + (assignProof enc n a).length = n * A.width := by + refine length_proofOf (w := A.width) (fun i => ?_) n + by_cases h : i < n <;> simp [h, hM.length_enc] + +theorem blockOf_assignProof (hM : A.Models G enc dec) {n : ℕ} (a : Fin n → α) + {v : ℕ} (hv : v < n) : + blockOf A.width (assignProof enc n a) v = enc (a ⟨v, hv⟩) := by + have := blockOf_proofOf (w := A.width) + (f := fun v => if h : v < n then enc (a ⟨v, h⟩) else enc default) + (fun i => by by_cases h : i < n <;> simp [h, hM.length_enc]) n v hv + rw [assignProof, this] + simp only + rw [dif_pos hv] + +/-- **Completeness transfers.** A satisfying assignment writes a proof the +verifier accepts on every edge. -/ +theorem Models.sat_of_satisfiable (hM : A.Models G enc dec) (x : List Bool) + (h : (G x).Satisfiable) : + ∃ π : List Bool, ∀ e < A.numEdges x, A.Sat x π e := by + obtain ⟨a, ha⟩ := h + refine ⟨assignProof enc (G x).numVerts a, ?_⟩ + intro e he + rw [hM.numEdges_eq] at he + set π := assignProof enc (G x).numVerts a with hπ + have hlen : π.length = (G x).numVerts * A.width := length_assignProof hM _ a + have h0 : A.vert false x e = ((G x).tail ⟨e, he⟩).val := hM.tail_eq x e he + have h1 : A.vert true x e = ((G x).head ⟨e, he⟩).val := hM.head_eq x e he + have hb0 : (A.vert false x e + 1) * A.width ≤ π.length := by + rw [hlen, h0] + exact Nat.mul_le_mul_right _ ((G x).tail ⟨e, he⟩).isLt + have hb1 : (A.vert true x e + 1) * A.width ≤ π.length := by + rw [hlen, h1] + exact Nat.mul_le_mul_right _ ((G x).head ⟨e, he⟩).isLt + have hv0 : blockOf A.width π (A.vert false x e) = enc (a ((G x).tail ⟨e, he⟩)) := by + rw [h0, blockOf_assignProof hM a ((G x).tail ⟨e, he⟩).isLt] + have hv1 : blockOf A.width π (A.vert true x e) = enc (a ((G x).head ⟨e, he⟩)) := by + rw [h1, blockOf_assignProof hM a ((G x).head ⟨e, he⟩).isLt] + show pair (pair x (List.replicate e true)) + (PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x e))) ∈ A.ok + rw [answers_posVal A x π e hb0 hb1, hv0, hv1, + hM.ok_iff x e he _ _ (hM.length_enc _) (hM.length_enc _), hM.dec_enc, hM.dec_enc] + exact ha ⟨e, he⟩ + +theorem card_filter_range_eq {n : ℕ} (P : ℕ → Prop) [DecidablePred P] : + ((Finset.range n).filter P).card + = (Finset.univ.filter (fun i : Fin n => P i.val)).card := by + refine Finset.card_bij (fun i hi => (⟨i, Finset.mem_range.mp (Finset.mem_filter.mp hi).1⟩ + : Fin n)) ?_ ?_ ?_ + · intro i hi + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact (Finset.mem_filter.mp hi).2 + · intro i hi j hj hij + exact congrArg Fin.val hij + · intro b hb + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hb + exact ⟨b.val, Finset.mem_filter.mpr ⟨Finset.mem_range.mpr b.isLt, hb⟩, rfl⟩ + +omit [Inhabited α] in +open Classical in +/-- **Soundness transfers.** No proof satisfies more than a `1 - gap` fraction +of the edges. -/ +theorem Models.card_sat_le [Fintype α] [Nonempty α] (hM : A.Models G enc dec) + (x : List Bool) {gap : ℚ} (hgap : gap ≤ (G x).unsatVal) (π : List Bool) : + (((Finset.range (A.numEdges x)).filter (A.Sat x π)).card : ℚ) + ≤ (1 - gap) * A.numEdges x := by + classical + set π' := π ++ List.replicate ((G x).numVerts * A.width) false with hπ' + have hlen : (G x).numVerts * A.width ≤ π'.length := by + rw [hπ', List.length_append, List.length_replicate] + omega + set a : (G x).Assignment := fun v => dec (blockOf A.width π' v.val) with ha + have hstep : ∀ (e : Fin (G x).numEdges), + A.Sat x π e.val ↔ (G x).satisfies a e = true := by + intro e + have h0 : A.vert false x e.val = ((G x).tail e).val := hM.tail_eq x e.val e.isLt + have h1 : A.vert true x e.val = ((G x).head e).val := hM.head_eq x e.val e.isLt + have hb0 : (A.vert false x e.val + 1) * A.width ≤ π'.length := by + refine le_trans (Nat.mul_le_mul_right _ ?_) hlen + rw [h0] + exact ((G x).tail e).isLt + have hb1 : (A.vert true x e.val + 1) * A.width ≤ π'.length := by + refine le_trans (Nat.mul_le_mul_right _ ?_) hlen + rw [h1] + exact ((G x).head e).isLt + show pair (pair x (List.replicate e.val true)) + (PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x e.val))) ∈ A.ok ↔ _ + rw [answers_append_false π ((G x).numVerts * A.width), ← hπ', + answers_posVal A x π' e.val hb0 hb1, + hM.ok_iff x e.val e.isLt _ _ (length_blockOf hb0) (length_blockOf hb1)] + rw [ConstraintGraph.satisfies, ha, h0, h1] + have hcard : ((Finset.range (A.numEdges x)).filter (A.Sat x π)).card + = (Finset.univ.filter + (fun e : Fin (G x).numEdges => (G x).satisfies a e = true)).card := by + rw [hM.numEdges_eq, card_filter_range_eq] + congr 1 + ext e + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact hstep e + have hunsat : (G x).unsatEdges a + = Finset.univ.filter (fun e : Fin (G x).numEdges => ¬ ((G x).satisfies a e = true)) := by + ext e + simp [ConstraintGraph.unsatEdges, ConstraintGraph.Satisfies] + have hsplit : (Finset.univ.filter + (fun e : Fin (G x).numEdges => (G x).satisfies a e = true)).card + + ((G x).unsatEdges a).card = (G x).numEdges := by + rw [hunsat] + have h := Finset.card_filter_add_card_filter_not + (s := (Finset.univ : Finset (Fin (G x).numEdges))) + (p := fun e => (G x).satisfies a e = true) + rw [Finset.card_univ, Fintype.card_fin] at h + exact h + rw [hcard, hM.numEdges_eq] + rcases Nat.eq_zero_or_pos (G x).numEdges with h0 | hpos + · have hIE : IsEmpty (Fin (G x).numEdges) := ⟨fun e => absurd e.isLt (by omega)⟩ + have hempty : (Finset.univ.filter + (fun e : Fin (G x).numEdges => (G x).satisfies a e = true)).card = 0 := + Finset.card_eq_zero.mpr (Finset.eq_empty_of_isEmpty _) + rw [hempty, h0] + simp + · have hNQ : (0 : ℚ) < ((G x).numEdges : ℚ) := by exact_mod_cast hpos + have hfrac : gap ≤ ((((G x).unsatEdges a).card : ℚ)) / ((G x).numEdges : ℚ) := + le_trans hgap ((G x).unsatVal_le a) + have hge : gap * ((G x).numEdges : ℚ) ≤ (((G x).unsatEdges a).card : ℚ) := by + rw [le_div_iff₀ hNQ] at hfrac + exact hfrac + have hs : ((Finset.univ.filter + (fun e : Fin (G x).numEdges => (G x).satisfies a e = true)).card : ℚ) + + ((((G x).unsatEdges a).card : ℚ)) = ((G x).numEdges : ℚ) := by + exact_mod_cast congrArg (Nat.cast : ℕ → ℚ) hsplit + linarith + +end AlgCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgCompose.lean b/Complexitylib/Classes/PCP/Internal/AlgCompose.lean new file mode 100644 index 00000000..2d3ad1b7 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgCompose.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.LocalTest +public import Complexitylib.Classes.PCP.Internal.NumEncPi +public import Complexitylib.Classes.PCP.Internal.Compose + +/-! +# The composed graph, in numbers + +The binary graph a family of tests produces has one vertex per position and per +(test, random string), and one edge per (test, random string, read). Both are +numbered by `NumEnc`, so an edge index splits by division and remainder into the +test, the string and the read, and the two endpoints are read off from there. + +## Main results + +- `Complexity.MultiTest.enc_edgeOf` — the edge a number names carries that number +- `Complexity.MultiTest.enc_edge` — how an edge's number splits +- `Complexity.MultiTest.val_tail_toGraph`, `val_head_toGraph` — the endpoints +- `Complexity.RegCSP.enc_pos_inl`, `enc_pos_lin`, `enc_pos_quad` — the three + kinds of position of the composed proof +-/ + +@[expose] public section + +namespace Complexity + +namespace MultiTest + +open NumEnc BooleanAnalysis + +variable {Pos E Q : Type} (M : MultiTest Pos E Q) [Fintype Pos] [Fintype E] [Fintype Q] + [NumEnc Pos] [NumEnc E] [NumEnc Q] + +omit [Fintype Pos] [NumEnc Pos] in +theorem enc_edgeOf (k : Fin (Fintype.card M.Edge)) : enc (M.edgeOf k) = k.val := by + show enc ((NumEnc.equivFinCard M.Edge).symm k) = _ + have h : (NumEnc.equivFinCard M.Edge ((NumEnc.equivFinCard M.Edge).symm k)).val = k.val := + congrArg Fin.val (Equiv.apply_symm_apply _ _) + exact h + +omit [Fintype Q] [NumEnc Q] in +theorem val_vertIdx (v : M.Vert) : (M.vertIdx v).val = enc v := rfl + +omit [Fintype Pos] [Fintype E] [Fintype Q] [NumEnc Pos] in +/-- **How an edge's number splits**: the test, then the random string, then the +read. -/ +theorem enc_edge (x : M.Edge) : + enc x = enc x.1 * (card (Cube M.R) * card Q) + (enc x.2.1 * card Q + enc x.2.2) := rfl + +/-- **The first endpoint**: the test vertex, numbered after all the positions. -/ +theorem val_tail_toGraph (k : Fin (Fintype.card M.Edge)) : + (M.toGraph.tail k).val + = card Pos + (enc (M.edgeOf k).1 * card (Cube M.R) + enc (M.edgeOf k).2.1) := rfl + +/-- **The second endpoint**: the position the read asks for. -/ +theorem val_head_toGraph (k : Fin (Fintype.card M.Edge)) : + (M.toGraph.head k).val + = enc (M.pos (M.edgeOf k).1 (M.edgeOf k).2.1 (M.edgeOf k).2.2) := rfl + +end MultiTest + +/-! ### The composed proof's positions -/ + +namespace RegCSP + +open NumEnc BooleanAnalysis Tester + +variable {β : Type} [Fintype β] [DecidableEq β] [Nonempty β] (R : RegCSP β) + [NumEnc R.graph.V] [NumEnc R.graph.D] {B : ℕ} + +omit [Fintype β] [DecidableEq β] [Nonempty β] in +/-- **A position in a vertex's encoding block.** -/ +theorem enc_pos_inl (v : R.graph.V) (y : Cube B) : + NumEnc.enc (Sum.inl (v, y) : R.Pos (B := B)) + = NumEnc.enc v * card (Cube B) + NumEnc.enc y := rfl + +omit [Fintype β] [DecidableEq β] [Nonempty β] in +/-- **A position in a dart's linear table**, after all the encoding blocks. -/ +theorem enc_pos_lin (p : R.Dart) (y : Cube (nOf B)) : + NumEnc.enc (Sum.inr (Sum.inl (p, y)) : R.Pos (B := B)) + = card R.graph.V * card (Cube B) + + (NumEnc.enc p * card (Cube (nOf B)) + NumEnc.enc y) := rfl + +omit [Fintype β] [DecidableEq β] [Nonempty β] in +/-- **A position in a dart's quadratic table**, after the linear ones. -/ +theorem enc_pos_quad (p : R.Dart) (y : Cube (nOf B * nOf B)) : + NumEnc.enc (Sum.inr (Sum.inr (p, y)) : R.Pos (B := B)) + = card R.graph.V * card (Cube B) + + (card R.Dart * card (Cube (nOf B)) + + (NumEnc.enc p * card (Cube (nOf B * nOf B)) + NumEnc.enc y)) := rfl + +omit [Fintype β] [DecidableEq β] [Nonempty β] in +/-- **A dart's number splits into its vertex and its label.** -/ +theorem enc_dart (p : R.Dart) : + NumEnc.enc p = NumEnc.enc p.1 * card R.graph.D + NumEnc.enc p.2 := rfl + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgEdge.lean b/Complexitylib/Classes/PCP/Internal/AlgEdge.lean new file mode 100644 index 00000000..47c1e93b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgEdge.lean @@ -0,0 +1,443 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgKeyFn +public import Complexitylib.Classes.PCP.Internal.AlgPosNum + +/-! +# A composed edge's record + +An edge of the composed graph carries three numbers: its two endpoints and the +code of its constraint. The first endpoint is arithmetic in the edge number; the +second is a position, laid out by kind — an encoding block, a linear table or a +quadratic one — and the third is the code the tester's verdict names. + +This module writes the position's layout out as an algorithm. + +## Main definitions + +- `Complexity.posBlk` — a position's number, from its kind, block and cube +- `Complexity.tailBlk` — an edge's first endpoint +- `Complexity.kindBlk`, `Complexity.blockBlk` — which kind of block the second + endpoint lies in, and which block +- `Complexity.headBlk` — the second endpoint itself +- `Complexity.edgeRule`, `Complexity.stepFn` — one edge's record, and the graph + a round produces + +## Main results + +- `Complexity.posBlk_eq` — it is `RegCSP.posNum` +- `Complexity.posBlk_mem_FP` — and it is computed in polynomial time +- `Complexity.tailBlk_eq`, `Complexity.tailBlk_mem_FP` — likewise for the first + endpoint +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis Tester + +/-- A position's number, from its kind, the block it lies in and the cube inside +that block. Kind `0` is an encoding block, kind `1` a dart's linear table, and +anything else a dart's quadratic table. -/ +noncomputable def posBlk (cardB cardN cardNN cardD : ℕ) + (cardV kind block cube : List Bool) : List Bool := + ifEqLen kind [] (marks (mulC cardB block) ++ cube) + (ifEqLen kind [true] + (marks (mulC cardB cardV) ++ (marks (mulC cardN block) ++ cube)) + (marks (mulC cardB cardV) + ++ (marks (mulC (cardD * cardN) cardV) ++ (marks (mulC cardNN block) ++ cube)))) + +/-- **The layout computes the position's number.** -/ +theorem posBlk_eq (cardB cardN cardNN cardD k b c : ℕ) (cardV kind block cube : List Bool) + (hk : kind.length = k) (hb : block.length = b) (hc : cube = List.replicate c true) : + posBlk cardB cardN cardNN cardD cardV kind block cube + = List.replicate (RegCSP.posNum cardV.length cardD cardB cardN cardNN k b c) true := by + have happ : ∀ m n : ℕ, List.replicate m true ++ List.replicate n true + = List.replicate (m + n) true := fun m n => (List.replicate_add m n true).symm + rw [posBlk, RegCSP.posNum] + by_cases h0 : k = 0 + · rw [ifEqLen_pos (by simp [hk, h0]), if_pos h0, marks_eq, length_mulC, hb, hc, happ] + rw [ifEqLen_neg (by simp [hk, h0]), if_neg h0] + by_cases h1 : k = 1 + · rw [ifEqLen_pos (by simp [hk, h1]), if_pos h1, marks_eq, marks_eq, length_mulC, + length_mulC, hb, hc, happ, happ] + rw [ifEqLen_neg (by simp [hk, h1]), if_neg h1, marks_eq, marks_eq, marks_eq, + length_mulC, length_mulC, length_mulC, hb, hc, happ, happ, happ] + congr 2 + ring + +theorem posBlk_mem_FP {cardB cardN cardNN cardD : ℕ} + {cardV kind block cube : List Bool → List Bool} + (hV : cardV ∈ FP) (hk : kind ∈ FP) (hb : block ∈ FP) (hc : cube ∈ FP) : + (fun w => posBlk cardB cardN cardNN cardD (cardV w) (kind w) (block w) (cube w)) ∈ FP := by + have hbb := marks_mem_FP (mulC_mem_FP hb cardB) + have hVB := marks_mem_FP (mulC_mem_FP hV cardB) + have hNb := marks_mem_FP (mulC_mem_FP hb cardN) + have hNV := marks_mem_FP (mulC_mem_FP hV (cardD * cardN)) + have hNNb := marks_mem_FP (mulC_mem_FP hb cardNN) + exact ifEqLen_mem_FP hk (constFn_mem_FP []) (Cobham.appendFn_mem_FP hbb hc) + (ifEqLen_mem_FP hk (constFn_mem_FP [true]) + (Cobham.appendFn_mem_FP hVB (Cobham.appendFn_mem_FP hNb hc)) + (Cobham.appendFn_mem_FP hVB + (Cobham.appendFn_mem_FP hNV (Cobham.appendFn_mem_FP hNNb hc)))) + +/-! ### The first endpoint -/ + +variable {α : Type} [Fintype α] [DecidableEq α] + +/-- An edge's first endpoint: the test vertex it belongs to, after all the +positions. -/ +noncomputable def tailBlk (posF : ℕ) (r : Round) (w : List Bool) : List Bool := + marks (mulC posF (posCount (Cobham.sndBlock (Cobham.fstBlock w)))) + ++ (marks (mulC r.cZ (testFn r w)) ++ randFn r w) + +theorem tailBlk_mem_FP (posF : ℕ) (r : Round) : tailBlk posF r ∈ FP := + Cobham.appendFn_mem_FP + (marks_mem_FP (mulC_mem_FP (posCount_mem_FP + (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP)) posF)) + (Cobham.appendFn_mem_FP (marks_mem_FP (mulC_mem_FP (testFn_mem_FP r) r.cZ)) + (randFn_mem_FP r)) + +/-- **The first endpoint's algorithm computes it.** -/ +theorem tailBlk_eq (posF : ℕ) (r : Round) (G : ConstraintGraph α) {w : List Bool} {t zN : ℕ} + (hg : Cobham.fstBlock w = encGraph G) (ht : testFn r w = List.replicate t true) + (hz : randFn r w = List.replicate zN true) : + tailBlk posF r w = List.replicate (G.numEdges * posF + (t * r.cZ + zN)) true := by + have hcnt : (posCount (Cobham.sndBlock (encGraph G))).length = G.numEdges := by + have h := gEdges_encGraph G + rwa [gEdges] at h + rw [tailBlk, hg, ht, hz, marks_eq, marks_eq, length_mulC, length_mulC, hcnt, + List.length_replicate, ← List.replicate_add, ← List.replicate_add] + +/-! ### Which block the second endpoint lies in -/ + +theorem readFn_length_le (w : List Bool) : (readFn w).length ≤ 22 := by + rw [readFn, modC_eq (by omega), List.length_replicate] + exact le_of_lt (Nat.mod_lt _ (by omega)) + +/-- The kind of block a read lands in. -/ +noncomputable def kindBlk (w : List Bool) : List Bool := + List.replicate (RegCSP.readKind (decOr ReadIdx.f1x (readFn w).length)) true + +theorem kindBlk_mem_FP : kindBlk ∈ FP := + mem_FP_of_bounded_key readFn_mem_FP readFn_length_le + (fun s => List.replicate (RegCSP.readKind (decOr ReadIdx.f1x s.length)) true) + +/-- **The kind is the read's.** -/ +theorem kindBlk_eq {w : List Bool} {i : ReadIdx} (hi : readFn w = List.replicate + (NumEnc.enc i) true) : + kindBlk w = List.replicate (RegCSP.readKind i) true := by + rw [kindBlk, hi, List.length_replicate, decOr_enc] + +/-- The block the second endpoint lies in: the dart's tail for the first input +read, its head for the second, and the dart itself otherwise. -/ +noncomputable def blockBlk (F : FinBase) (pol : Polynomial ℕ) (r : Round) (w : List Bool) : + List Bool := + ifEqLen (readFn w) (List.replicate (NumEnc.enc ReadIdx.i5r) true) (vertFn r w) + (ifEqLen (readFn w) (List.replicate (NumEnc.enc ReadIdx.i6r) true) + (Cobham.fstBlock (killedRotFn F pol r.deg r.P r.T r.q (killArg r w))) + (testFn r w)) + +theorem blockBlk_mem_FP (F : FinBase) (pol : Polynomial ℕ) (r : Round) : + blockBlk F pol r ∈ FP := by + have hrot : (fun w : List Bool => + Cobham.fstBlock (killedRotFn F pol r.deg r.P r.T r.q (killArg r w))) ∈ FP := + mem_FP_of_eq (mem_FP_comp (killArg_mem_FP r) + (mem_FP_comp (killedRotFn_mem_FP F pol r.deg r.P r.T r.q) Cobham.fstBlock_mem_FP)) + fun _ => rfl + exact ifEqLen_mem_FP readFn_mem_FP (constFn_mem_FP _) (vertFn_mem_FP r) + (ifEqLen_mem_FP readFn_mem_FP (constFn_mem_FP _) hrot (testFn_mem_FP r)) + +/-- **The block is the one the read asks for.** -/ +theorem blockBlk_eq {β : Type} [Fintype β] [DecidableEq β] [Nonempty β] {R : RegCSP β} + [NumEnc R.graph.V] [NumEnc R.graph.D] (F : FinBase) (pol : Polynomial ℕ) (r : Round) + {w : List Bool} (p : R.Dart) (i : ReadIdx) + (hread : readFn w = List.replicate (NumEnc.enc i) true) + (hv : vertFn r w = List.replicate (NumEnc.enc p.1) true) + (ht : testFn r w = List.replicate (NumEnc.enc p) true) + (hrot : Cobham.fstBlock (killedRotFn F pol r.deg r.P r.T r.q (killArg r w)) + = List.replicate (NumEnc.enc (R.graph.rot p).1) true) : + blockBlk F pol r w = List.replicate (R.blockNum p i) true := by + have hne : ∀ j k : ReadIdx, j ≠ k → NumEnc.enc j ≠ NumEnc.enc k := + fun j k h hcon => h (NumEnc.enc_injective hcon) + rw [blockBlk, hread] + rcases eq_or_ne i ReadIdx.i5r with rfl | h5 + · rw [ifEqLen_pos (by simp), hv, RegCSP.blockNum] + rw [ifEqLen_neg (by simpa using hne i ReadIdx.i5r h5)] + rcases eq_or_ne i ReadIdx.i6r with rfl | h6 + · rw [ifEqLen_pos (by simp), hrot, RegCSP.blockNum] + rfl + rw [ifEqLen_neg (by simpa using hne i ReadIdx.i6r h6), ht] + cases i <;> first | rfl | exact absurd rfl h5 | exact absurd rfl h6 + +/-! ### The second endpoint -/ + +/-- How many vertices the powered graph has: twice the input's edge count. -/ +noncomputable def vertCount (w : List Bool) : List Bool := + marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock w)))) + +theorem vertCount_mem_FP : vertCount ∈ FP := + marks_mem_FP (mulC_mem_FP (posCount_mem_FP + (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP)) 2) + +theorem vertCount_eq (G : ConstraintGraph α) {w : List Bool} + (hg : Cobham.fstBlock w = encGraph G) : + vertCount w = List.replicate (2 * G.numEdges) true := by + have hcnt : (posCount (Cobham.sndBlock (encGraph G))).length = G.numEdges := by + have h := gEdges_encGraph G + rwa [gEdges] at h + rw [vertCount, hg, marks_eq, length_mulC, hcnt, Nat.mul_comm] + +/-- An edge's second endpoint. -/ +noncomputable def headBlk (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) (w : List Bool) : List Bool := + posBlk cardB cardN cardNN r.cD (vertCount w) (kindBlk w) (blockBlk F pol r w) + (cubeFn F pol r dflt encβ w) + +theorem headBlk_mem_FP (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 < r.C) + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) : + headBlk F pol r cardB cardN cardNN dflt encβ ∈ FP := + posBlk_mem_FP vertCount_mem_FP kindBlk_mem_FP (blockBlk_mem_FP F pol r) + (cubeFn_mem_FP F pol r hQ hD hZ hC dflt encβ) + +/-- **The second endpoint's algorithm computes its number.** -/ +theorem headBlk_eq (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) {w : List Bool} {V k b c : ℕ} + (hV : vertCount w = List.replicate V true) + (hk : kindBlk w = List.replicate k true) + (hb : blockBlk F pol r w = List.replicate b true) + (hc : cubeFn F pol r dflt encβ w = List.replicate c true) : + headBlk F pol r cardB cardN cardNN dflt encβ w + = List.replicate (RegCSP.posNum V r.cD cardB cardN cardNN k b c) true := by + have hVlen : (vertCount w).length = V := by rw [hV, List.length_replicate] + rw [headBlk, posBlk_eq cardB cardN cardNN r.cD k b c _ _ _ _ + (by rw [hk, List.length_replicate]) (by rw [hb, List.length_replicate]) hc, hVlen] + +/-! ### The label encoding, without the graph -/ + +theorem card_preDart (E : ExpanderFamily) : Fintype.card (PreDart E) = Dinur.powDeg E := by + show Fintype.card (Unit ⊕ (Option (Fin E.degree) ⊕ Fin E.degree)) = _ + rw [Dinur.powDeg] + simp + omega + +theorem card_preWalk (E : ExpanderFamily) (T : ℕ) : + Fintype.card (PreWalk E T) = Dinur.walkCount E T := by + rw [Dinur.walkCount, ← Fin.sum_univ_eq_sum_range (fun ℓ => Dinur.powDeg E ^ ℓ) (T + 1)] + show Fintype.card (Σ ℓ : Fin (T + 1), Fin ℓ.val → PreDart E) = _ + rw [Fintype.card_sigma] + refine Finset.sum_congr rfl fun ℓ _ => ?_ + rw [Fintype.card_fun, Fintype.card_fin, card_preDart] + +theorem card_preOpinion (E : ExpanderFamily) (T : ℕ) : + Fintype.card (PreWalk E T → DinurAlpha) = Dinur.bits E T := by + rw [Fintype.card_fun, card_preWalk, Dinur.bits] + +/-- **The encoding of a powered label**, at a type that does not mention the +graph. -/ +noncomputable def encPre (E : ExpanderFamily) (T : ℕ) (σ : PreWalk E T → DinurAlpha) : + Cube (Dinur.bits E T) := + basisVec (Fin.cast (card_preOpinion E T) (Fintype.equivFin _ σ)) + +/-- **It is the encoding the round uses.** -/ +theorem enc_eq_encPre (E : ExpanderFamily) (G : ConstraintGraph DinurAlpha) (T : ℕ) : + Dinur.enc E G T = encPre E T := rfl + +/-! ### The round's constants -/ + +/-- The constants of a Dinur round at killing rate `q`, over the expander family +a finite base generates. The alphabet's constraint count and the tester's string +count are supplied, so that they carry the caller's own instances. -/ +noncomputable def dinurRound (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : Round where + deg := (F.toFamily hd).degree + P := 2 + 2 * (F.toFamily hd).degree + T := powT Dinur.K q + q := q + C := C + cZ := cZ + +@[simp] theorem dinurRound_deg (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : + (dinurRound F hd q C cZ).deg = (F.toFamily hd).degree := rfl + +theorem dinurRound_P (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) + (G : ConstraintGraph DinurAlpha) : + (dinurRound F hd q C cZ).P = G.preDeg (F.toFamily hd) := + (G.preDeg_eq (F.toFamily hd)).symm + +@[simp] theorem dinurRound_T (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : + (dinurRound F hd q C cZ).T = powT Dinur.K q := rfl + +@[simp] theorem dinurRound_q (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : + (dinurRound F hd q C cZ).q = q := rfl + +@[simp] theorem dinurRound_C (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : + (dinurRound F hd q C cZ).C = C := rfl + +@[simp] theorem dinurRound_cZ (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : + (dinurRound F hd q C cZ).cZ = cZ := rfl + +@[simp] theorem dinurRound_cQ (F : FinBase) (hd : 1 < F.deg) (q C cZ : ℕ) : + (dinurRound F hd q C cZ).cQ = q ^ powT Dinur.K q := rfl + +/-! ### The round's output -/ + +/-- One edge's record: its two endpoints and the code of its constraint. -/ +noncomputable def edgeRule (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (posF cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) (w : List Bool) : List Bool := + encTriple (tailBlk posF r w) (headBlk F pol r cardB cardN cardNN dflt encβ w) + (codeFn F pol r dflt encβ w) + +theorem edgeRule_mem_FP (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (posF cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 < r.C) + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) : + edgeRule F pol r posF cardB cardN cardNN dflt encβ ∈ FP := + encTriple_mem_FP (tailBlk_mem_FP posF r) + (headBlk_mem_FP F pol r cardB cardN cardNN hQ hD hZ hC dflt encβ) + (codeFn_mem_FP F pol r hQ hD hZ hC dflt encβ) + +/-- **The graph a round produces**, from the graph it is given. -/ +noncomputable def stepFn (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (vertF edgeF posF cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) : List Bool → List Bool := + buildGraph (fun z => marks (mulC vertF (posCount (Cobham.sndBlock z)))) + (fun z => marks (mulC edgeF (posCount (Cobham.sndBlock z)))) + (edgeRule F pol r posF cardB cardN cardNN dflt encβ) + +/-- **A count block is a constant multiple of the input's edge count.** -/ +theorem countBlk_eq (G : ConstraintGraph α) (c : ℕ) : + marks (mulC c (posCount (Cobham.sndBlock (encGraph G)))) + = List.replicate (c * G.numEdges) true := by + have hcnt : (posCount (Cobham.sndBlock (encGraph G))).length = G.numEdges := by + have h := gEdges_encGraph G + rwa [gEdges] at h + rw [marks_eq, length_mulC, hcnt, Nat.mul_comm] + +theorem stepFn_mem_FP (F : FinBase) (pol : Polynomial ℕ) (r : Round) + (vertF edgeF posF cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} + (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 < r.C) + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) : + stepFn F pol r vertF edgeF posF cardB cardN cardNN dflt encβ ∈ FP := + buildGraph_mem_FP (marks_mem_FP (mulC_mem_FP (posCount_mem_FP Cobham.sndBlock_mem_FP) vertF)) + (marks_mem_FP (mulC_mem_FP (posCount_mem_FP Cobham.sndBlock_mem_FP) edgeF)) + (edgeRule_mem_FP F pol r posF cardB cardN cardNN hQ hD hZ hC dflt encβ) + +set_option maxHeartbeats 1000000 in +/-- **One round of amplification, computed.** The algorithm's output is the +graph the round produces. -/ +theorem stepFn_eq (F : FinBase) (pol : Polynomial ℕ) (hd : 1 < F.deg) + (G : ConstraintGraph DinurAlpha) + (r : Round) (hq : 0 < r.q) (vertF edgeF posF cardB cardN cardNN : ℕ) + (hrD : r.cD = NumEnc.card ((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).graph.D) + (hrZ : r.cZ = 2 ^ ROf (Dinur.bits (F.toFamily hd) r.T)) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (DinurAlpha → DinurAlpha → Bool)) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (hvertF : (((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).compose + (Dinur.enc (F.toFamily hd) G r.T)).toGraph.numVerts = vertF * G.numEdges) + (hedgeF : (((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).compose + (Dinur.enc (F.toFamily hd) G r.T)).toGraph.numEdges = edgeF * G.numEdges) + (hcardB : cardB = NumEnc.card (Cube (Dinur.bits (F.toFamily hd) r.T))) + (hcardN : cardN = NumEnc.card (Cube (nOf (Dinur.bits (F.toFamily hd) r.T)))) + (hcardNN : cardNN = NumEnc.card (Cube (nOf (Dinur.bits (F.toFamily hd) r.T) + * nOf (Dinur.bits (F.toFamily hd) r.T)))) + (hposF : Fintype.card (((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).Pos + (B := Dinur.bits (F.toFamily hd) r.T)) = G.numEdges * posF) + (dflt : StepKey (F.toFamily hd) r.T r.q (Dinur.bits (F.toFamily hd) r.T) + (Fintype.card (DinurAlpha → DinurAlpha → Bool))) + : + stepFn F pol r vertF edgeF posF cardB cardN cardNN dflt + (Dinur.enc (F.toFamily hd) G r.T) (encGraph G) + = encGraph ((((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).compose + (Dinur.enc (F.toFamily hd) G r.T)).toGraph) := by + refine buildGraph_eq ?_ ?_ ?_ + · rw [countBlk_eq, hvertF] + · rw [countBlk_eq, hedgeF] + · intro e he + obtain ⟨p, z, i, hsplit, htail, hhead, hrel⟩ := RegCSP.edge_facts + ((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq) + (Dinur.enc (F.toFamily hd) G r.T) e he + rw [htail, hhead, hrel] + rw [← hrD, ← hrZ] at hsplit + have hDpos : 0 < r.cD := by + rw [hrD] + have := NumEnc.enc_lt p.2 + omega + have hblt : NumEnc.enc p.2 < r.cD := by + rw [hrD] + exact NumEnc.enc_lt p.2 + have hilt : NumEnc.enc i < 22 := NumEnc.enc_lt i + have hclt : NumEnc.enc z < r.cZ := by + rw [hrZ] + have h := NumEnc.enc_lt z + rw [NumEnc.card_eq_fintype_card, card_cube] at h + exact h + subst hsplit + have hV' : NumEnc.card ((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).graph.V + = 2 * G.numEdges := by + rw [NumEnc.card_eq_fintype_card] + exact G.order_preprocess (F.toFamily hd) + obtain ⟨htest, hvert, hdart, hrand, hread⟩ := + blocks_eq r hDpos (by omega) (encGraph G) + (NumEnc.enc p.1) (NumEnc.enc p.2) (NumEnc.enc z) (NumEnc.enc i) hblt hclt hilt + rw [edgeRule, tailBlk_eq posF r G (Cobham.fstBlock_pair _ _) htest hrand, + RegCSP.tailNum_split' (cZ := r.cZ) _ _ _ _ _ _ hrZ hclt hilt, hposF] + rw [codeFn_eq' (B := Dinur.bits (F.toFamily hd) r.T) r hd G hq hdeg hP hC (by omega) p z i + (by rw [hrZ, NumEnc.card_eq_fintype_card, card_cube]) hpc hpe dflt + (Dinur.enc (F.toFamily hd) G r.T)] + have hread : readFn (pair (encGraph G) (List.replicate + (((NumEnc.enc p.1 * r.cD + NumEnc.enc p.2) * r.cZ + NumEnc.enc z) * 22 + + NumEnc.enc i) true)) = List.replicate (NumEnc.enc i) true := hread + have hcube := cubeFn_eq' (B := Dinur.bits (F.toFamily hd) r.T) r hd G hq hdeg hP hC + (by omega) p z i (by rw [hrZ, NumEnc.card_eq_fintype_card, card_cube]) hpc hpe dflt + (Dinur.enc (F.toFamily hd) G r.T) + have hblock : blockBlk F pol r (pair (encGraph G) (List.replicate + (((NumEnc.enc p.1 * r.cD + NumEnc.enc p.2) * r.cZ + NumEnc.enc z) * 22 + + NumEnc.enc i) true)) + = List.replicate (((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).blockNum p i) + true := by + refine blockBlk_eq F pol r p i hread hvert ?_ ?_ + · have hdart' : NumEnc.enc p = NumEnc.enc p.1 * r.cD + NumEnc.enc p.2 := by + rw [RegCSP.enc_dart, hrD] + rw [hdart'] + exact htest + · have hv2 : NumEnc.enc p.1 < 2 * G.numEdges := by + have h := NumEnc.enc_lt p.1 + rwa [hV'] at h + have hc2 : NumEnc.enc p.2.2 < r.q ^ r.T := NumEnc.enc_lt p.2.2 + have hd2 : NumEnc.enc p.2 = NumEnc.enc p.2.1 * r.q ^ r.T + NumEnc.enc p.2.2 := rfl + have hkr := killedRotFn_eq hd G r.T r.q (NumEnc.enc p.1) (NumEnc.enc p.2.1) + (NumEnc.enc p.2.2) hq hv2 hc2 hpc hpe + rw [killArg_eq r (Cobham.fstBlock_pair _ _) hvert hdart, hdeg, hP, hd2, hkr, + Cobham.fstBlock_pair] + have hrn := G.killedRotNum_eq (F.toFamily hd) hq (G.preDeg_pos _) p.1 p.2 + (w := (((G.preprocess (F.toFamily hd)).graph.killedPower r.q r.T hq).rot + (p.1, p.2)).1) + (y := (((G.preprocess (F.toFamily hd)).graph.killedPower r.q r.T hq).rot + (p.1, p.2)).2) rfl + exact congrArg (fun n => List.replicate n true) (congrArg Prod.fst hrn) + rw [headBlk_eq F pol r cardB cardN cardNN dflt (Dinur.enc (F.toFamily hd) G r.T) + (vertCount_eq G (Cobham.fstBlock_pair _ _)) (kindBlk_eq hread) hblock hcube] + rw [hV', ← hrD, ← hcardB, ← hcardN, ← hcardNN] + rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgFamily.lean b/Complexitylib/Classes/PCP/Internal/AlgFamily.lean new file mode 100644 index 00000000..b509a3f6 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgFamily.lean @@ -0,0 +1,254 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgLevel +public import Complexitylib.Classes.PCP.Internal.TowerTable +public import Complexitylib.Classes.PCP.Internal.FamilyFin + +/-! +# The expander's table, for a requested size + +`AlgLevel` finds the tower level a request calls for, and `TowerTable` writes the +rotation table of a level. Putting the two together writes the table of the +level a request calls for — and it is polynomially long, because the level the +search reports always names a size within a constant factor of the request. + +## Main definitions + +- `Complexity.FinBase.famTableFn` — the table for a requested size + +## Main results + +- `Complexity.FinBase.famTableFn_mem_FP` — writing it is polynomial time +- `Complexity.FinBase.famRotFn_mem_FP` — and the family's rotation map is + polynomial time +- `Complexity.FinBase.levelFn_fitLevel` — the search reports the level the + family uses +-/ + +@[expose] public section + +namespace Complexity + +namespace FinBase + +variable (F : FinBase) (p : Polynomial ℕ) + +/-- The level the search reports for a request. -/ +noncomputable def searchLevel (z : List Bool) : ℕ := (levelFn (F.deg ^ 4) p z).length + +/-- **The size at the reported level is within a constant factor of the +request.** -/ +theorem size_searchLevel_le (z : List Bool) : + F.size (F.searchLevel p z) ≤ F.deg ^ 4 + 2 * z.length * F.deg ^ 4 := + pow_levelFn_le (F.deg ^ 4) p z + +theorem size_le_of_le {l : ℕ} (z : List Bool) (hl : l ≤ F.searchLevel p z) : + F.size l ≤ F.deg ^ 4 + 2 * z.length * F.deg ^ 4 := by + refine le_trans ?_ (F.size_searchLevel_le p z) + rw [size, size] + have hbase : 1 ≤ F.deg ^ 4 := pow_pos F.deg_pos 4 + exact Nat.pow_le_pow_right hbase (by omega) + +/-- The table of the level a request calls for. -/ +noncomputable def famTableFn (z : List Bool) : List Bool := F.table (F.searchLevel p z) + +/-- The polynomial that bounds that table. -/ +noncomputable def tableWidth : Polynomial ℕ := + Polynomial.C 2 + + (Polynomial.C (F.deg ^ 4) + Polynomial.C (2 * F.deg ^ 4) * Polynomial.X) + * Polynomial.C (F.deg ^ 2) + * (Polynomial.C 4 * (Polynomial.C (F.deg ^ 4) + + Polynomial.C (2 * F.deg ^ 4) * Polynomial.X) + + Polynomial.C (4 * F.deg ^ 2 + 6)) + +theorem eval_tableWidth (n : ℕ) : + F.tableWidth.eval n + = 2 + (F.deg ^ 4 + 2 * F.deg ^ 4 * n) * F.deg ^ 2 + * (4 * (F.deg ^ 4 + 2 * F.deg ^ 4 * n) + (4 * F.deg ^ 2 + 6)) := by + simp only [tableWidth, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X] + +/-- **Writing the table for a requested size is polynomial time.** -/ +theorem famTableFn_mem_FP : F.famTableFn p ∈ FP := by + refine F.table_mem_FP (levelFn_mem_FP (F.deg ^ 4) p) + (polyRulerFn_mem_FP F.tableWidth id_mem_FP) ?_ + intro z l hl + rw [polyRuler_length, eval_tableWidth] + refine le_trans (F.length_table_le l) ?_ + have hsize : F.size l ≤ F.deg ^ 4 + 2 * z.length * F.deg ^ 4 := + F.size_le_of_le p z hl + have hM : F.deg ^ 4 + 2 * z.length * F.deg ^ 4 = F.deg ^ 4 + 2 * F.deg ^ 4 * z.length := by + ring + rw [hM] at hsize + have h1 : F.size l * F.deg ^ 2 ≤ (F.deg ^ 4 + 2 * F.deg ^ 4 * z.length) * F.deg ^ 2 := + Nat.mul_le_mul_right _ hsize + have h2 : 4 * F.size l + 4 * F.deg ^ 2 + 6 + ≤ 4 * (F.deg ^ 4 + 2 * F.deg ^ 4 * z.length) + (4 * F.deg ^ 2 + 6) := by omega + exact Nat.add_le_add_left (Nat.mul_le_mul h1 h2) 2 + +/-! ### The level the family asks for -/ + +/-- **The search reports the level the family uses.** -/ +theorem levelFn_fitLevel (hd : 1 < F.deg) (n : ℕ) + (hp : F.fitLevel hd n ≤ p.eval n) : + (levelFn (F.deg ^ 4) p (List.replicate n true)).length = F.fitLevel hd n := by + have hlen : (List.replicate n true).length = n := List.length_replicate + refine levelFn_length _ p _ _ ?_ ?_ (by rw [hlen]; exact hp) + · rw [hlen] + have := F.le_size_level hd (2 * n) + rw [size] at this + exact this + · intro i hi + rw [hlen] + have hmin := Nat.find_min (F.exists_size_ge hd (2 * n)) (m := i) hi + rw [size] at hmin + exact hmin + +/-- **The search reports the size the family uses.** -/ +theorem sizeFn_fitN (hd : 1 < F.deg) (n : ℕ) (hp : F.fitLevel hd n ≤ p.eval n) : + (sizeFn (F.deg ^ 4) p (List.replicate n true)).length = F.fitN hd n := by + rw [sizeFn_length, F.levelFn_fitLevel p hd n hp, fitN, size] + +/-- **And writes that level's table.** -/ +theorem famTableFn_eq (hd : 1 < F.deg) (n : ℕ) (hp : F.fitLevel hd n ≤ p.eval n) : + F.famTableFn p (List.replicate n true) = F.table (F.fitLevel hd n) := by + rw [famTableFn, searchLevel, F.levelFn_fitLevel p hd n hp] + +/-! ### The family's rotation map -/ + +/-- The family's rotation map, on `pair (unary n) (pair (unary v) (unary i))`: +split the dart into a slot and a step, lift the vertex into the tower member, +look the step up in that member's table, and fold the answer back onto `n` +vertices. Darts past the fold's degree are self-loops. -/ +noncomputable def famRotFn (z : List Bool) : List Bool := + let n := Cobham.fstBlock z + let v := Cobham.fstBlock (Cobham.sndBlock z) + let i := Cobham.sndBlock (Cobham.sndBlock z) + let N := sizeFn (F.deg ^ 4) p n + let T := F.famTableFn p n + let m := divFn2 (pair n N) ++ [true] + let s := divC F.fitD i + let c := modC F.fitD i + let lift := v ++ mulLen s n + let y1 := tableFst T (mulLen lift (List.replicate F.fitD true) ++ c).length + let y2 := tableSnd T (mulLen lift (List.replicate F.fitD true) ++ c).length + ifLtLen i (mulLen m (List.replicate F.fitD true)) + (ifLtLen lift N + (pair (marks (modFn2 (pair n y1))) + (marks (y2 ++ mulC F.fitD (divFn2 (pair n y1))))) + (pair (marks v) (marks i))) + (pair (marks v) (marks i)) + +theorem famRotFn_mem_FP : F.famRotFn p ∈ FP := by + have hn : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hv : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP) fun _ => rfl + have hi : (fun z : List Bool => Cobham.sndBlock (Cobham.sndBlock z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP) fun _ => rfl + have hN : (fun z : List Bool => sizeFn (F.deg ^ 4) p (Cobham.fstBlock z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp hn (sizeFn_mem_FP _ p)) fun _ => rfl + have hT : (fun z : List Bool => F.famTableFn p (Cobham.fstBlock z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp hn (F.famTableFn_mem_FP p)) fun _ => rfl + have hm := Cobham.appendFn_mem_FP + (mem_FP_of_eq (mem_FP_comp (Cobham.pairFn_mem_FP hn hN) divFn2_mem_FP) fun _ => rfl) + (constFn_mem_FP [true]) + have hs := divC_mem_FP hi F.fitD + have hc := modC_mem_FP hi F.fitD + have hlift := Cobham.appendFn_mem_FP hv (mulLen_mem_FP hs hn) + have hidx := Cobham.appendFn_mem_FP + (mulLen_mem_FP hlift (constFn_mem_FP (List.replicate F.fitD true))) hc + have hy1 := tableFst_mem_FP hidx hT + have hy2 := tableSnd_mem_FP hidx hT + have hmod := mem_FP_of_eq + (mem_FP_comp (Cobham.pairFn_mem_FP hn hy1) modFn2_mem_FP) fun _ => rfl + have hdiv := mem_FP_of_eq + (mem_FP_comp (Cobham.pairFn_mem_FP hn hy1) divFn2_mem_FP) fun _ => rfl + have hstep := Cobham.pairFn_mem_FP (marks_mem_FP hmod) + (marks_mem_FP (Cobham.appendFn_mem_FP hy2 (mulC_mem_FP hdiv F.fitD))) + have hstay := Cobham.pairFn_mem_FP (marks_mem_FP hv) (marks_mem_FP hi) + have hinner := ifLtLen_mem_FP hlift hN hstep hstay + have houter := ifLtLen_mem_FP hi + (mulLen_mem_FP hm (constFn_mem_FP (List.replicate F.fitD true))) hinner hstay + exact mem_FP_of_eq houter fun _ => rfl + +/-- **The rotation function runs the family's rotation map.** -/ +theorem famRotFn_eq (hd : 1 < F.deg) (n v i : ℕ) (hn : 0 < n) + (hp : F.fitLevel hd n ≤ p.eval n) : + F.famRotFn p (pair (List.replicate n true) + (pair (List.replicate v true) (List.replicate i true))) + = pair (List.replicate (F.famRotVal hd n (v, i)).1 true) + (List.replicate (F.famRotVal hd n (v, i)).2 true) := by + have hrep : (List.replicate n true).length = n := List.length_replicate + have hdpos : 0 < F.fitD := F.fitD_pos + have hN : (sizeFn (F.deg ^ 4) p (List.replicate n true)).length = F.fitN hd n := + F.sizeFn_fitN p hd n hp + have hT : F.famTableFn p (List.replicate n true) = F.table (F.fitLevel hd n) := + F.famTableFn_eq p hd n hp + have hm : (divFn2 (pair (List.replicate n true) + (sizeFn (F.deg ^ 4) p (List.replicate n true))) ++ [true]).length = F.wid hd n := by + rw [divFn2_eq (by rw [hrep]; exact hn), List.length_append, List.length_replicate, + List.length_cons, List.length_nil, hrep, hN, wid, RegGraph.mergeWidth] + have hs : (divC F.fitD (List.replicate i true)) = List.replicate (i / F.fitD) true := by + rw [divC_eq hdpos, List.length_replicate] + have hc : (modC F.fitD (List.replicate i true)) = List.replicate (i % F.fitD) true := by + rw [modC_eq hdpos, List.length_replicate] + have hlift : (List.replicate v true + ++ mulLen (divC F.fitD (List.replicate i true)) (List.replicate n true)).length + = v + i / F.fitD * n := by + rw [List.length_append, List.length_replicate, length_mulLen, hs, hrep, + List.length_replicate] + rw [famRotFn, famRotVal] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + by_cases h1 : i < F.wid hd n * F.fitD + · rw [if_pos h1, ifLtLen_pos (by + rw [List.length_replicate, length_mulLen, hm, List.length_replicate] + exact h1)] + by_cases h2 : v + i / F.fitD * n < F.fitN hd n + · rw [if_pos h2, ifLtLen_pos (by rw [hlift, hN]; exact h2)] + have hidx : (mulLen (List.replicate v true + ++ mulLen (divC F.fitD (List.replicate i true)) (List.replicate n true)) + (List.replicate F.fitD true) ++ modC F.fitD (List.replicate i true)).length + = (v + i / F.fitD * n) * F.fitD + i % F.fitD := by + rw [List.length_append, length_mulLen, hlift, List.length_replicate, hc, + List.length_replicate] + have hclt : i % F.fitD < F.deg ^ 2 := Nat.mod_lt _ hdpos + have hbound : (v + i / F.fitD * n) * F.fitD + i % F.fitD + < F.size (F.fitLevel hd n) * F.deg ^ 2 := by + have hfitN : F.fitN hd n = F.size (F.fitLevel hd n) := rfl + rw [hfitN] at h2 + have hsucc : (v + i / F.fitD * n) + 1 ≤ F.size (F.fitLevel hd n) := h2 + have hclt' : i % F.fitD < F.fitD := Nat.mod_lt _ hdpos + show (v + i / F.fitD * n) * F.fitD + i % F.fitD < F.size (F.fitLevel hd n) * F.fitD + calc (v + i / F.fitD * n) * F.fitD + i % F.fitD + < (v + i / F.fitD * n) * F.fitD + F.fitD := by omega + _ = ((v + i / F.fitD * n) + 1) * F.fitD := by ring + _ ≤ F.size (F.fitLevel hd n) * F.fitD := Nat.mul_le_mul_right _ hsucc + rw [hT, hidx, F.tableFst_table hbound, F.tableSnd_table hbound, + show F.deg ^ 2 = F.fitD from rfl, + mul_add_div_of_lt hdpos (Nat.mod_lt _ hdpos), mul_add_mod_of_lt (Nat.mod_lt _ hdpos)] + congr 1 + · rw [marks_eq, modFn2_eq (by rw [hrep]; exact hn), + List.length_replicate, hrep, List.length_replicate] + · rw [marks_eq, List.length_append, List.length_replicate, + length_mulC, divFn2_eq (by rw [hrep]; exact hn), List.length_replicate, hrep, + List.length_replicate] + congr 1 + ring + · rw [if_neg h2, ifLtLen_neg (by rw [hlift, hN]; exact h2)] + congr 1 + · rw [marks_eq, List.length_replicate] + · rw [marks_eq, List.length_replicate] + · rw [if_neg h1, ifLtLen_neg (by + rw [List.length_replicate, length_mulLen, hm, List.length_replicate] + exact h1)] + congr 1 + · rw [marks_eq, List.length_replicate] + · rw [marks_eq, List.length_replicate] + +end FinBase + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgFormula.lean b/Complexitylib/Classes/PCP/Internal/AlgFormula.lean new file mode 100644 index 00000000..e75df63a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgFormula.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.SAT.ThreeSAT.Completeness +public import Complexitylib.Classes.PCP.Internal.AlgUniform + +/-! +# Every NP language, as a formula + +Cook--Levin and Tseitin already reduce any `NP` language to encoded 3SAT. What +the gap reduction needs is slightly more: not a string that *lies in* 3SAT, but +the *formula itself*, so that the constraint graph can be built from it. + +The Tseitin reduction is total — malformed inputs go to a fixed unsatisfiable +formula — so the formula is always there to be named: `redCNF` names it, and +`reduction_eq_encode` says the reduction writes exactly its encoding. + +## Main definitions + +- `Complexity.redCNF` — the 3CNF a string reduces to + +## Main results + +- `Complexity.exists_reduction_cnf` — every `NP` language is the satisfiability + of an `FP` family of 3CNFs +-/ + +@[expose] public section + +namespace Complexity + +open SAT SAT.ThreeSAT + +/-- The exact 3-CNF that the total Tseitin reduction produces. -/ +noncomputable def redCNF (z : List Bool) : CNF := + match CNF.decode? z with + | some φ => (CNF.to3Aux (z.length + 1) φ).1 + | none => falseFormula + +theorem reduction_eq_encode (z : List Bool) : reduction z = (redCNF z).encode := by + rw [reduction, redCNF] + cases CNF.decode? z with + | none => rfl + | some φ => rfl + +theorem redCNF_is3CNF (z : List Bool) : (redCNF z).Is3CNF := by + rw [redCNF] + cases CNF.decode? z with + | none => exact falseFormula_is3CNF + | some φ => exact CNF.to3Aux_is3CNF _ φ + +theorem satisfiable_redCNF_iff (z : List Bool) : + (redCNF z).Satisfiable ↔ z ∈ CNFSAT.language := by + cases hdecode : CNF.decode? z with + | none => + have hz : z ∉ CNFSAT.language := by + rw [CNFSAT.mem_language_iff_decode] + rintro ⟨φ, hφ, _⟩ + rw [hdecode] at hφ + exact absurd hφ (by simp) + rw [show redCNF z = falseFormula by rw [redCNF, hdecode]] + simp only [hz, iff_false] + exact falseFormula_not_satisfiable + | some φ => + have hz : z = φ.encode := CNF.decode?_sound hdecode + have hfresh : φ.maxVar < z.length + 1 := by + have hmax := CNF.maxVar_le_encode_length φ + rw [hz] + omega + rw [show redCNF z = (CNF.to3Aux (z.length + 1) φ).1 by rw [redCNF, hdecode], + CNF.to3Aux_satisfiable_iff _ φ hfresh, CNFSAT.mem_language_iff_decode] + constructor + · exact fun h => ⟨φ, hdecode, h⟩ + · rintro ⟨ψ, hψ, hsat⟩ + rw [hdecode] at hψ + exact (Option.some.inj hψ) ▸ hsat + +/-- **Every `NP` language is the satisfiability of an `FP` family of exact +3-CNFs.** -/ +theorem exists_reduction_cnf {L : Language} (hL : L ∈ NP) : + ∃ (E : List Bool → List Bool) (Φ : List Bool → CNF), E ∈ FP + ∧ (∀ x, E x = (Φ x).encode) ∧ (∀ x, (Φ x).Is3CNF) + ∧ (∀ x, x ∈ L ↔ (Φ x).Satisfiable) := by + obtain ⟨f, hf, hiff⟩ := SAT.NPHard_language L hL + refine ⟨fun x => reduction (f x), fun x => redCNF (f x), ?_, fun x => reduction_eq_encode _, + fun x => redCNF_is3CNF _, fun x => ?_⟩ + · exact mem_FP_of_eq (mem_FP_comp hf ThreeSAT.reduction_mem_FP) fun x => rfl + · rw [hiff x, ← satisfiable_redCNF_iff (f x)] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgGap.lean b/Complexitylib/Classes/PCP/Internal/AlgGap.lean new file mode 100644 index 00000000..1b8377f7 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgGap.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgRound +public import Complexitylib.Classes.PCP.Internal.AlgLog + +/-! +# Amplifying, logarithmically many times + +`AlgRound` computes one round. Dinur's theorem runs logarithmically many, so +this module iterates that function and bounds the size of what it writes: each +round multiplies the edge count by a constant, so after `n` rounds the graph is +`edgeFactor ^ n` times as large, and the ruler keeps `n` logarithmic. + +## Main definitions + +- `Complexity.gapFn` — the amplified graph, as a string + +## Main results + +- `Complexity.numEdges_iterStep` — a round's edge count, exactly +- `Complexity.length_encGraph_iterStep_le` — the size of what is written +- `Complexity.gapFn_eq` — it writes the amplifier's iterate +-/ + +@[expose] public section + +set_option maxRecDepth 8000 + +namespace Complexity + +open Dinur Tester + +variable (F : FinBase) (hd : 1 < F.deg) + +/-! ### The sizes of an iterate -/ + +theorem numEdges_iterStep (G : ConstraintGraph DinurAlpha) (n : ℕ) : + ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G).numEdges + = edgeFactor (F.toFamily hd) (qOf F hd) ^ n * G.numEdges := by + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply', Dinur.numEdges_step, ih, pow_succ] + ring + +theorem one_le_edgeFactor : 1 ≤ edgeFactor (F.toFamily hd) (qOf F hd) := by + rw [edgeFactor] + have h1 : 0 < powDeg (F.toFamily hd) ^ powT K (qOf F hd) * qOf F hd ^ powT K (qOf F hd) := + Nat.mul_pos (Nat.pow_pos (by rw [powDeg]; omega)) (Nat.pow_pos (qOf_pos F hd)) + have h2 : 0 < 2 ^ ROf (bits (F.toFamily hd) (powT K (qOf F hd))) := Nat.two_pow_pos _ + have := Nat.mul_pos (Nat.mul_pos (Nat.mul_pos (by omega : 0 < 2) h1) h2) (by omega : 0 < 22) + omega + +theorem numVerts_iterStep_le (G : ConstraintGraph DinurAlpha) (n : ℕ) : + ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G).numVerts + ≤ G.numVerts + vertFactor (F.toFamily hd) (qOf F hd) + * (edgeFactor (F.toFamily hd) (qOf F hd) ^ n * G.numEdges) := by + cases n with + | zero => simp + | succ n => + rw [Function.iterate_succ_apply', Dinur.numVerts_step, numEdges_iterStep] + refine le_trans (Nat.mul_le_mul_left _ (Nat.mul_le_mul_right _ ?_)) (Nat.le_add_left _ _) + exact Nat.pow_le_pow_right (one_le_edgeFactor F hd) (Nat.le_succ n) + +theorem size_mono {V V' E E' C : ℕ} (h : V' ≤ V) (hE : E' ≤ E) : + 2 * V' + 4 + E' * (8 * V' + 4 * C + 10) ≤ 2 * V + 4 + E * (8 * V + 4 * C + 10) := by + have h1 : 8 * V' + 4 * C + 10 ≤ 8 * V + 4 * C + 10 := by omega + have h2 := Nat.mul_le_mul hE h1 + omega + +/-- **The size of what a round writes.** -/ +theorem length_encGraph_iterStep_le (G : ConstraintGraph DinurAlpha) (n : ℕ) : + (encGraph ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G)).length + ≤ 2 * (G.numVerts + vertFactor (F.toFamily hd) (qOf F hd) + * (edgeFactor (F.toFamily hd) (qOf F hd) ^ n * G.numEdges)) + 4 + + edgeFactor (F.toFamily hd) (qOf F hd) ^ n * G.numEdges + * (8 * (G.numVerts + vertFactor (F.toFamily hd) (qOf F hd) + * (edgeFactor (F.toFamily hd) (qOf F hd) ^ n * G.numEdges)) + + 4 * Fintype.card (DinurAlpha → DinurAlpha → Bool) + 10) := by + have hV := numVerts_iterStep_le F hd G n + have hE := numEdges_iterStep F hd G n + refine le_trans (length_encGraph_le _) ?_ + rw [hE] + exact size_mono hV (le_refl _) + +/-- **The size of what a round writes**, in terms of a bound on the growth +factor, so that one bound serves every round of the iteration. -/ +theorem length_encGraph_iterStep_le' (G : ConstraintGraph DinurAlpha) (n r B : ℕ) + (hn : n ≤ r) (hB : edgeFactor (F.toFamily hd) (qOf F hd) ^ r ≤ B) : + (encGraph ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G)).length + ≤ 2 * (G.numVerts + vertFactor (F.toFamily hd) (qOf F hd) * (B * G.numEdges)) + 4 + + B * G.numEdges + * (8 * (G.numVerts + vertFactor (F.toFamily hd) (qOf F hd) * (B * G.numEdges)) + + 4 * Fintype.card (DinurAlpha → DinurAlpha → Bool) + 10) := by + have hpow : edgeFactor (F.toFamily hd) (qOf F hd) ^ n ≤ B := + le_trans (Nat.pow_le_pow_right (one_le_edgeFactor F hd) hn) hB + have hV : ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G).numVerts + ≤ G.numVerts + vertFactor (F.toFamily hd) (qOf F hd) * (B * G.numEdges) := + le_trans (numVerts_iterStep_le F hd G n) + (Nat.add_le_add_left (Nat.mul_le_mul_left _ (Nat.mul_le_mul_right _ hpow)) _) + have hE : ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G).numEdges + ≤ B * G.numEdges := by + rw [numEdges_iterStep] + exact Nat.mul_le_mul_right _ hpow + exact le_trans (length_encGraph_le _) (size_mono hV hE) + +/-- The amplifier's round is the round the algorithm computes. -/ +theorem transform_amplifier : + (Dinur.amplifier (F.toFamily hd)).transform + = Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd) := by + dsimp only [Dinur.amplifier, qOf] + +/-- **So the amplifier's iterate is the algorithm's.** -/ +theorem iter_amplifier (G : ConstraintGraph DinurAlpha) (k : ℕ) : + (Dinur.amplifier (F.toFamily hd)).iter k G + = (Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[k] G := by + rw [Amplifier.iter, transform_amplifier] + +/-- **The size of what a round writes**, from numeric bounds alone: a caller +supplies bounds on the graph it starts from and on the growth factor. -/ +theorem length_encGraph_iterStep_le'' (G : ConstraintGraph DinurAlpha) (n r B V m : ℕ) + (hn : n ≤ r) (hB : edgeFactor (F.toFamily hd) (qOf F hd) ^ r ≤ B) + (hV : G.numVerts ≤ V) (hm : G.numEdges ≤ m) : + (encGraph ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G)).length + ≤ 2 * (V + vertFactor (F.toFamily hd) (qOf F hd) * (B * m)) + 4 + + B * m + * (8 * (V + vertFactor (F.toFamily hd) (qOf F hd) * (B * m)) + + 4 * Fintype.card (DinurAlpha → DinurAlpha → Bool) + 10) := by + refine le_trans (length_encGraph_iterStep_le' F hd G n r B hn hB) (size_mono ?_ ?_) + · exact Nat.add_le_add hV (Nat.mul_le_mul_left _ (Nat.mul_le_mul_left _ hm)) + · exact Nat.mul_le_mul_left _ hm + +/-! ### The iteration -/ + +/-- **The amplified graph, as a string**: as many rounds as the ruler is long. -/ +noncomputable def gapFn (init ruler : List Bool → List Bool) (z : List Bool) : List Bool := + (roundFn F hd)^[(ruler z).length] (init z) + +/-- **What it writes**: the amplifier's iterate on whatever graph the start +writes. -/ +theorem gapFn_eq {init ruler : List Bool → List Bool} {z : List Bool} + {G : ConstraintGraph DinurAlpha} (h : init z = encGraph G) : + gapFn F hd init ruler z + = encGraph ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[(ruler z).length] G) := by + rw [gapFn, h] + exact iterate_encGraph (roundFn_eq F hd) _ G + +/-- **And writing it is polynomial-time.** -/ +theorem gapFn_mem_FP {init ruler width : List Bool → List Bool} + (hinit : init ∈ FP) (hruler : ruler ∈ FP) (hwidth : width ∈ FP) + (hinitG : ∀ z, ∃ G : ConstraintGraph DinurAlpha, init z = encGraph G) + (hbound : ∀ (z : List Bool) (G : ConstraintGraph DinurAlpha), init z = encGraph G → + ∀ n ≤ (ruler z).length, + (encGraph ((Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[n] G)).length + ≤ (width z).length) : + gapFn F hd init ruler ∈ FP := + iterate_mem_FP_encGraph (roundFn_mem_FP F hd) hinit hruler hwidth + (roundFn_eq F hd) hinitG hbound + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgGapAll.lean b/Complexitylib/Classes/PCP/Internal/AlgGapAll.lean new file mode 100644 index 00000000..ecead708 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgGapAll.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgGap +public import Complexitylib.Classes.PCP.Internal.AlgInit +public import Complexitylib.Classes.PCP.Internal.AlgFormula +public import Complexitylib.Classes.PCP.Internal.AlgUniform + +/-! +# The gap graph of an input + +Everything the reduction does, in one function: read the formula, write its +constraint graph padded to a size the input's length decides, and amplify it as +many times as a logarithmic ruler is long. + +## Main definitions + +- `Complexity.gapAllG` — the graph itself +- `Complexity.gapAll` — that graph, as a string + +## Main results + +- `Complexity.gapAll_eq` — the string is the graph's encoding +- `Complexity.satisfiable_gapAllG` — completeness +- `Complexity.gap_le_unsatVal_gapAllG` — soundness +-/ + +@[expose] public section + +set_option maxRecDepth 8000 + +namespace Complexity + +open Dinur SAT + +variable (F : FinBase) (hd : 1 < F.deg) (E padU : List Bool → List Bool) + {Φ : List Bool → CNF} + +/-- How many rounds an input gets: enough that the padded edge count is below +`2 ^ rounds`. -/ +noncomputable def gapRuler (x : List Bool) : List Bool := logRuler (padU x) + +theorem gapRuler_mem_FP (hpad : padU ∈ FP) : gapRuler padU ∈ FP := + mem_FP_of_eq (mem_FP_comp hpad logRuler_mem_FP) fun _ => rfl + +@[simp] theorem length_gapRuler (x : List Bool) : + (gapRuler padU x).length = rulerLen (padU x).length := by + rw [gapRuler, length_logRuler] + +/-- **The gap graph of an input.** -/ +noncomputable def gapAllG (x : List Bool) : ConstraintGraph DinurAlpha := + (Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd))^[rulerLen (padU x).length] + ((baseCSP (Φ x)).padGraph (numVerts_baseCSP_pos (Φ x)) (padU x).length) + +/-- **The gap graph of an input, as a string.** -/ +noncomputable def gapAll : List Bool → List Bool := + gapFn F hd (basePadFn E padU baseCodeFn) (gapRuler padU) + +theorem gapAll_eq (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hmark : ∀ x, padU x = List.replicate (padU x).length true) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) (x : List Bool) : + gapAll F hd E padU x = encGraph (gapAllG F hd padU (Φ := Φ) x) := by + rw [gapAll, gapFn_eq F hd (basePadFn_eq E hE h3 x (hmark x) (hle x)), gapAllG, + length_gapRuler] + +/-! ### The gap -/ + +theorem numEdges_padded_le (x : List Bool) (hle : 3 * (Φ x).length ≤ (padU x).length) : + ((baseCSP (Φ x)).padGraph (numVerts_baseCSP_pos (Φ x)) (padU x).length).numEdges + ≤ 2 ^ rulerLen (padU x).length := by + rw [ConstraintGraph.numEdges_padGraph, numEdges_baseCSP, max_eq_left (by omega)] + exact le_of_lt (lt_two_pow_rulerLen _) + +/-- **Completeness.** -/ +theorem satisfiable_gapAllG (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) (x : List Bool) + (h : (Φ x).Satisfiable) : (gapAllG F hd padU (Φ := Φ) x).Satisfiable := by + have hd' := (Amplifier.dichotomy (Dinur.amplifier (F.toFamily hd)) _ + (numEdges_padded_le padU x (hle x))).1 + rw [iter_amplifier] at hd' + exact hd' (ConstraintGraph.satisfiable_padGraph_iff.mpr ((satisfiable_baseCSP_iff (h3 x)).mpr h)) + +/-- **Soundness.** -/ +theorem gap_le_unsatVal_gapAllG (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) (x : List Bool) + (h : ¬ (Φ x).Satisfiable) : + (Dinur.amplifier (F.toFamily hd)).gap ≤ (gapAllG F hd padU (Φ := Φ) x).unsatVal := by + have hd' := (Amplifier.dichotomy (Dinur.amplifier (F.toFamily hd)) _ + (numEdges_padded_le padU x (hle x))).2 + rw [iter_amplifier] at hd' + exact hd' fun hs => h ((satisfiable_baseCSP_iff (h3 x)).mp + (ConstraintGraph.satisfiable_padGraph_iff.mp hs)) + +/-! ### Writing it is polynomial-time -/ + +/-- The exponent by which the whole iteration can grow the graph. -/ +noncomputable def growthExp : ℕ := rulerLen (edgeFactor (F.toFamily hd) (qOf F hd)) + +theorem pow_edgeFactor_le (m : ℕ) : + edgeFactor (F.toFamily hd) (qOf F hd) ^ rulerLen m ≤ (2 * m + 1) ^ growthExp F hd := by + calc edgeFactor (F.toFamily hd) (qOf F hd) ^ rulerLen m + ≤ (2 ^ growthExp F hd) ^ rulerLen m := + Nat.pow_le_pow_left (le_of_lt (lt_two_pow_rulerLen _)) _ + _ = (2 ^ rulerLen m) ^ growthExp F hd := by + rw [← pow_mul, ← pow_mul, Nat.mul_comm] + _ ≤ (2 * m + 1) ^ growthExp F hd := + Nat.pow_le_pow_left (two_pow_rulerLen_le m) _ + +/-- How wide the iteration ever gets. -/ +noncomputable def widthPoly (p₀ q : Polynomial ℕ) : Polynomial ℕ := + 2 * (2 * p₀ + 1 + + Polynomial.C (vertFactor (F.toFamily hd) (qOf F hd)) + * ((2 * q + 1) ^ growthExp F hd * q)) + 4 + + (2 * q + 1) ^ growthExp F hd * q + * (8 * (2 * p₀ + 1 + + Polynomial.C (vertFactor (F.toFamily hd) (qOf F hd)) + * ((2 * q + 1) ^ growthExp F hd * q)) + + Polynomial.C (4 * Fintype.card (DinurAlpha → DinurAlpha → Bool)) + 10) + + +/-- How wide the iteration ever gets, as a function of the input's length. The +round's constants are parameters, so that no tactic here ever meets them. -/ +def widthFn (p₀ q : Polynomial ℕ) (v cw d : ℕ) (n : ℕ) : ℕ := + 2 * (2 * p₀.eval n + 1 + v * ((2 * q.eval n + 1) ^ d * q.eval n)) + 4 + + (2 * q.eval n + 1) ^ d * q.eval n + * (8 * (2 * p₀.eval n + 1 + v * ((2 * q.eval n + 1) ^ d * q.eval n)) + cw) + +theorem widthFn_hasRuler (p₀ q : Polynomial ℕ) (v cw d : ℕ) : + HasRuler (widthFn p₀ q v cw d) := by + have hm : HasRuler fun n => q.eval n := HasRuler.of_poly q + have hV : HasRuler fun n => 2 * p₀.eval n + 1 := + HasRuler.add (HasRuler.mul (HasRuler.const 2) (HasRuler.of_poly p₀)) (HasRuler.const 1) + have hB : HasRuler fun n => (2 * q.eval n + 1) ^ d := + HasRuler.pow (HasRuler.add (HasRuler.mul (HasRuler.const 2) hm) (HasRuler.const 1)) _ + have hBm := HasRuler.mul hB hm + have hA := HasRuler.add hV (HasRuler.mul (HasRuler.const v) hBm) + exact HasRuler.add (HasRuler.add (HasRuler.mul (HasRuler.const 2) hA) (HasRuler.const 4)) + (HasRuler.mul hBm (HasRuler.add (HasRuler.mul (HasRuler.const 8) hA) (HasRuler.const cw))) + +set_option maxRecDepth 100000 in +/-- **Writing the gap graph is polynomial-time.** -/ +theorem gapAll_mem_FP (hEfp : E ∈ FP) (hpad : padU ∈ FP) + (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hmark : ∀ x, padU x = List.replicate (padU x).length true) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) (p₀ q : Polynomial ℕ) + (hp₀ : ∀ x, (E x).length ≤ p₀.eval x.length) + (hq : ∀ x, (padU x).length = q.eval x.length) : + gapAll F hd E padU ∈ FP := by + obtain ⟨R, hR, hRlen⟩ := widthFn_hasRuler p₀ q (vertFactor (F.toFamily hd) (qOf F hd)) + (4 * Fintype.card (DinurAlpha → DinurAlpha → Bool) + 10) (growthExp F hd) + refine gapFn_mem_FP F hd (basePadFn_mem_FP E hEfp hpad _) (gapRuler_mem_FP padU hpad) hR + (fun z => ⟨_, basePadFn_eq E hE h3 z (hmark z) (hle z)⟩) ?_ + intro z G hG n hn + have hsame : encGraph G + = encGraph ((baseCSP (Φ z)).padGraph (numVerts_baseCSP_pos (Φ z)) (padU z).length) := by + rw [← hG, basePadFn_eq E hE h3 z (hmark z) (hle z)] + have hV : G.numVerts + = ((baseCSP (Φ z)).padGraph (numVerts_baseCSP_pos (Φ z)) (padU z).length).numVerts := by + rw [← gVerts_encGraph (G := G), hsame, gVerts_encGraph] + have hEd : G.numEdges + = ((baseCSP (Φ z)).padGraph (numVerts_baseCSP_pos (Φ z)) (padU z).length).numEdges := by + rw [← gEdges_encGraph (G := G), hsame, gEdges_encGraph] + have hmq : G.numEdges = q.eval z.length := by + rw [hEd, ConstraintGraph.numEdges_padGraph, numEdges_baseCSP, + max_eq_left (by have := hle z; omega), hq] + have hVle : G.numVerts ≤ 2 * p₀.eval z.length + 1 := by + have h1 := CNF.maxVar_le_encode_length (Φ z) + have h2 := length_le_length_encode (Φ z) + have h3' := hp₀ z + rw [hE z] at h3' + have hvv : G.numVerts = (Φ z).maxVar + 1 + (Φ z).length := by + rw [hV] + rfl + omega + have hn' : n ≤ rulerLen (padU z).length := by + rwa [length_gapRuler] at hn + have hB : edgeFactor (F.toFamily hd) (qOf F hd) ^ rulerLen (padU z).length + ≤ (2 * q.eval z.length + 1) ^ growthExp F hd := by + rw [← hq] + exact pow_edgeFactor_le F hd _ + refine le_trans (length_encGraph_iterStep_le'' F hd G n _ _ _ _ hn' hB hVle + (le_of_eq hmq)) (le_trans (le_of_eq ?_) (hRlen z)) + rw [widthFn] + ring + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean b/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean new file mode 100644 index 00000000..c415b21a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgGapAll +public import Complexitylib.Classes.PCP.Internal.BaseAlg + +/-! +# The gap graph, as an algorithm + +The verifier does not read a graph; it reads *an algorithm* that answers three +questions about one — how many edges, where an edge's ends are, and whether a +pair of symbols satisfies it. This module packages the gap graph that way, by +reading the string the reduction writes. + +The constraint is a bounded-key decision: an edge's record names its constraint +by a code, and the code, together with the two symbol blocks, is all the +constraint depends on. Both are clamped to constant width, so the key is +constant-size even on strings that are not graphs at all. + +## Main definitions + +- `Complexity.gapAlg` — the gap graph as an `AlgCSP` + +## Main results + +- `Complexity.gapAlg_models` — it agrees with the gap graph +-/ + +@[expose] public section + +set_option maxRecDepth 8000 + +namespace Complexity + +open SAT + +variable (F : FinBase) (hd : 1 < F.deg) (E padU : List Bool → List Bool) + +/-! ### Reading the graph -/ + +/-- The graph string a verifier argument names. -/ +noncomputable def gapStr (z : List Bool) : List Bool := + gapAll F hd E padU (Cobham.fstBlock (Cobham.fstBlock z)) + +theorem gapStr_mem_FP (hgap : gapAll F hd E padU ∈ FP) : gapStr F hd E padU ∈ FP := + mem_FP_of_eq (mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP) hgap) + fun _ => rfl + +/-- The code of the constraint the argument names, clamped to the number of +constraints there are. -/ +noncomputable def gapCodeBlk (z : List Bool) : List Bool := + (recThd (Cobham.sndBlock (gapStr F hd E padU z)) + (Cobham.sndBlock (Cobham.fstBlock z)).length).take cRel + +theorem gapCodeBlk_mem_FP (hgap : gapAll F hd E padU ∈ FP) : + gapCodeBlk F hd E padU ∈ FP := by + have hidx : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) fun _ => rfl + have hrec := gCodeFn_mem_FP hidx (gapStr_mem_FP F hd E padU hgap) + refine mem_FP_of_eq (Cobham.takeLenFn_mem_FP + (constFn_mem_FP (List.replicate cRel false)) hrec) fun z => ?_ + rw [gapCodeBlk, List.length_replicate] + +/-- Everything the constraint depends on: the code and the two symbol blocks. -/ +noncomputable def gapOkKey (z : List Bool) : List Bool := + pair (gapCodeBlk F hd E padU z) ((Cobham.sndBlock z).take 46) + +theorem gapOkKey_mem_FP (hgap : gapAll F hd E padU ∈ FP) : gapOkKey F hd E padU ∈ FP := + Cobham.pairFn_mem_FP (gapCodeBlk_mem_FP F hd E padU hgap) + (mem_FP_of_eq (Cobham.takeLenFn_mem_FP + (constFn_mem_FP (List.replicate 46 false)) Cobham.sndBlock_mem_FP) + fun z => by rw [List.length_replicate]) + +theorem gapOkKey_length_le (z : List Bool) : + (gapOkKey F hd E padU z).length ≤ 2 * cRel + 48 := by + have h1 : (gapCodeBlk F hd E padU z).length ≤ cRel := by + rw [gapCodeBlk, List.length_take] + omega + have h2 : ((Cobham.sndBlock z).take 46).length ≤ 46 := by + rw [List.length_take] + omega + rw [gapOkKey, pair_length] + omega + +/-- What the constraint says, of the key alone. -/ +def gapOkPred (k : List Bool) : Prop := + relOfCode DinurAlpha (Cobham.fstBlock k).length + (symDec DinurAlpha ((Cobham.sndBlock k).take 23)) + (symDec DinurAlpha ((Cobham.sndBlock k).drop 23)) = true + +/-- The constraint, as a language on the verifier's verdict argument. -/ +noncomputable def gapOk : Language := + {z : List Bool | gapOkPred (gapOkKey F hd E padU z)} + +theorem gapOk_mem_P (hgap : gapAll F hd E padU ∈ FP) : gapOk F hd E padU ∈ P := + mem_P_of_bounded_key (gapOkKey_mem_FP F hd E padU hgap) + (gapOkKey_length_le F hd E padU) gapOkPred + +/-! ### The record -/ + +/-- **The gap graph as an algorithm.** -/ +noncomputable def gapAlg (hgap : gapAll F hd E padU ∈ FP) : AlgCSP where + numEdges x := gEdges (gapAll F hd E padU x) + numEdges_mem := by + refine mem_FP_of_eq (marks_mem_FP (gEdgesFn_mem_FP hgap)) fun x => ?_ + rw [marks_eq, length_posCount_sndBlock] + width := 23 + width_pos := by omega + vert b x e := + cond b (gHead (gapAll F hd E padU x) e) (gTail (gapAll F hd E padU x) e) + vert_mem := by + intro b + have hg : (fun w : List Bool => gapAll F hd E padU (Cobham.fstBlock w)) ∈ FP := + mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP hgap) fun _ => rfl + cases b + · refine mem_FP_of_eq (marks_mem_FP (gTailFn_mem_FP Cobham.sndBlock_mem_FP hg)) + fun w => ?_ + simp only [cond_false] + rw [marks_eq, length_recFst_sndBlock] + · refine mem_FP_of_eq (marks_mem_FP (gHeadFn_mem_FP Cobham.sndBlock_mem_FP hg)) + fun w => ?_ + simp only [cond_true] + rw [marks_eq, length_recSnd_sndBlock] + ok := gapOk F hd E padU + ok_mem := gapOk_mem_P F hd E padU hgap + +@[simp] theorem numEdges_gapAlg (hgap : gapAll F hd E padU ∈ FP) (x : List Bool) : + (gapAlg F hd E padU hgap).numEdges x = gEdges (gapAll F hd E padU x) := rfl + +@[simp] theorem width_gapAlg (hgap : gapAll F hd E padU ∈ FP) : + (gapAlg F hd E padU hgap).width = 23 := rfl + +theorem vert_gapAlg_false (hgap : gapAll F hd E padU ∈ FP) (x : List Bool) (e : ℕ) : + (gapAlg F hd E padU hgap).vert false x e = gTail (gapAll F hd E padU x) e := by + simp only [gapAlg, cond_false] + +theorem vert_gapAlg_true (hgap : gapAll F hd E padU ∈ FP) (x : List Bool) (e : ℕ) : + (gapAlg F hd E padU hgap).vert true x e = gHead (gapAll F hd E padU x) e := by + simp only [gapAlg, cond_true] + +@[simp] theorem ok_gapAlg (hgap : gapAll F hd E padU ∈ FP) : + (gapAlg F hd E padU hgap).ok = gapOk F hd E padU := rfl + +/-! ### It models the gap graph -/ + +variable {Φ : List Bool → CNF} + +theorem gapCodeBlk_length (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hmark : ∀ x, padU x = List.replicate (padU x).length true) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) (x : List Bool) (e : ℕ) + (he : e < (gapAllG F hd padU (Φ := Φ) x).numEdges) (a : List Bool) : + (gapCodeBlk F hd E padU (pair (pair x (List.replicate e true)) a)).length + = codeOfRel ((gapAllG F hd padU (Φ := Φ) x).rel ⟨e, he⟩) := by + have hcode : (recThd (Cobham.sndBlock (gapAll F hd E padU x)) e).length + = codeOfRel ((gapAllG F hd padU (Φ := Φ) x).rel ⟨e, he⟩) := by + rw [length_recThd_sndBlock, gapAll_eq F hd E padU hE h3 hmark hle x, gCode_encGraph] + have hlt : codeOfRel ((gapAllG F hd padU (Φ := Φ) x).rel ⟨e, he⟩) < cRel := by + rw [cRel_eq] + exact codeOfRel_lt _ + rw [gapCodeBlk, gapStr, Cobham.fstBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, List.length_replicate, List.length_take, hcode] + omega + +/-- **The algorithm models the gap graph.** -/ +theorem gapAlg_models (hgap : gapAll F hd E padU ∈ FP) + (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hmark : ∀ x, padU x = List.replicate (padU x).length true) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) : + (gapAlg F hd E padU hgap).Models (fun x => gapAllG F hd padU (Φ := Φ) x) + (symEnc DinurAlpha 23) (symDec DinurAlpha) where + numEdges_eq x := by + rw [numEdges_gapAlg, gapAll_eq F hd E padU hE h3 hmark hle x, gEdges_encGraph] + tail_eq x e he := by + rw [vert_gapAlg_false, gapAll_eq F hd E padU hE h3 hmark hle x, gTail_encGraph _ e he] + head_eq x e he := by + rw [vert_gapAlg_true, gapAll_eq F hd E padU hE h3 hmark hle x, gHead_encGraph _ e he] + length_enc := length_symEnc_gapAlpha + dec_enc := symDec_symEnc_gapAlpha + ok_iff x e he u v hu hv := by + rw [width_gapAlg] at hu hv + have ha : (u ++ v).length = 46 := by + rw [List.length_append, hu, hv] + have htake : (u ++ v).take 23 = u := by + rw [← hu, List.take_left] + have hdrop : (u ++ v).drop 23 = v := by + rw [← hu, List.drop_left] + have hcode := gapCodeBlk_length F hd E padU hE h3 hmark hle x e he (u ++ v) + have htake46 : (u ++ v).take 46 = u ++ v := List.take_of_length_le (by omega) + show gapOkPred (gapOkKey F hd E padU (pair (pair x (List.replicate e true)) (u ++ v))) ↔ _ + rw [gapOkPred, gapOkKey, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hcode, + Cobham.sndBlock_pair, htake46, htake, hdrop, relOfCode_codeOfRel] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgGraph.lean b/Complexitylib/Classes/PCP/Internal/AlgGraph.lean new file mode 100644 index 00000000..db43e8bf --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgGraph.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.UnaryList +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph +public import Complexitylib.Classes.PCP.Internal.Materialize + +/-! +# A constraint graph as a string + +An algorithm that runs Dinur's amplification has to hold a constraint graph in +its hand. Over a fixed finite alphabet a graph is a small amount of data: how +many vertices, and for each edge its two endpoints and its constraint. The +endpoints are numbers below the vertex count, and the constraint — a predicate +on two symbols — is itself one of finitely many, so it too is a number. + +That is the encoding used here: the vertex count in unary, followed by a list of +records, each three unary numbers. Numbering the constraints rather than +tabulating them keeps every record a triple of numbers, so the whole toolkit of +`UnaryList` applies; and because the number of constraints is a constant, +reading one back is a lookup on a bounded key. + +## Main definitions + +- `Complexity.relOfCode`, `Complexity.codeOfRel` — numbering the constraints +- `Complexity.encGraph` — the graph as a string +- `Complexity.gVerts`, `gEdges`, `gTail`, `gHead`, `gCode` — reading it back + +## Main results + +- `Complexity.gVerts_encGraph`, `gEdges_encGraph`, `gTail_encGraph`, + `gHead_encGraph`, `gRel_encGraph` — the reading inverts the writing +- `Complexity.buildGraph_eq`, `Complexity.buildGraph_mem_FP` — a rule for each + edge writes the graph, in polynomial time +-/ + +@[expose] public section + +namespace Complexity + +/-! ### Numbering the constraints -/ + +variable {α : Type} [Fintype α] [DecidableEq α] + +/-- The constraint a code stands for; the always-false constraint for a code +that is out of range. -/ +noncomputable def relOfCode (α : Type) [Fintype α] [DecidableEq α] (r : ℕ) : α → α → Bool := + if h : r < Fintype.card (α → α → Bool) then (Fintype.equivFin (α → α → Bool)).symm ⟨r, h⟩ + else fun _ _ => false + +/-- The code of a constraint. -/ +noncomputable def codeOfRel (f : α → α → Bool) : ℕ := (Fintype.equivFin (α → α → Bool) f).val + +theorem codeOfRel_lt (f : α → α → Bool) : + codeOfRel f < Fintype.card (α → α → Bool) := Fin.isLt _ + +@[simp] theorem relOfCode_codeOfRel (f : α → α → Bool) : relOfCode α (codeOfRel f) = f := by + rw [relOfCode, dif_pos (codeOfRel_lt f)] + simp only [codeOfRel, Fin.eta, Equiv.symm_apply_apply] + +/-! ### The encoding -/ + +/-- One record for each edge: its two endpoints and the code of its +constraint. -/ +noncomputable def edgeRecs (G : ConstraintGraph α) : List (List Bool × List Bool × List Bool) := + (List.finRange G.numEdges).map fun e => + (List.replicate (G.tail e).val true, + List.replicate (G.head e).val true, List.replicate (codeOfRel (G.rel e)) true) + +@[simp] theorem length_edgeRecs (G : ConstraintGraph α) : + (edgeRecs G).length = G.numEdges := by + rw [edgeRecs, List.length_map, List.length_finRange] + +/-- **A constraint graph, as a string.** -/ +noncomputable def encGraph (G : ConstraintGraph α) : List Bool := + pair (List.replicate G.numVerts true) (DataEncode.bitstringEncode (edgeRecs G)) + +/-! ### Reading it back -/ + +/-- How many vertices an encoded graph has. -/ +def gVerts (z : List Bool) : ℕ := (Cobham.fstBlock z).length + +/-- How many edges. -/ +noncomputable def gEdges (z : List Bool) : ℕ := (posCount (Cobham.sndBlock z)).length + +/-- The first endpoint of an edge. -/ +noncomputable def gTail (z : List Bool) (e : ℕ) : ℕ := (recFst (Cobham.sndBlock z) e).length + +/-- The second endpoint. -/ +noncomputable def gHead (z : List Bool) (e : ℕ) : ℕ := (recSnd (Cobham.sndBlock z) e).length + +/-- The code of the constraint. -/ +noncomputable def gCode (z : List Bool) (e : ℕ) : ℕ := (recThd (Cobham.sndBlock z) e).length + +variable (G : ConstraintGraph α) + +@[simp] theorem gVerts_encGraph : gVerts (encGraph G) = G.numVerts := by + rw [gVerts, encGraph, Cobham.fstBlock_pair, List.length_replicate] + +@[simp] theorem gEdges_encGraph : gEdges (encGraph G) = G.numEdges := by + rw [gEdges, encGraph, Cobham.sndBlock_pair, posCount_eq, List.length_replicate, + length_edgeRecs] + +theorem getElem_edgeRecs (e : ℕ) (he : e < G.numEdges) : + (edgeRecs G)[e]'(by rw [length_edgeRecs]; exact he) + = (List.replicate (G.tail ⟨e, he⟩).val true, + List.replicate (G.head ⟨e, he⟩).val true, + List.replicate (codeOfRel (G.rel ⟨e, he⟩)) true) := by + simp only [edgeRecs, List.getElem_map, List.getElem_finRange] + rfl + +@[simp] theorem gTail_encGraph (e : ℕ) (he : e < G.numEdges) : + gTail (encGraph G) e = (G.tail ⟨e, he⟩).val := by + rw [gTail, encGraph, Cobham.sndBlock_pair, + recFst_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact he) (getElem_edgeRecs G e he), + List.length_replicate] + +@[simp] theorem gHead_encGraph (e : ℕ) (he : e < G.numEdges) : + gHead (encGraph G) e = (G.head ⟨e, he⟩).val := by + rw [gHead, encGraph, Cobham.sndBlock_pair, + recSnd_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact he) (getElem_edgeRecs G e he), + List.length_replicate] + +theorem gCode_encGraph (e : ℕ) (he : e < G.numEdges) : + gCode (encGraph G) e = codeOfRel (G.rel ⟨e, he⟩) := by + rw [gCode, encGraph, Cobham.sndBlock_pair, + recThd_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact he) (getElem_edgeRecs G e he), + List.length_replicate] + +/-- **The constraint of an edge survives the round trip.** -/ +theorem gRel_encGraph (e : ℕ) (he : e < G.numEdges) : + relOfCode α (gCode (encGraph G) e) = G.rel ⟨e, he⟩ := by + rw [gCode_encGraph G e he, relOfCode_codeOfRel] + +/-- **How long a graph's encoding is**, in terms of its two counts. -/ +theorem length_encGraph_le (G : ConstraintGraph α) : + (encGraph G).length + ≤ 2 * G.numVerts + 4 + + G.numEdges * (8 * G.numVerts + 4 * Fintype.card (α → α → Bool) + 10) := by + have hsum : ((edgeRecs G).map fun a => (DataEncode.bitstringEncode a).length).sum + ≤ G.numEdges * (8 * G.numVerts + 4 * Fintype.card (α → α → Bool) + 10) := by + refine le_trans (List.sum_le_card_nsmul _ + (8 * G.numVerts + 4 * Fintype.card (α → α → Bool) + 10) ?_) ?_ + · intro x hx + obtain ⟨e, he, rfl⟩ := List.mem_map.mp hx + obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp he + rw [length_edgeRecs] at hi + rw [getElem_edgeRecs G i hi, ← encTriple_eq, length_encTriple] + have h1 := (G.tail ⟨i, hi⟩).isLt + have h2 := (G.head ⟨i, hi⟩).isLt + have h3 := codeOfRel_lt (G.rel ⟨i, hi⟩) + omega + · rw [List.length_map, length_edgeRecs, smul_eq_mul] + rw [encGraph, pair_length, List.length_replicate, length_bitstringEncode_list] + omega + +/-! ### Writing one out -/ + +/-- A graph assembled from a vertex count, an edge count and a rule for each +edge record. -/ +noncomputable def buildGraph (nv cnt E : List Bool → List Bool) (z : List Bool) : List Bool := + pair (nv z) (listEncFn E (pair (cnt z) z)) + +theorem buildGraph_mem_FP {nv cnt E : List Bool → List Bool} (hnv : nv ∈ FP) + (hcnt : cnt ∈ FP) (hE : E ∈ FP) : buildGraph nv cnt E ∈ FP := by + have harg := Cobham.pairFn_mem_FP hcnt id_mem_FP + have hlist := mem_FP_comp harg (materialize_mem_FP hE) + exact mem_FP_of_eq (Cobham.pairFn_mem_FP hnv hlist) fun _ => rfl + +/-- **The rule writes the graph.** -/ +theorem buildGraph_eq {nv cnt E : List Bool → List Bool} {z : List Bool} + {G : ConstraintGraph α} (hnv : nv z = List.replicate G.numVerts true) + (hcnt : cnt z = List.replicate G.numEdges true) + (hE : ∀ (e : ℕ) (he : e < G.numEdges), + E (pair z (List.replicate e true)) + = encTriple (List.replicate (G.tail ⟨e, he⟩).val true) + (List.replicate (G.head ⟨e, he⟩).val true) + (List.replicate (codeOfRel (G.rel ⟨e, he⟩)) true)) : + buildGraph nv cnt E z = encGraph G := by + rw [buildGraph, encGraph, hnv, hcnt, ← length_edgeRecs G] + refine congrArg _ (materialize_eq (edgeRecs G) z fun i hi => ?_) + rw [length_edgeRecs] at hi + rw [hE i hi, encTriple_eq, getElem_edgeRecs G i hi] + +/-! ### Reading one, in polynomial time -/ + +theorem gVertsFn_mem_FP {g : List Bool → List Bool} (hg : g ∈ FP) : + (fun z => marks (Cobham.fstBlock (g z))) ∈ FP := + marks_mem_FP (mem_FP_comp hg Cobham.fstBlock_mem_FP) + +theorem gEdgesFn_mem_FP {g : List Bool → List Bool} (hg : g ∈ FP) : + (fun z => posCount (Cobham.sndBlock (g z))) ∈ FP := + posCount_mem_FP (mem_FP_comp hg Cobham.sndBlock_mem_FP) + +theorem gTailFn_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => recFst (Cobham.sndBlock (g z)) (f z).length) ∈ FP := + recFst_mem_FP hf (mem_FP_comp hg Cobham.sndBlock_mem_FP) + +theorem gHeadFn_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => recSnd (Cobham.sndBlock (g z)) (f z).length) ∈ FP := + recSnd_mem_FP hf (mem_FP_comp hg Cobham.sndBlock_mem_FP) + +theorem gCodeFn_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => recThd (Cobham.sndBlock (g z)) (f z).length) ∈ FP := + recThd_mem_FP hf (mem_FP_comp hg Cobham.sndBlock_mem_FP) + +theorem length_marks_fstBlock (z : List Bool) : + (marks (Cobham.fstBlock z)).length = gVerts z := by + rw [marks_eq, List.length_replicate, gVerts] + +theorem length_posCount_sndBlock (z : List Bool) : + (posCount (Cobham.sndBlock z)).length = gEdges z := rfl + +theorem length_recFst_sndBlock (z : List Bool) (e : ℕ) : + (recFst (Cobham.sndBlock z) e).length = gTail z e := rfl + +theorem length_recSnd_sndBlock (z : List Bool) (e : ℕ) : + (recSnd (Cobham.sndBlock z) e).length = gHead z e := rfl + +theorem length_recThd_sndBlock (z : List Bool) (e : ℕ) : + (recThd (Cobham.sndBlock z) e).length = gCode z e := rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgInit.lean b/Complexitylib/Classes/PCP/Internal/AlgInit.lean new file mode 100644 index 00000000..48a3a562 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgInit.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.BaseAlg +public import Complexitylib.Classes.PCP.Internal.AlgGraph +public import Complexitylib.Classes.PCP.Internal.PadGraph + +/-! +# The starting graph, written out + +`BaseAlg` reads the starting graph's numbers straight off a formula, which is +all a verifier needs. Amplification needs more: the graph itself, as a string +the round function can consume. This module writes it, reusing that module's +readers. + +An edge's constraint depends on the formula only through the three signs of its +clause and which of the three positions the edge checks — twelve bits in all. +That is what `baseCodeKey` extracts and `relOfSigns` turns back into a +constraint, so the constraint's code is written by a table lookup. + +## Main definitions + +- `Complexity.relOfSigns` — an edge's constraint, as a function of the signs +- `Complexity.baseCodeKey` — the bounded data an edge's constraint depends on +- `Complexity.baseGraphFn` — the starting graph, as a string + +## Main results + +- `Complexity.rel_baseCSP` — the constraint depends only on the signs +- `Complexity.baseGraphFn_mem_FP` — writing the graph is polynomial-time +- `Complexity.baseGraphFn_eq` — it writes the right graph +-/ + +@[expose] public section + +namespace Complexity + +open SAT ThreeSATCSP + +variable (E : List Bool → List Bool) + +/-! ### The constraint, from the signs alone -/ + +open Classical in +/-- The constraint of an edge that checks position `p` of a clause whose three +literals have signs `s`: both endpoints name triples in the image of the +alphabet embedding, the first satisfies the clause, and the two agree on the +checked position. -/ +noncomputable def relOfSigns (s : Fin 3 → Bool) (p : Fin 3) : GapAlpha → GapAlpha → Bool := + fun u v => decide (∃ a₁ a₂ : Fin 3 → Bool, alphaEmb a₁ = u ∧ alphaEmb a₂ = v ∧ + (∃ q : Fin 3, a₁ q = s q) ∧ a₁ p = a₂ 0) + +/-- **The constraint depends only on the signs.** -/ +theorem rel_baseCSP (φ : CNF) (e : ℕ) (he : e < (baseCSP φ).numEdges) : + (baseCSP φ).rel ⟨e, he⟩ + = relOfSigns (fun q => (litOf φ (e / 3) q).sign) ⟨e % 3, Nat.mod_lt _ (by omega)⟩ := by + funext u v + show (ConstraintGraph.lift (toGraph φ) alphaEmb).rel ⟨e, he⟩ u v = _ + rw [ConstraintGraph.rel_lift, relOfSigns] + refine decide_eq_decide.mpr ⟨?_, ?_⟩ + · rintro ⟨a₁, a₂, h1, h2, hr⟩ + replace hr : (clauseSat φ (edgeClause e) a₁ && (a₁ (edgePos e) == a₂ 0)) = true := hr + rw [Bool.and_eq_true, clauseSat_eq_true_iff, beq_iff_eq] at hr + exact ⟨a₁, a₂, h1, h2, hr.1, hr.2⟩ + · rintro ⟨a₁, a₂, h1, h2, hq, hagree⟩ + refine ⟨a₁, a₂, h1, h2, ?_⟩ + show (clauseSat φ (edgeClause e) a₁ && (a₁ (edgePos e) == a₂ 0)) = true + rw [Bool.and_eq_true, clauseSat_eq_true_iff, beq_iff_eq] + exact ⟨hq, hagree⟩ + +/-! ### The key -/ + +/-- The data an edge's constraint depends on: the clause's three signs and +which of them the edge reads. -/ +noncomputable def baseCodeKey (w : List Bool) : List Bool := + pair (baseSigns E (pair w [])) + (modFn [false, false, false] (Cobham.sndBlock w)) + +theorem baseCodeKey_mem_FP (hE : E ∈ FP) : baseCodeKey E ∈ FP := by + have harg : (fun w : List Bool => pair w []) ∈ FP := + Cobham.pairFn_mem_FP id_mem_FP (constFn_mem_FP []) + have hsigns : (fun w : List Bool => baseSigns E (pair w [])) ∈ FP := by + refine mem_FP_of_eq (mem_FP_comp harg (baseSigns_mem_FP E hE)) fun w => ?_ + rw [Function.comp_apply] + have hmod : (fun w : List Bool => modFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + refine mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP + (modFn_mem_FP [false, false, false])) fun w => ?_ + rw [Function.comp_apply] + exact Cobham.pairFn_mem_FP hsigns hmod + +theorem baseCodeKey_length_le (w : List Bool) : (baseCodeKey E w).length ≤ 12 := by + have hs : (baseSigns E (pair w [])).length ≤ 3 := length_baseSigns_le E _ + have hm : (modFn [false, false, false] (Cobham.sndBlock w)).length ≤ 2 := by + rw [modFn_eq (by simp), List.length_replicate] + have : (Cobham.sndBlock w).length % [false, false, false].length < 3 := by + simpa using Nat.mod_lt _ (by omega) + omega + rw [baseCodeKey, pair_length] + omega + +variable {Φ : List Bool → CNF} + +theorem baseCodeKey_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) {e : ℕ} (he : e < 3 * (Φ x).length) : + baseCodeKey E (pair x (List.replicate e true)) + = pair [(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, + (litOf (Φ x) (e / 3) 2).sign] (List.replicate (e % 3) true) := by + rw [baseCodeKey, baseSigns_pair E hE h3 x he [], Cobham.sndBlock_pair, + modFn_eq (by simp) (List.replicate e true), List.length_replicate, + show ([false, false, false] : List Bool).length = 3 from rfl] + +/-! ### The constraint's code, from the key -/ + +/-- The constraint an edge's key stands for. -/ +noncomputable def baseRelOfKey (k : List Bool) : GapAlpha → GapAlpha → Bool := + relOfSigns (fun q => (Cobham.fstBlock k).getD q.val false) + ⟨(Cobham.sndBlock k).length % 3, Nat.mod_lt _ (by omega)⟩ + +/-- The constraint's code, in unary, from the key. -/ +noncomputable def baseCodeFn (k : List Bool) : List Bool := + List.replicate (codeOfRel (baseRelOfKey k)) true + +theorem relOfSigns_congr {s t : Fin 3 → Bool} {m n : ℕ} (hm : m < 3) (hn : n < 3) + (hs : s = t) (h : m = n) : relOfSigns s ⟨m, hm⟩ = relOfSigns t ⟨n, hn⟩ := by + subst hs + subst h + rfl + +theorem baseCodeFn_codeKey (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) (e : ℕ) (he : e < (baseCSP (Φ x)).numEdges) : + baseCodeFn (baseCodeKey E (pair x (List.replicate e true))) + = List.replicate (codeOfRel ((baseCSP (Φ x)).rel ⟨e, he⟩)) true := by + have he' : e < 3 * (Φ x).length := by rwa [numEdges_baseCSP] at he + have hrel : baseRelOfKey (baseCodeKey E (pair x (List.replicate e true))) + = relOfSigns (fun q => (litOf (Φ x) (e / 3) q).sign) + ⟨e % 3, Nat.mod_lt _ (by omega)⟩ := by + rw [baseRelOfKey] + refine relOfSigns_congr _ _ ?_ ?_ + · rw [baseCodeKey_pair E hE h3 x he', Cobham.fstBlock_pair] + funext q + fin_cases q <;> rfl + · rw [baseCodeKey_pair E hE h3 x he', Cobham.sndBlock_pair, List.length_replicate] + omega + rw [baseCodeFn, hrel, rel_baseCSP] + +/-! ### The counts -/ + +/-- The number of vertices, in unary: one per variable, one per clause. -/ +noncomputable def baseVertsU (z : List Bool) : List Bool := + marks (baseMaxU E z) ++ [true] ++ divC 3 (baseEdgesU E z) + +theorem baseVertsU_mem_FP (hE : E ∈ FP) : baseVertsU E ∈ FP := + Cobham.appendFn_mem_FP + (Cobham.appendFn_mem_FP (marks_mem_FP (baseMaxU_mem_FP E hE)) (constFn_mem_FP [true])) + (divC_mem_FP (baseEdgesU_mem_FP E hE) 3) + +theorem baseVertsU_eq (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) : + baseVertsU E x = List.replicate (baseCSP (Φ x)).numVerts true := by + have hnv : (baseCSP (Φ x)).numVerts = ((Φ x).maxVar + 1) + (Φ x).length := rfl + rw [baseVertsU, marks_eq, baseMaxU_eq E hE h3, baseEdgesU_eq E hE, divC_eq (by omega), + List.length_replicate, Nat.mul_div_cancel_left _ (by omega), hnv] + rw [show ([true] : List Bool) = List.replicate 1 true from rfl, + ← List.replicate_add, ← List.replicate_add] + +theorem baseEdgesU_count (hE : ∀ x, E x = (Φ x).encode) (x : List Bool) : + baseEdgesU E x = List.replicate (baseCSP (Φ x)).numEdges true := by + rw [baseEdgesU_eq E hE, numEdges_baseCSP] + +/-! ### The endpoints -/ + +theorem baseTailU_val (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) (e : ℕ) (he : e < (baseCSP (Φ x)).numEdges) : + (baseTailU E (pair x (List.replicate e true))).length + = ((baseCSP (Φ x)).tail ⟨e, he⟩).val := by + rw [numEdges_baseCSP] at he + rw [baseTailU_eq E hE h3] + show _ = (clauseVertex (Φ x) (edgeClause e)).val + rw [clauseVertex, edgeClause, dif_pos (by rw [numVerts]; omega)] + +theorem baseHeadU_val (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) (e : ℕ) (he : e < (baseCSP (Φ x)).numEdges) : + (baseHeadU E (pair x (List.replicate e true))).length + = ((baseCSP (Φ x)).head ⟨e, he⟩).val := by + rw [numEdges_baseCSP] at he + have hj : e / 3 < (Φ x).length := by omega + have hp : e % 3 < ((Φ x)[e / 3]'hj).length := by + rw [h3 x _ (List.getElem_mem hj)] + omega + have hvar : (litOf (Φ x) (e / 3) ⟨e % 3, Nat.mod_lt _ (by omega)⟩).var + ≤ (Φ x).maxVar := by + rw [litOf_eq (Φ x) hj _ hp] + exact var_le_maxVar (Φ x) hj hp + rw [baseHeadU_eq E hE h3 x he] + show _ = (varVertex (Φ x) (litOf (Φ x) (edgeClause e) (edgePos e)).var).val + rw [varVertex, edgeClause, edgePos, dif_pos (by rw [numVerts]; omega)] + +/-! ### The graph -/ + +/-- **The starting graph, as a string.** -/ +noncomputable def baseGraphFn (g : List Bool → List Bool) : List Bool → List Bool := + buildGraph (baseVertsU E) (baseEdgesU E) + (fun w => encTriple (marks (baseTailU E w)) (marks (baseHeadU E w)) (g (baseCodeKey E w))) + +theorem baseGraphFn_mem_FP (hE : E ∈ FP) (g : List Bool → List Bool) : + baseGraphFn E g ∈ FP := + buildGraph_mem_FP (baseVertsU_mem_FP E hE) (baseEdgesU_mem_FP E hE) + (encTriple_mem_FP (marks_mem_FP (baseTailU_mem_FP E hE)) + (marks_mem_FP (baseHeadU_mem_FP E hE)) + (mem_FP_of_bounded_key (baseCodeKey_mem_FP E hE) (baseCodeKey_length_le E) g)) + +/-- **The rule writes the starting graph.** -/ +theorem baseGraphFn_eq (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) : baseGraphFn E baseCodeFn x = encGraph (baseCSP (Φ x)) := by + refine buildGraph_eq (baseVertsU_eq E hE h3 x) (baseEdgesU_count E hE x) fun e he => ?_ + rw [marks_eq, marks_eq, baseTailU_val E hE h3 x e he, baseHeadU_val E hE h3 x e he, + baseCodeFn_codeKey E hE h3 x e he] + +/-! ### Padded to a fixed size -/ + +/-- The base graph always has a vertex. -/ +theorem numVerts_baseCSP_pos (φ : CNF) : 0 < (baseCSP φ).numVerts := by + show 0 < ((φ.maxVar + 1) + φ.length) + omega + +/-- The code of the constraint that is always true, in unary. -/ +noncomputable def trivCode : List Bool := + List.replicate (codeOfRel (α := GapAlpha) (fun _ _ => true)) true + +/-- **The starting graph, padded**: the edge count is whatever `padU` says, so it +can be made to depend on the input's length alone. -/ +noncomputable def basePadFn (padU g : List Bool → List Bool) : List Bool → List Bool := + buildGraph (baseVertsU E) padU + (fun w => ifLtLen (Cobham.sndBlock w) (baseEdgesU E (Cobham.fstBlock w)) + (encTriple (marks (baseTailU E w)) (marks (baseHeadU E w)) (g (baseCodeKey E w))) + (encTriple [] [] trivCode)) + +theorem basePadFn_mem_FP (hE : E ∈ FP) (hP : padU ∈ FP) (g : List Bool → List Bool) : + basePadFn E padU g ∈ FP := by + refine buildGraph_mem_FP (baseVertsU_mem_FP E hE) hP (ifLtLen_mem_FP Cobham.sndBlock_mem_FP + ?_ (encTriple_mem_FP (marks_mem_FP (baseTailU_mem_FP E hE)) + (marks_mem_FP (baseHeadU_mem_FP E hE)) + (mem_FP_of_bounded_key (baseCodeKey_mem_FP E hE) (baseCodeKey_length_le E) g)) + (constFn_mem_FP _)) + exact mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP (baseEdgesU_mem_FP E hE)) + fun w => rfl + +/-- **The rule writes the padded starting graph.** -/ +theorem basePadFn_eq (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) (hPmark : padU x = List.replicate (padU x).length true) + (hPle : 3 * (Φ x).length ≤ (padU x).length) : + basePadFn E padU baseCodeFn x + = encGraph ((baseCSP (Φ x)).padGraph (numVerts_baseCSP_pos (Φ x)) (padU x).length) := by + have hmax : max (padU x).length (baseCSP (Φ x)).numEdges = (padU x).length := by + rw [numEdges_baseCSP] + omega + refine buildGraph_eq (baseVertsU_eq E hE h3 x) ?_ fun e he => ?_ + · rw [ConstraintGraph.numEdges_padGraph, hmax] + exact hPmark + · rw [ConstraintGraph.numEdges_padGraph, hmax] at he + have hcnt : (baseEdgesU E (Cobham.fstBlock (pair x (List.replicate e true)))).length + = 3 * (Φ x).length := by + rw [Cobham.fstBlock_pair, baseEdgesU_eq E hE, List.length_replicate] + by_cases hlt : e < (baseCSP (Φ x)).numEdges + · have hlt' : e < 3 * (Φ x).length := by rwa [numEdges_baseCSP] at hlt + rw [ifLtLen_pos (by rw [Cobham.sndBlock_pair, List.length_replicate, hcnt]; exact hlt')] + rw [ConstraintGraph.tail_padGraph_of_lt _ hlt, ConstraintGraph.head_padGraph_of_lt _ hlt, + ConstraintGraph.rel_padGraph_of_lt _ hlt] + rw [marks_eq, marks_eq, baseTailU_val E hE h3 x e hlt, baseHeadU_val E hE h3 x e hlt, + baseCodeFn_codeKey E hE h3 x e hlt] + · rw [ifLtLen_neg (by rw [Cobham.sndBlock_pair, List.length_replicate, hcnt, + numEdges_baseCSP] at *; omega)] + rw [ConstraintGraph.tail_padGraph_of_ge _ hlt, ConstraintGraph.head_padGraph_of_ge _ hlt, + ConstraintGraph.rel_padGraph_of_ge _ hlt, trivCode] + rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgIter.lean b/Complexitylib/Classes/PCP/Internal/AlgIter.lean new file mode 100644 index 00000000..4c491732 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgIter.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgEdge + +/-! +# Iterating a round + +Amplification runs a round logarithmically many times. On the algorithm's side +that is an iteration of one `FP` function; on the abstract side it is +`Amplifier.iter`. This module says the two agree, for any round function that +computes its transformation. + +## Main results + +- `Complexity.iterate_encGraph` — iterating the algorithm writes the iterated + graph +- `Complexity.iterate_mem_FP_encGraph` — and the iteration is an `FP` function +-/ + +@[expose] public section + +namespace Complexity + +variable {α : Type} [Fintype α] [DecidableEq α] + +/-- **Iterating the algorithm writes the iterated graph.** -/ +theorem iterate_encGraph {f : List Bool → List Bool} + {T : ConstraintGraph α → ConstraintGraph α} + (hstep : ∀ G : ConstraintGraph α, f (encGraph G) = encGraph (T G)) : + ∀ (k : ℕ) (G : ConstraintGraph α), f^[k] (encGraph G) = encGraph (T^[k] G) := by + intro k + induction k with + | zero => intro G; rfl + | succ k ih => + intro G + rw [Function.iterate_succ_apply, Function.iterate_succ_apply, hstep, ih] + +/-- **And it writes the amplifier's iterate.** -/ +theorem iterate_encGraph_amplifier [Nonempty α] {f : List Bool → List Bool} + (A : Amplifier α) + (hstep : ∀ G : ConstraintGraph α, f (encGraph G) = encGraph (A.transform G)) : + ∀ (k : ℕ) (G : ConstraintGraph α), f^[k] (encGraph G) = encGraph (A.iter k G) := + iterate_encGraph hstep + +/-- **The iteration is an `FP` function.** The bound the iteration rule wants is +supplied on the *graphs*, where the round's size bounds live, rather than on +their encodings. -/ +theorem iterate_mem_FP_encGraph {f init ruler width : List Bool → List Bool} + {T : ConstraintGraph α → ConstraintGraph α} + (hf : f ∈ FP) (hinit : init ∈ FP) (hruler : ruler ∈ FP) (hwidth : width ∈ FP) + (hstep : ∀ G : ConstraintGraph α, f (encGraph G) = encGraph (T G)) + (hinitG : ∀ z, ∃ G : ConstraintGraph α, init z = encGraph G) + (hbound : ∀ (z : List Bool) (G : ConstraintGraph α), init z = encGraph G → + ∀ n ≤ (ruler z).length, (encGraph (T^[n] G)).length ≤ (width z).length) : + (fun z => f^[(ruler z).length] (init z)) ∈ FP := by + refine Cobham.iterate_mem_FP hf hinit hruler hwidth ?_ + intro z n hn + obtain ⟨G, hG⟩ := hinitG z + rw [hG, iterate_encGraph hstep] + exact hbound z G hG n hn + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgKey.lean b/Complexitylib/Classes/PCP/Internal/AlgKey.lean new file mode 100644 index 00000000..936fb2c5 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgKey.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgPosNum +public import Complexitylib.Classes.PCP.Internal.AlgStep + +/-! +# The bounded data a composed edge depends on + +A composed edge's second endpoint and its constraint depend on the outer graph +only through what one killed walk meets: the darts it takes, the parity of each +vertex it stands on, the code of each constraint there, and the darts it returns +by — together with the random string and the read. All of that lives in finite +types that do not mention the graph, so it is a *key* of bounded length, and the +edge's data is a function of the key alone. + +## Main definitions + +- `Complexity.StepKey` — that data +- `Complexity.packKey`, `Complexity.keyOfString` — writing it out as a string, + and reading it back +- `Complexity.relOfKey` — the constraint it describes +- `Complexity.satSetOfKey` — and the satisfying set + +## Main results + +- `Complexity.keyOfString_packKey` — the reading inverts the writing +- `Complexity.relOfKey_stepKeyOf` — on a walk's own data it is the killed + constraint +- `Complexity.cubeOfKey_eq`, `Complexity.codeOfKey_eq` — so the data alone gives + the composed edge's second endpoint and its constraint +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis Tester + +/-- The bounded data a composed edge's head and constraint depend on. -/ +abbrev StepKey (E : ExpanderFamily) (T q B C : ℕ) : Type := + ((Fin T → PreDart E) × (Fin T → Fin q)) + × ((Fin T → Fin 2) × (Fin T → Fin C)) + × ((Fin T → PreDart E) × (Cube (ROf B) × ReadIdx)) + +namespace StepKey + +variable {E : ExpanderFamily} {T q B C : ℕ} (k : StepKey E T q B C) + +/-- The walk's darts. -/ +def dart : Fin T → PreDart E := k.1.1 + +/-- Its coins. -/ +def coins : Fin T → Fin q := k.1.2 + +/-- The parity of the vertex each step stands on. -/ +def par : Fin T → Fin 2 := k.2.1.1 + +/-- The code of the constraint each step meets. -/ +def code : Fin T → Fin C := k.2.1.2 + +/-- The darts the walk returns by. -/ +def rev : Fin T → PreDart E := k.2.2.1 + +/-- The tester's random string. -/ +def rand : Cube (ROf B) := k.2.2.2.1 + +/-- The read. -/ +def read : ReadIdx := k.2.2.2.2 + +/-- How long the effective walk is. -/ +def len : ℕ := stopAt k.coins + +theorem len_le : k.len ≤ T := stopAt_le _ + +end StepKey + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] + +/-- The constraint the data describes: at each step of the effective walk, the +preprocessed constraint its code and parity stand for. -/ +noncomputable def relOfKey {E : ExpanderFamily} {T q B C : ℕ} (k : StepKey E T q B C) : + (PreWalk E T → α) → (PreWalk E T → α) → Bool := + preRelOfSteps E T E.degree k.len + (fun i => k.dart ⟨i.val, lt_of_lt_of_le i.isLt k.len_le⟩) + (fun i => (k.par ⟨i.val, lt_of_lt_of_le i.isLt k.len_le⟩).val) + (fun i => (k.code ⟨i.val, lt_of_lt_of_le i.isLt k.len_le⟩).val) + (fun i => ⟨⟨i.val, by have := i.isLt; have := k.len_le; omega⟩, + fun j => k.dart ⟨j.val, by have := j.isLt; have := i.isLt; have := k.len_le; omega⟩⟩) + (fun i => ⟨⟨k.len - (i.val + 1), by have := i.isLt; have := k.len_le; omega⟩, + fun j => k.rev ⟨j.val, by have := j.isLt; have := i.isLt; have := k.len_le; omega⟩⟩) + +set_option synthInstance.maxSize 400 in +/-- The satisfying set the data describes. -/ +noncomputable def satSetOfKey {E : ExpanderFamily} {T q B C : ℕ} + (encβ : (PreWalk E T → α) → Cube B) (k : StepKey E T q B C) : + Finset (Cube (kOf B)) := + (Finset.univ.filter fun st : (PreWalk E T → α) × (PreWalk E T → α) => + relOfKey k st.1 st.2 = true).image fun st => RegCSP.inputVec encβ st.1 st.2 + +/-! ### Writing the data out -/ + +/-- The value a number names, or a default. -/ +noncomputable def decOr {X : Type} [NumEnc X] (d : X) (n : ℕ) : X := (NumEnc.dec n).getD d + +theorem decOr_enc {X : Type} [NumEnc X] (d a : X) : decOr d (NumEnc.enc a) = a := by + rw [decOr, NumEnc.dec_enc] + rfl + +variable {E : ExpanderFamily} {T q B C : ℕ} + +/-- The data written out: one unary number per component. -/ +noncomputable def packKey (k : StepKey E T q B C) : List Bool := + pair (pair (List.replicate (NumEnc.enc k.dart) true) + (List.replicate (NumEnc.enc k.coins) true)) + (pair (pair (List.replicate (NumEnc.enc k.par) true) + (List.replicate (NumEnc.enc k.code) true)) + (pair (List.replicate (NumEnc.enc k.rev) true) + (pair (List.replicate (NumEnc.enc k.rand) true) + (List.replicate (NumEnc.enc k.read) true)))) + +/-- The data read back from a string, falling back on a default. -/ +noncomputable def keyOfString (dflt : StepKey E T q B C) (s : List Bool) : + StepKey E T q B C := + ((decOr dflt.dart (Cobham.fstBlock (Cobham.fstBlock s)).length, + decOr dflt.coins (Cobham.sndBlock (Cobham.fstBlock s)).length), + ((decOr dflt.par + (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock s))).length, + decOr dflt.code + (Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock s))).length), + (decOr dflt.rev (Cobham.fstBlock (Cobham.sndBlock (Cobham.sndBlock s))).length, + (decOr dflt.rand (Cobham.fstBlock (Cobham.sndBlock + (Cobham.sndBlock (Cobham.sndBlock s)))).length, + decOr dflt.read (Cobham.sndBlock (Cobham.sndBlock + (Cobham.sndBlock (Cobham.sndBlock s)))).length)))) + +/-- **The reading inverts the writing.** -/ +theorem keyOfString_packKey (dflt k : StepKey E T q B C) : + keyOfString dflt (packKey k) = k := by + rw [keyOfString, packKey] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, decOr_enc] + rfl + +/-- **A digit sum is a tuple's number**, when the digits are the entries'. -/ +theorem length_digitSum_eq_enc {X : Type} [NumEnc X] {T : ℕ} (s : Fin T → X) + (digit : ℕ → List Bool → List Bool) (w : List Bool) + (h : ∀ (j : ℕ) (hj : j < T), (digit j w).length = NumEnc.enc (s ⟨j, hj⟩)) : + (digitSum (NumEnc.card X) digit T w).length = NumEnc.enc s := by + rw [length_digitSum] + show _ = ∑ j ∈ Finset.range T, NumEnc.encAt s j * NumEnc.card X ^ j + refine Finset.sum_congr rfl fun j hj => ?_ + rw [Finset.mem_range] at hj + rw [h j hj, NumEnc.encAt, dif_pos hj] + +/-- The data a killed walk actually shows. -/ +noncomputable def stepKeyOf (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (B : ℕ) (z : Cube (ROf B)) (i : ReadIdx) : + StepKey E T q B (Fintype.card (α → α → Bool)) := + ((x.1, x.2), + ((fun j => if h : j.val < (G.preprocess E).graph.kLen x then + ⟨NumEnc.enc ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) j.val) % 2, Nat.mod_lt _ (by omega)⟩ + else 0, + fun j => if h : j.val < (G.preprocess E).graph.kLen x then + ⟨codeOfRel (G.rel ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) j.val).1), codeOfRel_lt _⟩ + else 0), + ((G.preprocess E).graph.killedRev v x.1 x.2, (z, i)))) + +omit [Nonempty α] in +/-- **The data a walk shows describes that walk's constraint.** -/ +theorem relOfKey_stepKeyOf (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (B : ℕ) (z : Cube (ROf B)) (i : ReadIdx) : + relOfKey (α := α) (stepKeyOf G E v x B z i) + = ((G.preprocess E).killedPow q T hq).rel v x := by + rw [rel_killedPow_eq_preRelOfSteps, relOfKey] + simp only [stepKeyOf, StepKey.dart, StepKey.par, StepKey.code, StepKey.rev, StepKey.coins, + StepKey.len, RegGraph.kLen, RegGraph.kWalk, Fin.is_lt, dif_pos] + congr 1 + funext i + congr 1 + funext j + rw [RegGraph.killedRev, RegGraph.extWalk] + dsimp only + rw [dif_pos (by have := j.isLt; omega)] + +set_option synthInstance.maxSize 400 in +omit [Nonempty α] in +/-- **The data a walk shows describes that walk's satisfying set.** -/ +theorem satSetOfKey_stepKeyOf (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + {B : ℕ} (z : Cube (ROf B)) (i : ReadIdx) (encβ : (PreWalk E T → α) → Cube B) : + satSetOfKey encβ (stepKeyOf G E v x B z i) + = ((G.preprocess E).killedPow q T hq).satSet encβ (v, x) := by + show (Finset.univ.filter fun st : (PreWalk E T → α) × (PreWalk E T → α) => + relOfKey (stepKeyOf G E v x B z i) st.1 st.2 = true).image + (fun st => RegCSP.inputVec encβ st.1 st.2) = _ + rw [relOfKey_stepKeyOf (hq := hq)] + rfl + +/-- The cube the data names. -/ +noncomputable def cubeOfKey {E : ExpanderFamily} {T q B C : ℕ} + (encβ : (PreWalk E T → α) → Cube B) (k : StepKey E T q B C) : ℕ := + RegCSP.cubeOfSet (satSetOfKey encβ k) k.rand k.read + +/-- The constraint code the data names. -/ +noncomputable def codeOfKey {E : ExpanderFamily} {T q B C : ℕ} + (encβ : (PreWalk E T → α) → Cube B) (k : StepKey E T q B C) : ℕ := + codeOfRel (MultiTest.relOfCheck (RegCSP.checkOfSet (satSetOfKey encβ k) k.rand) k.read) + +omit [Nonempty α] in +/-- **The data gives the composed edge's cube.** -/ +theorem cubeOfKey_eq (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + {B : ℕ} (z : Cube (ROf B)) (i : ReadIdx) (encβ : (PreWalk E T → α) → Cube B) : + cubeOfKey encβ (stepKeyOf G E v x B z i) + = ((G.preprocess E).killedPow q T hq).cubeNum encβ (v, x) z i := by + rw [cubeOfKey, satSetOfKey_stepKeyOf G E hq v x z i encβ, + RegCSP.cubeNum_eq_cubeOfSet] + rfl + +omit [Nonempty α] in +/-- **And the composed edge's constraint.** -/ +theorem codeOfKey_eq (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + {B : ℕ} (z : Cube (ROf B)) (i : ReadIdx) (encβ : (PreWalk E T → α) → Cube B) : + codeOfKey encβ (stepKeyOf G E v x B z i) + = codeOfRel (MultiTest.relOfCheck + ((((G.preprocess E).killedPow q T hq).compose encβ).check (v, x) z) i) := by + rw [codeOfKey, satSetOfKey_stepKeyOf G E hq v x z i encβ, + RegCSP.check_eq_checkOfSet] + rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean b/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean new file mode 100644 index 00000000..b8a3ddeb --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean @@ -0,0 +1,672 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgKey +public import Complexitylib.Classes.PCP.Internal.AlgKilled + +/-! +# Reading an edge's data off the input + +The constants of a round — the expander's degree, the walk's length, the killing +rate, how many constraints the alphabet has, how many random strings the tester +uses — are fixed. Given them, an edge number of the composed graph splits by +division into a test, a random string and a read; the test splits into a vertex +and a killed dart; and the killed dart drives the walk, whose parities, codes +and return darts are what the edge's data is made of. + +This module writes that out as `FP` functions. + +## Main definitions + +- `Complexity.Round` — the constants of a round +- `Complexity.keyFn` — the edge's data, as a string + +## Main results + +- `Complexity.keyFn_mem_FP` — it is an `FP` function +- `Complexity.keyFn_length_le` — of bounded length, whatever the input +- `Complexity.keyFn_eq` — on a real edge it writes that edge's own data +- `Complexity.cubeFn_eq`, `Complexity.codeFn_eq` — so the composed edge's second + endpoint and its constraint are `FP` functions of the input +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis Tester + +/-- The constants of one round of amplification, as an algorithm sees them. -/ +structure Round where + /-- The expander's degree. -/ + deg : ℕ + /-- The preprocessed system's degree. -/ + P : ℕ + /-- The walk's length. -/ + T : ℕ + /-- The killing rate. -/ + q : ℕ + /-- How many constraints there are on the alphabet. -/ + C : ℕ + /-- How many random strings the tester has. -/ + cZ : ℕ + +namespace Round + +variable (r : Round) + +/-- How many darts the powered graph has at a vertex. -/ +def cD : ℕ := r.P ^ r.T * r.q ^ r.T + +/-- How many coin tuples there are. -/ +def cQ : ℕ := r.q ^ r.T + +end Round + +variable (F : FinBase) (pol : Polynomial ℕ) (r : Round) + +/-! ### Splitting an edge number -/ + +/-- The test an edge belongs to. -/ +noncomputable def testFn (w : List Bool) : List Bool := + divC (r.cZ * 22) (Cobham.sndBlock w) + +/-- The random string it runs on. -/ +noncomputable def randFn (w : List Bool) : List Bool := + divC 22 (modC (r.cZ * 22) (Cobham.sndBlock w)) + +/-- The read it asks for. -/ +noncomputable def readFn (w : List Bool) : List Bool := modC 22 (Cobham.sndBlock w) + +/-- The killed dart the test is. -/ +noncomputable def dartFn (w : List Bool) : List Bool := modC r.cD (testFn r w) + +/-- The vertex it starts at. -/ +noncomputable def vertFn (w : List Bool) : List Bool := divC r.cD (testFn r w) + +/-- The walk's steps. -/ +noncomputable def stepsFn (w : List Bool) : List Bool := divC r.cQ (dartFn r w) + +/-- The walk's coins. -/ +noncomputable def coinFn (w : List Bool) : List Bool := modC r.cQ (dartFn r w) + +/-- The input the walk algorithm reads. -/ +noncomputable def walkArg (w : List Bool) : List Bool := + pair (Cobham.fstBlock w) (pair (vertFn r w) (stepsFn r w)) + +/-- The input the killed-walk algorithms read. -/ +noncomputable def killArg (w : List Bool) : List Bool := + pair (Cobham.fstBlock w) (pair (vertFn r w) (dartFn r w)) + +theorem testFn_mem_FP : testFn r ∈ FP := divC_mem_FP Cobham.sndBlock_mem_FP _ + +theorem randFn_mem_FP : randFn r ∈ FP := + divC_mem_FP (modC_mem_FP Cobham.sndBlock_mem_FP _) _ + +theorem readFn_mem_FP : readFn ∈ FP := modC_mem_FP Cobham.sndBlock_mem_FP _ + +theorem dartFn_mem_FP : dartFn r ∈ FP := modC_mem_FP (testFn_mem_FP r) _ + +theorem vertFn_mem_FP : vertFn r ∈ FP := divC_mem_FP (testFn_mem_FP r) _ + +theorem stepsFn_mem_FP : stepsFn r ∈ FP := divC_mem_FP (dartFn_mem_FP r) _ + +theorem coinFn_mem_FP : coinFn r ∈ FP := modC_mem_FP (dartFn_mem_FP r) _ + +theorem walkArg_mem_FP : walkArg r ∈ FP := + Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP + (Cobham.pairFn_mem_FP (vertFn_mem_FP r) (stepsFn_mem_FP r)) + +theorem killArg_mem_FP : killArg r ∈ FP := + Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP + (Cobham.pairFn_mem_FP (vertFn_mem_FP r) (dartFn_mem_FP r)) + +/-! ### The walk's data -/ + +/-- Where the walk stops. -/ +noncomputable def stopBlk (w : List Bool) : List Bool := + stopFn r.q (coinsOf r.q r.T) 0 r.T (killArg r w) + +theorem stopBlk_mem_FP : stopBlk r ∈ FP := + mem_FP_of_eq (mem_FP_comp (killArg_mem_FP r) + (stopFn_mem_FP (coinsOf_mem_FP r.q r.T) r.T 0)) fun _ => rfl + +/-- The parity of the vertex the `i`-th step stands on, and `0` past the end. -/ +noncomputable def parDigit (i : ℕ) (w : List Bool) : List Bool := + ifLtLen (List.replicate i true) (stopBlk r w) + (modC 2 (walkFn F pol r.deg r.P i (walkArg r w))) [] + +theorem parDigit_mem_FP (i : ℕ) : parDigit F pol r i ∈ FP := + ifLtLen_mem_FP (constFn_mem_FP _) (stopBlk_mem_FP r) + (modC_mem_FP (mem_FP_of_eq + (mem_FP_comp (walkArg_mem_FP r) (walkFn_mem_FP F pol r.deg r.P i)) fun _ => rfl) 2) + (constFn_mem_FP []) + +/-- The code of the constraint the `i`-th step meets, and `0` past the end. -/ +noncomputable def codeDigit (i : ℕ) (w : List Bool) : List Bool := + ifLtLen (List.replicate i true) (stopBlk r w) + ((recThd (Cobham.sndBlock (Cobham.fstBlock w)) + (divC 2 (walkFn F pol r.deg r.P i (walkArg r w))).length).take r.C) [] + +theorem codeDigit_mem_FP (i : ℕ) : codeDigit F pol r i ∈ FP := by + have hwalk : (fun w : List Bool => walkFn F pol r.deg r.P i (walkArg r w)) ∈ FP := + mem_FP_of_eq (mem_FP_comp (walkArg_mem_FP r) (walkFn_mem_FP F pol r.deg r.P i)) + fun _ => rfl + have hcode : (fun w : List Bool => recThd (Cobham.sndBlock (Cobham.fstBlock w)) + (divC 2 (walkFn F pol r.deg r.P i (walkArg r w))).length) ∈ FP := + gCodeFn_mem_FP (divC_mem_FP hwalk 2) Cobham.fstBlock_mem_FP + refine ifLtLen_mem_FP (constFn_mem_FP _) (stopBlk_mem_FP r) ?_ (constFn_mem_FP []) + have := Cobham.takeLenFn_mem_FP (constFn_mem_FP (List.replicate r.C true)) hcode + refine mem_FP_of_eq this fun w => ?_ + rw [List.length_replicate] + +/-! ### The data as a string -/ + +/-- **An edge's data**, written out as the seven blocks `packKey` expects. -/ +noncomputable def keyFn (w : List Bool) : List Bool := + pair (pair (stepsFn r w) (coinFn r w)) + (pair (pair (marks (digitSum 2 (parDigit F pol r) r.T w)) + (marks (digitSum r.C (codeDigit F pol r) r.T w))) + (pair ((revNumFn F pol r.deg r.P r.T r.q (killArg r w)).take (r.P ^ r.T)) + (pair (randFn r w) (readFn w)))) + +theorem keyFn_mem_FP : keyFn F pol r ∈ FP := by + refine Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP (stepsFn_mem_FP r) (coinFn_mem_FP r)) + (Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP (marks_mem_FP (digitSum_mem_FP (parDigit_mem_FP F pol r) r.T)) + (marks_mem_FP (digitSum_mem_FP (codeDigit_mem_FP F pol r) r.T))) + (Cobham.pairFn_mem_FP ?_ (Cobham.pairFn_mem_FP (randFn_mem_FP r) readFn_mem_FP))) + have hrev : (fun w : List Bool => revNumFn F pol r.deg r.P r.T r.q (killArg r w)) ∈ FP := + mem_FP_of_eq (mem_FP_comp (killArg_mem_FP r) + (revNumFn_mem_FP F pol r.deg r.P r.T r.q)) fun _ => rfl + have := Cobham.takeLenFn_mem_FP (constFn_mem_FP (List.replicate (r.P ^ r.T) true)) hrev + refine mem_FP_of_eq this fun w => ?_ + rw [List.length_replicate] + +/-! ### What the blocks read -/ + +/-- **The blocks split an edge number.** -/ +theorem blocks_eq (hD : 0 < r.cD) (hZ : 0 < r.cZ) (g : List Bool) (a b c d : ℕ) + (hb : b < r.cD) (hc : c < r.cZ) (hd : d < 22) : + testFn r (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) + = List.replicate (a * r.cD + b) true + ∧ vertFn r (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) + = List.replicate a true + ∧ dartFn r (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) + = List.replicate b true + ∧ randFn r (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) + = List.replicate c true + ∧ readFn (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) + = List.replicate d true := by + have hre : ((a * r.cD + b) * r.cZ + c) * 22 + d + = (a * r.cD + b) * (r.cZ * 22) + (c * 22 + d) := by ring + obtain ⟨h1, h2, h3⟩ := MultiTest.split_mixed (a := a * r.cD + b) hc hd + rw [← hre] at h1 h2 h3 + have htest : testFn r (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) + = List.replicate (a * r.cD + b) true := by + rw [testFn, Cobham.sndBlock_pair, divC_eq (by positivity), List.length_replicate, h1] + refine ⟨htest, ?_, ?_, ?_, ?_⟩ + · rw [vertFn, htest, divC_eq hD, List.length_replicate, Nat.add_comm, + Nat.add_mul_div_right _ _ hD, Nat.div_eq_of_lt hb, Nat.zero_add] + · rw [dartFn, htest, modC_eq hD, List.length_replicate, Nat.add_comm, + Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hb] + · rw [randFn, Cobham.sndBlock_pair, modC_eq (by positivity), List.length_replicate, + divC_eq (by omega), List.length_replicate, h2] + · rw [readFn, Cobham.sndBlock_pair, modC_eq (by omega), List.length_replicate, h3] + +/-- **The dart block splits into steps and coins.** -/ +theorem steps_coin_eq (hQ : 0 < r.cQ) (w : List Bool) (s t : ℕ) (ht : t < r.cQ) + (hdart : dartFn r w = List.replicate (s * r.cQ + t) true) : + stepsFn r w = List.replicate s true ∧ coinFn r w = List.replicate t true := by + constructor + · rw [stepsFn, hdart, divC_eq hQ, List.length_replicate, Nat.add_comm, + Nat.add_mul_div_right _ _ hQ, Nat.div_eq_of_lt ht, Nat.zero_add] + · rw [coinFn, hdart, modC_eq hQ, List.length_replicate, Nat.add_comm, + Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt ht] + +/-- **The walk's input**, once the blocks are known. -/ +theorem walkArg_eq {w g : List Bool} {a s : ℕ} (hg : Cobham.fstBlock w = g) + (hv : vertFn r w = List.replicate a true) + (hs : stepsFn r w = List.replicate s true) : + walkArg r w = pair g (pair (List.replicate a true) (List.replicate s true)) := by + rw [walkArg, hg, hv, hs] + +/-- **The killed walk's input**, likewise. -/ +theorem killArg_eq {w g : List Bool} {a b : ℕ} (hg : Cobham.fstBlock w = g) + (hv : vertFn r w = List.replicate a true) + (hb : dartFn r w = List.replicate b true) : + killArg r w = pair g (pair (List.replicate a true) (List.replicate b true)) := by + rw [killArg, hg, hv, hb] + +/-! ### The walk, on encoded vertices -/ + +variable {α : Type} [Fintype α] [DecidableEq α] + +variable {F pol} in +/-- **The walk algorithm, run on a dart's own numbers.** -/ +theorem walkFn_enc (hd : 1 < F.deg) (G : ConstraintGraph α) {T q : ℕ} + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin T → Fin q)) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (j : ℕ) (hj : j ≤ (G.preprocess (F.toFamily hd)).graph.kLen x) : + walkFn F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) j + (pair (encGraph G) (pair (List.replicate (NumEnc.enc v) true) + (List.replicate (NumEnc.enc x.1) true))) + = List.replicate (NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j)) true := by + have hv : NumEnc.enc v < 2 * G.numEdges := by + have h := NumEnc.enc_lt v + rw [NumEnc.card_eq_fintype_card] at h + have horder : Fintype.card (G.preprocess (F.toFamily hd)).graph.V = 2 * G.numEdges := + G.order_preprocess (F.toFamily hd) + omega + have hpos : 0 < G.preDeg (F.toFamily hd) := G.preDeg_pos _ + have hle : (G.preprocess (F.toFamily hd)).graph.kLen x ≤ T := + (G.preprocess (F.toFamily hd)).graph.kLen_le x + have hpre : ∀ (k : ℕ) (hk : k < (G.preprocess (F.toFamily hd)).graph.kLen x), + (NumEnc.enc x.1 / G.preDeg (F.toFamily hd) ^ k) % G.preDeg (F.toFamily hd) + = NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.kWalk x ⟨k, hk⟩) := by + intro k hk + rw [G.digit_enc (F.toFamily hd) x.1 hpos k (lt_of_lt_of_le hk hle), RegGraph.kWalk, + RegGraph.preWalk] + refine (walkFn_eq F pol hd G _ _ hv hpc hpe j).trans ?_ + exact congrArg (fun n => List.replicate n true) + (G.walkNum_eq (F.toFamily hd) v ((G.preprocess (F.toFamily hd)).graph.kWalk x) + (NumEnc.enc x.1) hpre hj) + +variable {F pol} in +/-- **The stopping block is the effective walk's length.** -/ +theorem stopBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + (hv : vertFn r w = List.replicate (NumEnc.enc v) true) + (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) : + stopBlk r w = List.replicate ((G.preprocess (F.toFamily hd)).graph.kLen x) true := by + have hlt : NumEnc.enc x.2 < r.q ^ r.T := NumEnc.enc_lt x.2 + have hxenc : NumEnc.enc x = NumEnc.enc x.1 * r.q ^ r.T + NumEnc.enc x.2 := rfl + have hco : coinsOf r.q r.T (killArg r w) = List.replicate (NumEnc.enc x.2) true := by + rw [killArg_eq r hg hv hdart, coinsOf, Cobham.sndBlock_pair, Cobham.sndBlock_pair, + modC_eq (Nat.pow_pos hq), List.length_replicate, hxenc, Nat.add_comm, + Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hlt] + rw [stopBlk, stopFn_eq hq hco r.T 0, ← stopAtNum_eq_stopFromNum, stopAtNum_eq hq x.2] + rfl + +variable {F pol} in +/-- **The parity block is the parity tuple's number.** -/ +theorem parBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + (hv : vertFn r w = List.replicate (NumEnc.enc v) true) + (hs : stepsFn r w = List.replicate (NumEnc.enc x.1) true) + (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (B : ℕ) (z : Cube (ROf B)) (i : ReadIdx) : + marks (digitSum 2 (parDigit F pol r) r.T w) + = List.replicate (NumEnc.enc (stepKeyOf G (F.toFamily hd) v x B z i).par) true := by + have hstop := stopBlk_eq r hd G hq v x hg hv hdart + rw [marks_eq] + congr 1 + refine length_digitSum_eq_enc (X := Fin 2) + (stepKeyOf G (F.toFamily hd) v x B z i).par _ w fun j hj => ?_ + rw [parDigit, hstop, hdeg, hP] + by_cases hjk : j < (G.preprocess (F.toFamily hd)).graph.kLen x + · rw [ifLtLen_pos (by simpa using hjk), walkArg_eq r hg hv hs, + walkFn_enc hd G v x hpc hpe j (le_of_lt hjk), modC_eq (by omega), + List.length_replicate, List.length_replicate] + show _ = NumEnc.enc (StepKey.par _ _) + rw [stepKeyOf] + simp only [StepKey.par] + rw [dif_pos hjk] + rfl + · rw [ifLtLen_neg (by simpa using hjk), List.length_nil] + show _ = NumEnc.enc (StepKey.par _ _) + rw [stepKeyOf] + simp only [StepKey.par] + rw [dif_neg hjk] + rfl + +omit [Fintype α] [DecidableEq α] in +theorem enc_halfEdge_div_two (G : ConstraintGraph α) (p : G.HalfEdge) : + NumEnc.enc p / 2 = p.1.val := by + have hcode : NumEnc.enc p = 2 * p.1.val + (if p.2 then 0 else 1) := by + rw [ConstraintGraph.enc_halfEdge, ConstraintGraph.halfCode] + rw [hcode] + by_cases h : p.2 = true + · rw [if_pos h] + omega + · rw [if_neg h] + omega + +variable {F pol} in +/-- **The code block is the code tuple's number.** -/ +theorem codeBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (α → α → Bool)) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + (hv : vertFn r w = List.replicate (NumEnc.enc v) true) + (hs : stepsFn r w = List.replicate (NumEnc.enc x.1) true) + (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (B : ℕ) (z : Cube (ROf B)) (i : ReadIdx) : + marks (digitSum r.C (codeDigit F pol r) r.T w) + = List.replicate (NumEnc.enc (stepKeyOf G (F.toFamily hd) v x B z i).code) true := by + have hstop := stopBlk_eq r hd G hq v x hg hv hdart + rw [marks_eq] + congr 1 + rw [hC] + refine length_digitSum_eq_enc (X := Fin (Fintype.card (α → α → Bool))) + (stepKeyOf G (F.toFamily hd) v x B z i).code _ w fun j hj => ?_ + rw [codeDigit, hstop, hdeg, hP] + by_cases hjk : j < (G.preprocess (F.toFamily hd)).graph.kLen x + · rw [ifLtLen_pos (by simpa using hjk), hg, walkArg_eq r hg hv hs, + walkFn_enc hd G v x hpc hpe j (le_of_lt hjk), divC_eq (by omega), + List.length_take] + simp only [List.length_replicate] + have henc : NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j) < 2 * G.numEdges := by + have h := NumEnc.enc_lt ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j) + rw [NumEnc.card_eq_fintype_card] at h + have horder : Fintype.card (G.preprocess (F.toFamily hd)).graph.V = 2 * G.numEdges := + G.order_preprocess (F.toFamily hd) + omega + have hidx : NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j) / 2 < G.numEdges := by omega + have hgc := gCode_encGraph G _ hidx + rw [gCode] at hgc + rw [hgc] + have hlt : codeOfRel (G.rel ⟨NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j) / 2, hidx⟩) < r.C := by + rw [hC] + exact codeOfRel_lt _ + rw [Nat.min_eq_right (le_of_lt hlt)] + show _ = NumEnc.enc (StepKey.code _ _) + rw [stepKeyOf] + simp only [StepKey.code] + rw [dif_pos hjk] + have hfin : (⟨NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j) / 2, hidx⟩ : Fin G.numEdges) + = ((G.preprocess (F.toFamily hd)).graph.walkAt + ((G.preprocess (F.toFamily hd)).graph.kLen x) v + ((G.preprocess (F.toFamily hd)).graph.kWalk x) j).1 := + Fin.ext (enc_halfEdge_div_two G _) + rw [hfin] + rfl + · rw [ifLtLen_neg (by simpa using hjk), List.length_nil] + show _ = NumEnc.enc (StepKey.code _ _) + rw [stepKeyOf] + simp only [StepKey.code] + rw [dif_neg hjk] + rfl + +variable {F pol} in +/-- **The return-dart block is the return tuple's number.** -/ +theorem revBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + (hv : vertFn r w = List.replicate (NumEnc.enc v) true) + (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (B : ℕ) (z : Cube (ROf B)) (i : ReadIdx) : + (revNumFn F pol r.deg r.P r.T r.q (killArg r w)).take (r.P ^ r.T) + = List.replicate (NumEnc.enc (stepKeyOf G (F.toFamily hd) v x B z i).rev) true := by + have henc : NumEnc.enc v < 2 * G.numEdges := by + have h := NumEnc.enc_lt v + rw [NumEnc.card_eq_fintype_card] at h + have horder : Fintype.card (G.preprocess (F.toFamily hd)).graph.V = 2 * G.numEdges := + G.order_preprocess (F.toFamily hd) + omega + have hclt : NumEnc.enc x.2 < r.q ^ r.T := NumEnc.enc_lt x.2 + have hxenc : NumEnc.enc x = NumEnc.enc x.1 * r.q ^ r.T + NumEnc.enc x.2 := rfl + have hrev : NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.killedRev v x.1 x.2) + < r.P ^ r.T := by + have h := NumEnc.enc_lt ((G.preprocess (F.toFamily hd)).graph.killedRev v x.1 x.2) + have hcard : NumEnc.card (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) + = G.preDeg (F.toFamily hd) ^ r.T := rfl + rw [hcard, ← hP] at h + exact h + rw [killArg_eq r hg hv hdart, hdeg, hP, hxenc, + revNumFn_eq hd G r.T r.q (NumEnc.enc v) (NumEnc.enc x.1) (NumEnc.enc x.2) hq henc + hclt hpc hpe] + have hknum : G.killedRevNum (F.toFamily hd) r.T r.q (NumEnc.enc v) (NumEnc.enc x.1) + (NumEnc.enc x.2) + = NumEnc.enc ((G.preprocess (F.toFamily hd)).graph.killedRev v x.1 x.2) := + G.killedRevNum_eq (F.toFamily hd) hq (G.preDeg_pos _) v x.1 x.2 + rw [hknum, List.take_replicate] + show List.replicate _ true = List.replicate (NumEnc.enc (StepKey.rev _)) true + rw [stepKeyOf] + simp only [StepKey.rev] + rw [← hP, Nat.min_eq_right (le_of_lt hrev)] + rfl + +variable {F pol} in +/-- **The algorithm writes out the walk's own data.** -/ +theorem keyFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (α → α → Bool)) (hZ : 0 < r.cZ) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + {B : ℕ} (z : Cube (ROf B)) (i : ReadIdx) + (hcZ : r.cZ = NumEnc.card (Cube (ROf B))) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + keyFn F pol r (pair (encGraph G) (List.replicate + (((NumEnc.enc v * r.cD + NumEnc.enc x) * r.cZ + NumEnc.enc z) * 22 + NumEnc.enc i) true)) + = packKey (stepKeyOf G (F.toFamily hd) v x B z i) := by + have hxlt : NumEnc.enc x < r.cD := by + have h := NumEnc.enc_lt x + have hcard : NumEnc.card ((Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) + × (Fin r.T → Fin r.q)) = G.preDeg (F.toFamily hd) ^ r.T * r.q ^ r.T := rfl + rw [hcard] at h + rw [Round.cD, hP] + exact h + have hzlt : NumEnc.enc z < r.cZ := by rw [hcZ]; exact NumEnc.enc_lt z + have hilt : NumEnc.enc i < 22 := NumEnc.enc_lt i + obtain ⟨-, hv, hdart, hrand, hread⟩ := + blocks_eq r (by + rw [Round.cD, hP] + exact Nat.mul_pos (Nat.pow_pos (G.preDeg_pos _)) (Nat.pow_pos hq)) hZ (encGraph G) + (NumEnc.enc v) (NumEnc.enc x) (NumEnc.enc z) (NumEnc.enc i) hxlt hzlt hilt + have hclt : NumEnc.enc x.2 < r.cQ := NumEnc.enc_lt x.2 + have hxenc : NumEnc.enc x = NumEnc.enc x.1 * r.cQ + NumEnc.enc x.2 := rfl + obtain ⟨hs, hc⟩ := steps_coin_eq r (Nat.pow_pos hq) _ (NumEnc.enc x.1) + (NumEnc.enc x.2) hclt (by rw [hdart, hxenc]) + have hg : Cobham.fstBlock (pair (encGraph G) (List.replicate + (((NumEnc.enc v * r.cD + NumEnc.enc x) * r.cZ + NumEnc.enc z) * 22 + NumEnc.enc i) true)) + = encGraph G := Cobham.fstBlock_pair _ _ + rw [keyFn, hs, hc, hrand, hread, + parBlk_eq r hd G hq hdeg hP v x hg hv hs hdart hpc hpe B z i, + codeBlk_eq r hd G hq hdeg hP hC v x hg hv hs hdart hpc hpe B z i, + revBlk_eq r hd G hq hdeg hP v x hg hv hdart hpc hpe B z i, packKey] + rfl + +/-- A bound on the length of an edge's data. -/ +def keyBound : ℕ := + 2 * (2 * r.cD + 2 + r.cQ) + 2 + + (2 * (2 * (r.T * (1 * 2 ^ r.T)) + 2 + r.T * (r.C * r.C ^ r.T)) + 2 + + (2 * r.P ^ r.T + 2 + (2 * r.cZ + 2 + 22))) + +theorem keyFn_length_le (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 < r.C) + (w : List Bool) : + (keyFn F pol r w).length ≤ keyBound r := by + have hdart : (dartFn r w).length < r.cD := by + rw [dartFn, modC_eq hD, List.length_replicate] + exact Nat.mod_lt _ hD + have hsteps : (stepsFn r w).length ≤ r.cD := by + rw [stepsFn, divC_eq hQ, List.length_replicate] + exact le_trans (Nat.div_le_self _ _) (le_of_lt hdart) + have hcoin : (coinFn r w).length < r.cQ := by + rw [coinFn, modC_eq hQ, List.length_replicate] + exact Nat.mod_lt _ hQ + have hrand : (randFn r w).length ≤ r.cZ := by + rw [randFn, divC_eq (by omega), List.length_replicate, modC_eq (by positivity), + List.length_replicate] + have hlt : (Cobham.sndBlock w).length % (r.cZ * 22) < r.cZ * 22 := + Nat.mod_lt _ (by positivity) + exact Nat.div_le_of_le_mul (by omega) + have hread : (readFn w).length ≤ 22 := by + rw [readFn, modC_eq (by omega), List.length_replicate] + exact le_of_lt (Nat.mod_lt _ (by omega)) + have hpar : (digitSum 2 (parDigit F pol r) r.T w).length ≤ r.T * (1 * 2 ^ r.T) := by + refine length_digitSum_le (by omega) (fun j u => ?_) r.T w + rw [parDigit] + by_cases h : (List.replicate j true).length < (stopBlk r u).length + · rw [ifLtLen_pos h, modC_eq (by omega), List.length_replicate] + omega + · rw [ifLtLen_neg h] + simp + have hcode : (digitSum r.C (codeDigit F pol r) r.T w).length ≤ r.T * (r.C * r.C ^ r.T) := by + refine length_digitSum_le hC (fun j u => ?_) r.T w + rw [codeDigit] + by_cases h : (List.replicate j true).length < (stopBlk r u).length + · rw [ifLtLen_pos h] + exact le_trans (List.length_take_le _ _) (by simp) + · rw [ifLtLen_neg h] + simp + have hrevb : ((revNumFn F pol r.deg r.P r.T r.q (killArg r w)).take (r.P ^ r.T)).length + ≤ r.P ^ r.T := by + exact le_trans (List.length_take_le _ _) (by simp) + rw [keyFn, keyBound] + simp only [pair_length, marks_eq, List.length_replicate] + omega + +/-! ### The cube and the code, in polynomial time -/ + +variable {E : ExpanderFamily} {B : ℕ} + +/-- The cube a composed edge's second endpoint names. -/ +noncomputable def cubeFn + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) (w : List Bool) : List Bool := + List.replicate (cubeOfKey encβ (keyOfString dflt (keyFn F pol r w))) true + +/-- The code of a composed edge's constraint. -/ +noncomputable def codeFn + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) (w : List Bool) : List Bool := + List.replicate (codeOfKey encβ (keyOfString dflt (keyFn F pol r w))) true + +theorem cubeFn_mem_FP (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 < r.C) + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) : cubeFn F pol r dflt encβ ∈ FP := + mem_FP_of_bounded_key (keyFn_mem_FP F pol r) (keyFn_length_le F pol r hQ hD hZ hC) + (fun s => List.replicate (cubeOfKey encβ (keyOfString dflt s)) true) + +theorem codeFn_mem_FP (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 < r.C) + (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk E r.T → α) → Cube B) : codeFn F pol r dflt encβ ∈ FP := + mem_FP_of_bounded_key (keyFn_mem_FP F pol r) (keyFn_length_le F pol r hQ hD hZ hC) + (fun s => List.replicate (codeOfKey encβ (keyOfString dflt s)) true) + +variable {F pol} in +/-- **The cube algorithm computes the composed edge's cube.** -/ +theorem cubeFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (α → α → Bool)) (hZ : 0 < r.cZ) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + (z : Cube (ROf B)) (i : ReadIdx) + (hcZ : r.cZ = NumEnc.card (Cube (ROf B))) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (dflt : StepKey (F.toFamily hd) r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk (F.toFamily hd) r.T → α) → Cube B) : + cubeFn F pol r dflt encβ (pair (encGraph G) (List.replicate + (((NumEnc.enc v * r.cD + NumEnc.enc x) * r.cZ + NumEnc.enc z) * 22 + NumEnc.enc i) true)) + = List.replicate (((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).cubeNum + encβ (v, x) z i) true := by + rw [cubeFn, keyFn_eq r hd G hq hdeg hP hC hZ v x z i hcZ hpc hpe, keyOfString_packKey, + cubeOfKey_eq G (F.toFamily hd) hq v x z i encβ] + +variable {F pol} in +/-- **The cube algorithm**, with the dart given as one object. -/ +theorem cubeFn_eq' (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (α → α → Bool)) (hZ : 0 < r.cZ) + (p : ((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).Dart) + (z : Cube (ROf B)) (i : ReadIdx) + (hcZ : r.cZ = NumEnc.card (Cube (ROf B))) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (dflt : StepKey (F.toFamily hd) r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk (F.toFamily hd) r.T → α) → Cube B) : + cubeFn F pol r dflt encβ (pair (encGraph G) (List.replicate + (((NumEnc.enc p.1 * r.cD + NumEnc.enc p.2) * r.cZ + NumEnc.enc z) * 22 + + NumEnc.enc i) true)) + = List.replicate (((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).cubeNum + encβ p z i) true := by + obtain ⟨v, x⟩ := p + exact cubeFn_eq r hd G hq hdeg hP hC hZ v x z i hcZ hpc hpe dflt encβ + +variable {F pol} in +/-- **The code algorithm computes the composed edge's constraint.** -/ +theorem codeFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (α → α → Bool)) (hZ : 0 < r.cZ) + (v : (G.preprocess (F.toFamily hd)).graph.V) + (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) + (z : Cube (ROf B)) (i : ReadIdx) + (hcZ : r.cZ = NumEnc.card (Cube (ROf B))) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (dflt : StepKey (F.toFamily hd) r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk (F.toFamily hd) r.T → α) → Cube B) : + codeFn F pol r dflt encβ (pair (encGraph G) (List.replicate + (((NumEnc.enc v * r.cD + NumEnc.enc x) * r.cZ + NumEnc.enc z) * 22 + NumEnc.enc i) true)) + = List.replicate (codeOfRel (MultiTest.relOfCheck + ((((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).compose encβ).check (v, x) z) + i)) true := by + rw [codeFn, keyFn_eq r hd G hq hdeg hP hC hZ v x z i hcZ hpc hpe, keyOfString_packKey, + codeOfKey_eq G (F.toFamily hd) hq v x z i encβ] + +variable {F pol} in +/-- **The code algorithm**, with the dart given as one object. -/ +theorem codeFn_eq' (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) + (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) + (hC : r.C = Fintype.card (α → α → Bool)) (hZ : 0 < r.cZ) + (p : ((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).Dart) + (z : Cube (ROf B)) (i : ReadIdx) + (hcZ : r.cZ = NumEnc.card (Cube (ROf B))) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) + (dflt : StepKey (F.toFamily hd) r.T r.q B (Fintype.card (α → α → Bool))) + (encβ : (PreWalk (F.toFamily hd) r.T → α) → Cube B) : + codeFn F pol r dflt encβ (pair (encGraph G) (List.replicate + (((NumEnc.enc p.1 * r.cD + NumEnc.enc p.2) * r.cZ + NumEnc.enc z) * 22 + + NumEnc.enc i) true)) + = List.replicate (codeOfRel (MultiTest.relOfCheck + ((((G.preprocess (F.toFamily hd)).killedPow r.q r.T hq).compose encβ).check p z) + i)) true := by + obtain ⟨v, x⟩ := p + exact codeFn_eq r hd G hq hdeg hP hC hZ v x z i hcZ hpc hpe dflt encβ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgKilled.lean b/Complexitylib/Classes/PCP/Internal/AlgKilled.lean new file mode 100644 index 00000000..5edba267 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgKilled.lean @@ -0,0 +1,542 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgPreRot +public import Complexitylib.Classes.PCP.Internal.AlgWalk + +/-! +# The killed walk, as an algorithm + +The walk length and the killing denominator are constants of a round, so the +walk is a constant-depth unrolling of the preprocessed rotation map, and the +stopping index is chosen by a constant-depth chain of comparisons. + +## Main definitions + +- `Complexity.selectAt` — choose among constantly many functions by a unary key +- `Complexity.walkFn` — the vertex a walk reaches after a constant number of + steps + +## Main results + +- `Complexity.walkFn_mem_FP`, `Complexity.walkFn_eq` — it is an `FP` function, + and it computes `ConstraintGraph.walkNum` +-/ + +@[expose] public section + +namespace Complexity + +variable {α : Type} [Fintype α] [DecidableEq α] + +namespace ConstraintGraph + +variable (G : ConstraintGraph α) (E : ExpanderFamily) + +omit [Fintype α] [DecidableEq α] in +/-- Every code in a cloud is below twice the edge count. -/ +theorem mem_cloudCodes_lt {u : Fin G.numVerts} {c : ℕ} (h : c ∈ G.cloudCodes u) : + c < 2 * G.numEdges := by + obtain ⟨p, _, rfl⟩ := (G.mem_cloudCodes).mp h + exact halfCode_lt G p + +omit [Fintype α] in +/-- **The rotation map keeps a vertex number in range.** -/ +theorem preRotNum_fst_lt {v : ℕ} (hv : v < 2 * G.numEdges) (d : ℕ) : + (G.preRotNum E v d).1 < 2 * G.numEdges := by + classical + have horder : (G.reduce E).graph.order = 2 * G.numEdges := by + rw [graph_reduce, order_reduceGraph] + rw [preRotNum] + split + · exact hv + · split + · simp only + split <;> omega + · split + · simp only + rw [cloudStepN] + split + · split + · rw [cloudStepNum] + split + · simp only + exact G.mem_cloudCodes_lt (Finset.orderEmbOfFin_mem _ _ _) + · exact hv + · exact hv + · exact hv + · simp only + rw [expStepN] + split + · split + · rw [← horder] + exact Fin.isLt _ + · exact hv + · exact hv + +omit [Fintype α] in +/-- **A walk stays in range.** -/ +theorem walkNum_lt {v : ℕ} (hv : v < 2 * G.numEdges) (s : ℕ) : + ∀ k, G.walkNum E s k v < 2 * G.numEdges := by + intro k + induction k with + | zero => exact hv + | succ k ih => exact G.preRotNum_fst_lt E ih _ + +omit [Fintype α] in +/-- **The preprocessed graph has `2 + 2 · deg` darts at a vertex.** -/ +theorem preDeg_eq : G.preDeg E = 2 + 2 * E.degree := by + rw [preDeg, NumEnc.card_eq_fintype_card] + show Fintype.card (Unit ⊕ (Option (Fin E.degree) ⊕ Fin E.degree)) = _ + simp + omega + +omit [Fintype α] in +theorem preDeg_pos : 0 < G.preDeg E := by rw [G.preDeg_eq E]; omega + +end ConstraintGraph + +/-! ### Choosing by a unary key -/ + +/-- Choose among `n + 1` functions by a unary key. -/ +noncomputable def selectAt (f : ℕ → List Bool → List Bool) (key : List Bool → List Bool) : + ℕ → List Bool → List Bool + | 0, z => f 0 z + | n + 1, z => + ifEqLen (key z) (List.replicate (n + 1) true) (f (n + 1) z) (selectAt f key n z) + +theorem selectAt_mem_FP {f : ℕ → List Bool → List Bool} {key : List Bool → List Bool} + (hf : ∀ k, f k ∈ FP) (hkey : key ∈ FP) : ∀ n, selectAt f key n ∈ FP := by + intro n + induction n with + | zero => exact hf 0 + | succ n ih => + refine mem_FP_of_eq (ifEqLen_mem_FP hkey + (constFn_mem_FP (List.replicate (n + 1) true)) (hf (n + 1)) ih) fun w => ?_ + rw [selectAt] + +theorem selectAt_eq {f : ℕ → List Bool → List Bool} {key : List Bool → List Bool} + {z : List Bool} {m : ℕ} (hkey : key z = List.replicate m true) : + ∀ {n : ℕ}, m ≤ n → selectAt f key n z = f m z := by + intro n + induction n with + | zero => + intro h + rw [selectAt, Nat.le_zero.mp h] + | succ n ih => + intro h + rw [selectAt] + by_cases hm : m = n + 1 + · subst hm + rw [ifEqLen_pos (by simp [hkey])] + · rw [ifEqLen_neg (by + rw [hkey, List.length_replicate, List.length_replicate] + exact hm), ih (by omega)] + +/-! ### Walking -/ + +variable (F : FinBase) (pol : Polynomial ℕ) + +/-- The vertex a walk reaches after `k` steps, on +`pair (graph) (pair (unary vertex) (unary steps))`. -/ +noncomputable def walkFn (deg P : ℕ) : ℕ → List Bool → List Bool + | 0, w => Cobham.fstBlock (Cobham.sndBlock w) + | k + 1, w => + Cobham.fstBlock (preRotFn F pol deg + (pair (Cobham.fstBlock w) + (pair (walkFn deg P k w) + (modC P (divC (P ^ k) (Cobham.sndBlock (Cobham.sndBlock w))))))) + +theorem walkFn_mem_FP (deg P : ℕ) : ∀ k, walkFn F pol deg P k ∈ FP := by + intro k + induction k with + | zero => + refine mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP) + fun w => ?_ + rw [Function.comp_apply, walkFn] + | succ k ih => + have hs : (fun w : List Bool => Cobham.sndBlock (Cobham.sndBlock w)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP + have h := mem_FP_comp (Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP + (Cobham.pairFn_mem_FP ih (modC_mem_FP (divC_mem_FP hs (P ^ k)) P))) + (mem_FP_comp (preRotFn_mem_FP F pol deg) Cobham.fstBlock_mem_FP) + refine mem_FP_of_eq h fun w => ?_ + simp only [Function.comp_apply] + rw [walkFn] + +/-- **The walk algorithm computes the walk.** -/ +theorem walkFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (v s : ℕ) + (hv : v < 2 * G.numEdges) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + ∀ k, walkFn F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) k + (pair (encGraph G) (pair (List.replicate v true) (List.replicate s true))) + = List.replicate (G.walkNum (F.toFamily hd) s k v) true := by + have hPpos : 0 < G.preDeg (F.toFamily hd) := G.preDeg_pos _ + intro k + induction k with + | zero => + rw [walkFn, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + rfl + | succ k ih => + have hdig : modC (G.preDeg (F.toFamily hd)) + (divC (G.preDeg (F.toFamily hd) ^ k) (List.replicate s true)) + = List.replicate ((s / G.preDeg (F.toFamily hd) ^ k) + % G.preDeg (F.toFamily hd)) true := by + rw [divC_eq (Nat.pow_pos hPpos), List.length_replicate, + modC_eq hPpos, List.length_replicate] + have hdlt : (s / G.preDeg (F.toFamily hd) ^ k) % G.preDeg (F.toFamily hd) + < 2 + 2 * (F.toFamily hd).degree := by + rw [← G.preDeg_eq (F.toFamily hd)] + exact Nat.mod_lt _ hPpos + rw [walkFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.sndBlock_pair, ih, hdig, + preRotFn_eq G F pol hd _ _ (G.walkNum_lt _ hv s k) hdlt hpc hpe, + Cobham.fstBlock_pair, ConstraintGraph.walkNum] + +/-! ### Where the walk stops -/ + +theorem findIdx_map {β γ : Type} (f : β → γ) (p : γ → Bool) (l : List β) : + (l.map f).findIdx p = l.findIdx (fun x => p (f x)) := by + induction l with + | nil => rfl + | cons a t ih => rw [List.map_cons, List.findIdx_cons, List.findIdx_cons, ih] + +/-- The first zero digit at or after `i`, among the next `n` digits. -/ +def stopFromNum (q c : ℕ) : ℕ → ℕ → ℕ + | i, 0 => i + | i, n + 1 => if (c / q ^ i) % q = 0 then i else stopFromNum q c (i + 1) n + +theorem stopFromNum_eq_findIdx (q c : ℕ) : ∀ (n i : ℕ), stopFromNum q c i n + = i + (List.finRange n).findIdx (fun j : Fin n => (c / q ^ (i + j.val)) % q == 0) := by + intro n + induction n with + | zero => + intro i + rw [stopFromNum, List.finRange_zero, List.findIdx_nil, Nat.add_zero] + | succ n ih => + intro i + rw [stopFromNum, List.finRange_succ, List.findIdx_cons, findIdx_map] + by_cases h : (c / q ^ i) % q = 0 + · rw [if_pos h] + simp [h] + · rw [if_neg h, ih (i + 1)] + have hcond : ((c / q ^ (i + (0 : Fin (n + 1)).val)) % q == 0) = false := by + simpa using h + rw [hcond] + have hbody : (List.finRange n).findIdx + (fun x : Fin n => (c / q ^ (i + (Fin.succ x).val)) % q == 0) + = (List.finRange n).findIdx + (fun j : Fin n => (c / q ^ (i + 1 + j.val)) % q == 0) := by + refine findIdx_congr fun x _ => ?_ + rw [Fin.val_succ, show i + (x.val + 1) = i + 1 + x.val by omega] + rw [hbody] + simp only [cond_false] + omega + +theorem stopAtNum_eq_stopFromNum (T q c : ℕ) : stopAtNum T q c = stopFromNum q c 0 T := by + rw [stopFromNum_eq_findIdx, stopAtNum, Nat.zero_add] + exact (findIdx_congr fun j _ => by rw [Nat.zero_add]).symm + +/-- Where the walk stops, from a unary reading `co` of the coins. -/ +noncomputable def stopFn (q : ℕ) (co : List Bool → List Bool) : + ℕ → ℕ → List Bool → List Bool + | i, 0, _ => List.replicate i true + | i, n + 1, z => + ifEqLen (modC q (divC (q ^ i) (co z))) [] (List.replicate i true) + (stopFn q co (i + 1) n z) + +theorem stopFn_mem_FP {q : ℕ} {co : List Bool → List Bool} (hco : co ∈ FP) : + ∀ (n i : ℕ), stopFn q co i n ∈ FP := by + intro n + induction n with + | zero => exact fun i => constFn_mem_FP _ + | succ n ih => + intro i + refine mem_FP_of_eq (ifEqLen_mem_FP (modC_mem_FP (divC_mem_FP hco (q ^ i)) q) + (constFn_mem_FP []) (constFn_mem_FP (List.replicate i true)) (ih (i + 1))) fun w => ?_ + rw [stopFn] + +/-- **The stopping algorithm finds the stopping index.** -/ +theorem stopFn_eq {q : ℕ} (hq : 0 < q) {co : List Bool → List Bool} {z : List Bool} {c : ℕ} + (hco : co z = List.replicate c true) : + ∀ (n i : ℕ), stopFn q co i n z = List.replicate (stopFromNum q c i n) true := by + intro n + induction n with + | zero => intro i; rw [stopFn, stopFromNum] + | succ n ih => + intro i + have hdig : modC q (divC (q ^ i) (co z)) = List.replicate ((c / q ^ i) % q) true := by + rw [hco, divC_eq (Nat.pow_pos hq), List.length_replicate, modC_eq hq, + List.length_replicate] + rw [stopFn, hdig, stopFromNum] + by_cases h : (c / q ^ i) % q = 0 + · rw [if_pos h, ifEqLen_pos (by simp [h])] + · rw [if_neg h, ifEqLen_neg (by simpa using h), ih (i + 1)] + +/-! ### The dart the walk comes back by -/ + +/-- The label the walk's `i`-th step points back along. -/ +noncomputable def backFn (deg P i : ℕ) (w : List Bool) : List Bool := + Cobham.sndBlock (preRotFn F pol deg + (pair (Cobham.fstBlock w) + (pair (walkFn F pol deg P i w) + (modC P (divC (P ^ i) (Cobham.sndBlock (Cobham.sndBlock w))))))) + +theorem backFn_mem_FP (deg P i : ℕ) : backFn F pol deg P i ∈ FP := by + have hs : (fun w : List Bool => Cobham.sndBlock (Cobham.sndBlock w)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP + have h := mem_FP_comp (Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP + (Cobham.pairFn_mem_FP (walkFn_mem_FP F pol deg P i) + (modC_mem_FP (divC_mem_FP hs (P ^ i)) P))) + (mem_FP_comp (preRotFn_mem_FP F pol deg) Cobham.sndBlock_mem_FP) + refine mem_FP_of_eq h fun w => ?_ + simp only [Function.comp_apply] + rw [backFn] + +variable {F pol} in +/-- **The back-label algorithm reads the label off the rotation map.** -/ +theorem backFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (v s i : ℕ) + (hv : v < 2 * G.numEdges) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + backFn F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) i + (pair (encGraph G) (pair (List.replicate v true) (List.replicate s true))) + = List.replicate (G.preRotNum (F.toFamily hd) (G.walkNum (F.toFamily hd) s i v) + ((s / G.preDeg (F.toFamily hd) ^ i) % G.preDeg (F.toFamily hd))).2 true := by + have hPpos : 0 < G.preDeg (F.toFamily hd) := G.preDeg_pos _ + have hdig : modC (G.preDeg (F.toFamily hd)) + (divC (G.preDeg (F.toFamily hd) ^ i) (List.replicate s true)) + = List.replicate ((s / G.preDeg (F.toFamily hd) ^ i) + % G.preDeg (F.toFamily hd)) true := by + rw [divC_eq (Nat.pow_pos hPpos), List.length_replicate, modC_eq hPpos, + List.length_replicate] + have hdlt : (s / G.preDeg (F.toFamily hd) ^ i) % G.preDeg (F.toFamily hd) + < 2 + 2 * (F.toFamily hd).degree := by + rw [← G.preDeg_eq (F.toFamily hd)] + exact Nat.mod_lt _ hPpos + rw [backFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.sndBlock_pair, + walkFn_eq F pol hd G v s hv hpc hpe, hdig, + preRotFn_eq G F pol hd _ _ (G.walkNum_lt _ hv s i) hdlt hpc hpe, Cobham.sndBlock_pair] + +/-- The reversed dart's digits, for a fixed stopping index `k`, over the first +`n` places. -/ +noncomputable def revSum (deg P k : ℕ) : ℕ → List Bool → List Bool + | 0, _ => [] + | n + 1, w => + revSum deg P k n w ++ mulC (P ^ n) + (if n < k then backFn F pol deg P (k - 1 - n) w + else modC P (divC (P ^ n) (Cobham.sndBlock (Cobham.sndBlock w)))) + +theorem revSum_mem_FP (deg P k : ℕ) : ∀ n, revSum F pol deg P k n ∈ FP := by + intro n + induction n with + | zero => exact mem_FP_of_eq (constFn_mem_FP []) fun w => by rw [revSum] + | succ n ih => + have hs : (fun w : List Bool => Cobham.sndBlock (Cobham.sndBlock w)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP + have hterm : (fun w : List Bool => + if n < k then backFn F pol deg P (k - 1 - n) w + else modC P (divC (P ^ n) (Cobham.sndBlock (Cobham.sndBlock w)))) ∈ FP := by + by_cases h : n < k + · simpa [h] using backFn_mem_FP F pol deg P (k - 1 - n) + · simpa [h] using modC_mem_FP (divC_mem_FP hs (P ^ n)) P + refine mem_FP_of_eq (Cobham.appendFn_mem_FP ih (mulC_mem_FP hterm (P ^ n))) fun w => ?_ + rw [revSum] + +variable {F pol} in +/-- **The digit sum has the reversed dart's number as its length.** -/ +theorem length_revSum (hd : 1 < F.deg) (G : ConstraintGraph α) (v s k : ℕ) + (hv : v < 2 * G.numEdges) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + ∀ n, (revSum F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) k n + (pair (encGraph G) (pair (List.replicate v true) (List.replicate s true)))).length + = ∑ j ∈ Finset.range n, + (if j < k then (G.preRotNum (F.toFamily hd) + (G.walkNum (F.toFamily hd) s (k - 1 - j) v) + ((s / G.preDeg (F.toFamily hd) ^ (k - 1 - j)) + % G.preDeg (F.toFamily hd))).2 + else (s / G.preDeg (F.toFamily hd) ^ j) % G.preDeg (F.toFamily hd)) + * G.preDeg (F.toFamily hd) ^ j := by + have hPpos : 0 < G.preDeg (F.toFamily hd) := G.preDeg_pos _ + intro n + induction n with + | zero => rw [revSum, Finset.range_zero, Finset.sum_empty, List.length_nil] + | succ n ih => + rw [revSum, List.length_append, ih, Finset.sum_range_succ, length_mulC] + congr 1 + congr 1 + by_cases h : n < k + · rw [if_pos h, if_pos h, backFn_eq hd G v s (k - 1 - n) hv hpc hpe, + List.length_replicate] + · rw [if_neg h, if_neg h, Cobham.sndBlock_pair, Cobham.sndBlock_pair, + divC_eq (Nat.pow_pos hPpos), List.length_replicate, modC_eq hPpos] + simp + +namespace ConstraintGraph + +variable (G : ConstraintGraph α) (E : ExpanderFamily) + +/-- The reversed dart's number, for a fixed stopping index. -/ +noncomputable def revAtNum (T k v s : ℕ) : ℕ := + ∑ j ∈ Finset.range T, + (if j < k then (G.preRotNum E (G.walkNum E s (k - 1 - j) v) + ((s / G.preDeg E ^ (k - 1 - j)) % G.preDeg E)).2 + else (s / G.preDeg E ^ j) % G.preDeg E) * G.preDeg E ^ j + +omit [Fintype α] in +theorem killedRevNum_eq_revAtNum (T q v s c : ℕ) : + G.killedRevNum E T q v s c = G.revAtNum E T (stopAtNum T q c) v s := rfl + +end ConstraintGraph + +/-! ### The powered graph's rotation map -/ + +/-- The coins of a killed dart. -/ +noncomputable def coinsOf (q T : ℕ) (z : List Bool) : List Bool := + modC (q ^ T) (Cobham.sndBlock (Cobham.sndBlock z)) + +/-- A killed dart's steps, in the walk's input format. -/ +noncomputable def toWalk (q T : ℕ) (z : List Bool) : List Bool := + pair (Cobham.fstBlock z) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + (divC (q ^ T) (Cobham.sndBlock (Cobham.sndBlock z)))) + +theorem coinsOf_mem_FP (q T : ℕ) : coinsOf q T ∈ FP := + modC_mem_FP (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP) _ + +theorem toWalk_mem_FP (q T : ℕ) : toWalk q T ∈ FP := + Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP + (Cobham.pairFn_mem_FP (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP) + (divC_mem_FP (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP) _)) + +/-- **The dart a killed walk comes back by**, on `pair (graph) (pair (unary +vertex) (unary dart))`. -/ +noncomputable def revNumFn (deg P T q : ℕ) (z : List Bool) : List Bool := + selectAt (fun k w => marks (revSum F pol deg P k T (toWalk q T w))) + (fun w => stopFn q (coinsOf q T) 0 T w) T z + +theorem revNumFn_mem_FP (deg P T q : ℕ) : revNumFn F pol deg P T q ∈ FP := + selectAt_mem_FP + (fun k => marks_mem_FP (mem_FP_of_eq + (mem_FP_comp (toWalk_mem_FP q T) (revSum_mem_FP F pol deg P k T)) fun _ => rfl)) + (stopFn_mem_FP (coinsOf_mem_FP q T) T 0) T + +/-- **The powered graph's rotation map**, on `pair (graph) (pair (unary vertex) +(unary dart))`: walk to the end, come back by the reversed labels, and keep the +coins. -/ +noncomputable def killedRotFn (deg P T q : ℕ) (z : List Bool) : List Bool := + pair + (selectAt (fun k w => walkFn F pol deg P k (toWalk q T w)) + (fun w => stopFn q (coinsOf q T) 0 T w) T z) + (marks (mulC (q ^ T) (revNumFn F pol deg P T q z)) ++ coinsOf q T z) + +theorem killedRotFn_mem_FP (deg P T q : ℕ) : killedRotFn F pol deg P T q ∈ FP := by + have hkey : (fun w : List Bool => stopFn q (coinsOf q T) 0 T w) ∈ FP := + stopFn_mem_FP (coinsOf_mem_FP q T) T 0 + have hwalk : ∀ k, (fun w : List Bool => walkFn F pol deg P k (toWalk q T w)) ∈ FP := + fun k => mem_FP_of_eq (mem_FP_comp (toWalk_mem_FP q T) (walkFn_mem_FP F pol deg P k)) + fun _ => rfl + have hrev : ∀ k, (fun w : List Bool => + marks (revSum F pol deg P k T (toWalk q T w))) ∈ FP := + fun k => marks_mem_FP (mem_FP_of_eq + (mem_FP_comp (toWalk_mem_FP q T) (revSum_mem_FP F pol deg P k T)) fun _ => rfl) + refine mem_FP_of_eq (Cobham.pairFn_mem_FP (selectAt_mem_FP hwalk hkey T) + (Cobham.appendFn_mem_FP + (marks_mem_FP (mulC_mem_FP (selectAt_mem_FP hrev hkey T) (q ^ T))) + (coinsOf_mem_FP q T))) fun w => ?_ + rw [killedRotFn, revNumFn] + +variable {F pol} in +theorem marks_revSum_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (T v s k : ℕ) + (hv : v < 2 * G.numEdges) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + marks (revSum F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) k T + (pair (encGraph G) (pair (List.replicate v true) (List.replicate s true)))) + = List.replicate (G.revAtNum (F.toFamily hd) T k v s) true := by + rw [marks_eq, length_revSum hd G v s k hv hpc hpe, ConstraintGraph.revAtNum] + +variable {F pol} in +/-- **The return-dart algorithm computes the dart the walk comes back by.** -/ +theorem revNumFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (T q v s c : ℕ) + (hq : 0 < q) (hv : v < 2 * G.numEdges) (hc : c < q ^ T) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + revNumFn F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) T q + (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) + = List.replicate (G.killedRevNum (F.toFamily hd) T q v s c) true := by + have hqT : 0 < q ^ T := Nat.pow_pos hq + have hdiv : (s * q ^ T + c) / q ^ T = s := by + rw [Nat.add_comm, Nat.add_mul_div_right _ _ hqT, Nat.div_eq_of_lt hc, Nat.zero_add] + have hmod : (s * q ^ T + c) % q ^ T = c := by + rw [Nat.add_comm, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hc] + have hco : coinsOf q T (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) = List.replicate c true := by + rw [coinsOf, Cobham.sndBlock_pair, Cobham.sndBlock_pair, modC_eq hqT, + List.length_replicate, hmod] + have htw : toWalk q T (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) + = pair (encGraph G) (pair (List.replicate v true) (List.replicate s true)) := by + rw [toWalk, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, divC_eq hqT, List.length_replicate, hdiv] + have hstop : stopFn q (coinsOf q T) 0 T (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) = List.replicate (stopAtNum T q c) true := by + rw [stopFn_eq hq hco T 0, ← stopAtNum_eq_stopFromNum] + have hle : stopAtNum T q c ≤ T := by + have h : (List.finRange T).findIdx (fun j : Fin T => (c / q ^ j.val) % q == 0) + ≤ (List.finRange T).length := List.findIdx_le_length + rwa [List.length_finRange] at h + rw [revNumFn, selectAt_eq hstop hle, htw, marks_revSum_eq hd G T v s _ hv hpc hpe, + G.killedRevNum_eq_revAtNum] + +variable {F pol} in +/-- **The rotation algorithm runs the powered graph's rotation map.** -/ +theorem killedRotFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (T q v s c : ℕ) + (hq : 0 < q) (hv : v < 2 * G.numEdges) (hc : c < q ^ T) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + killedRotFn F pol (F.toFamily hd).degree (G.preDeg (F.toFamily hd)) T q + (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) + = pair (List.replicate (G.killedRotNum (F.toFamily hd) T q v s c).1 true) + (List.replicate (G.killedRotNum (F.toFamily hd) T q v s c).2 true) := by + have hqT : 0 < q ^ T := Nat.pow_pos hq + have hdiv : (s * q ^ T + c) / q ^ T = s := by + rw [Nat.add_comm, Nat.add_mul_div_right _ _ hqT, Nat.div_eq_of_lt hc, Nat.zero_add] + have hmod : (s * q ^ T + c) % q ^ T = c := by + rw [Nat.add_comm, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hc] + have hco : coinsOf q T (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) = List.replicate c true := by + rw [coinsOf, Cobham.sndBlock_pair, Cobham.sndBlock_pair, modC_eq hqT, + List.length_replicate, hmod] + have htw : toWalk q T (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) + = pair (encGraph G) (pair (List.replicate v true) (List.replicate s true)) := by + rw [toWalk, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, divC_eq hqT, List.length_replicate, hdiv] + have hstop : stopFn q (coinsOf q T) 0 T (pair (encGraph G) (pair (List.replicate v true) + (List.replicate (s * q ^ T + c) true))) = List.replicate (stopAtNum T q c) true := by + rw [stopFn_eq hq hco T 0, ← stopAtNum_eq_stopFromNum] + have hle : stopAtNum T q c ≤ T := by + have h : (List.finRange T).findIdx (fun j : Fin T => (c / q ^ j.val) % q == 0) + ≤ (List.finRange T).length := List.findIdx_le_length + rwa [List.length_finRange] at h + rw [killedRotFn, revNumFn, selectAt_eq hstop hle, selectAt_eq hstop hle, htw, + walkFn_eq F pol hd G v s hv hpc hpe, marks_revSum_eq hd G T v s _ hv hpc hpe, + marks_eq, length_mulC, List.length_replicate, hco, ConstraintGraph.killedRotNum] + dsimp only + congr 1 + rw [← List.replicate_add, G.killedRevNum_eq_revAtNum] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgLevel.lean b/Complexitylib/Classes/PCP/Internal/AlgLevel.lean new file mode 100644 index 00000000..2d0b10be --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgLevel.lean @@ -0,0 +1,316 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.TowerFin +public import Complexitylib.Classes.PCP.Internal.Materialize + +/-! +# Finding the tower level + +The expander family answers a request for `n` vertices with the first tower +member of at least `2 n` of them. An algorithm finds that member by counting: it +walks up the tower, multiplying the size by `deg ^ 4` at each level, and stops +at the first level large enough. + +The walk is one step of a loop, so `Cobham.iterate_mem_FP` runs it; the state is +the level so far and the size so far, carried beside the requested count. + +## Main definitions + +- `Complexity.levelStep` — one tick of the search + +## Main results + +- `Complexity.levelStep_iterate` — what the loop has found after `j` ticks +- `Complexity.levelStep_mem_FP` — the tick is polynomial time +- `Complexity.levelAfter_of_lt`, `Complexity.levelAfter_stable` — the loop + climbs until it is large enough, and then stays +- `Complexity.levelAfter_snd_le` — and never overshoots by more than a factor +- `Complexity.levelFn_mem_FP` — the search is polynomial time +- `Complexity.levelFn_length` — and finds the first level that is large enough +- `Complexity.pow_levelFn_le` — whatever level it reports, that level's size is + polynomially bounded +-/ + +@[expose] public section + +namespace Complexity + +/-- The loop's own model: after `j` ticks, the level and the size reached. -/ +def levelAfter (d n : ℕ) : ℕ → ℕ × ℕ → ℕ × ℕ + | 0, p => p + | j + 1, p => + let q := levelAfter d n j p + if q.2 < 2 * n then (q.1 + 1, q.2 * d) else q + +/-- One tick: if the size so far is below twice the request, take another +level. The state is `pair (pair (level so far) (size so far)) (the request)`. -/ +noncomputable def levelStep (d : ℕ) (st : List Bool) : List Bool := + ifLtLen (Cobham.sndBlock (Cobham.fstBlock st)) + (Cobham.sndBlock st ++ Cobham.sndBlock st) + (pair (pair (Cobham.fstBlock (Cobham.fstBlock st) ++ [true]) + ((marks (mulC d (Cobham.sndBlock (Cobham.fstBlock st)))).take + (List.replicate d true ++ mulC (2 * d) (Cobham.sndBlock st)).length)) + (Cobham.sndBlock st)) + st + +theorem levelStep_mem_FP (d : ℕ) : levelStep d ∈ FP := by + have hk : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hs : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hn : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hbound : (fun st : List Bool => + List.replicate d true ++ mulC (2 * d) (Cobham.sndBlock st)) ∈ FP := + Cobham.appendFn_mem_FP (constFn_mem_FP (List.replicate d true)) (mulC_mem_FP hn (2 * d)) + have hadv : (fun st : List Bool => + pair (pair (Cobham.fstBlock (Cobham.fstBlock st) ++ [true]) + ((marks (mulC d (Cobham.sndBlock (Cobham.fstBlock st)))).take + (List.replicate d true ++ mulC (2 * d) (Cobham.sndBlock st)).length)) + (Cobham.sndBlock st)) ∈ FP := + Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hk (constFn_mem_FP [true])) + (Cobham.takeLenFn_mem_FP hbound (marks_mem_FP (mulC_mem_FP hs d)))) hn + exact ifLtLen_mem_FP hs (Cobham.appendFn_mem_FP hn hn) hadv id_mem_FP + +theorem levelStep_apply (d k s : ℕ) (Z : List Bool) : + levelStep d (pair (pair (List.replicate k true) (List.replicate s true)) Z) + = if s < 2 * Z.length then + pair (pair (List.replicate (k + 1) true) (List.replicate (s * d) true)) Z + else pair (pair (List.replicate k true) (List.replicate s true)) Z := by + set n := Z.length with hn + rw [levelStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair] + have hlen : (Z ++ Z).length = 2 * n := by + simp only [List.length_append] + omega + by_cases h : s < 2 * n + · rw [if_pos h, ifLtLen_pos (by rw [List.length_replicate, hlen]; exact h), + marks_eq, length_mulC, List.length_replicate, ← List.replicate_succ'] + congr 2 + refine List.take_of_length_le ?_ + rw [List.length_replicate, List.length_append, List.length_replicate, length_mulC, ← hn] + nlinarith [h] + · rw [if_neg h, ifLtLen_neg (by rw [List.length_replicate, hlen]; exact h)] + +/-- **The loop's model runs the loop.** -/ +theorem levelStep_iterate (d : ℕ) (Z : List Bool) : + ∀ (j k s : ℕ), (levelStep d)^[j] + (pair (pair (List.replicate k true) (List.replicate s true)) Z) + = pair (pair (List.replicate (levelAfter d Z.length j (k, s)).1 true) + (List.replicate (levelAfter d Z.length j (k, s)).2 true)) Z := by + intro j + induction j with + | zero => intro k s; rfl + | succ j ih => + intro k s + rw [Function.iterate_succ_apply', ih k s, levelStep_apply, levelAfter] + by_cases h : (levelAfter d Z.length j (k, s)).2 < 2 * Z.length + · rw [if_pos h, if_pos h] + · rw [if_neg h, if_neg h] + +/-! ### What the loop settles on -/ + +/-- Until it is large enough, the loop is at level `j` with size `d ^ (j + 1)`. -/ +theorem levelAfter_of_lt (d n : ℕ) : + ∀ j, (∀ i < j, ¬ (2 * n ≤ d ^ (i + 1))) → levelAfter d n j (0, d) = (j, d ^ (j + 1)) := by + intro j + induction j with + | zero => intro _; simp [levelAfter] + | succ j ih => + intro h + have hj := ih fun i hi => h i (by omega) + rw [levelAfter, hj] + have hlt : d ^ (j + 1) < 2 * n := by + have := h j (by omega) + omega + rw [if_pos hlt] + refine Prod.ext rfl ?_ + show d ^ j * d * d = d ^ (j + 1 + 1) + rw [pow_succ, pow_succ] + +/-- Once it is large enough, the loop stays put. -/ +theorem levelAfter_stable (d n : ℕ) (p : ℕ × ℕ) (j : ℕ) (h : 2 * n ≤ (levelAfter d n j p).2) : + ∀ i, levelAfter d n (j + i) p = levelAfter d n j p := by + intro i + induction i with + | zero => rfl + | succ i ih => + have hji : j + (i + 1) = (j + i) + 1 := by omega + rw [hji, levelAfter, ih] + rw [if_neg (by omega)] + +/-- The loop never overshoots by more than a factor of `d`. -/ +theorem levelAfter_snd_le (d n : ℕ) : + ∀ j, (levelAfter d n j (0, d)).2 ≤ d + 2 * n * d := by + intro j + induction j with + | zero => simp [levelAfter] + | succ j ih => + rw [levelAfter] + by_cases h : (levelAfter d n j (0, d)).2 < 2 * n + · rw [if_pos h] + have : (levelAfter d n j (0, d)).2 * d ≤ 2 * n * d := Nat.mul_le_mul_right _ (by omega) + simpa using by omega + · rw [if_neg h] + exact ih + +/-- The size the loop carries is always the power the level names. -/ +theorem levelAfter_pow (d n : ℕ) : + ∀ j, (levelAfter d n j (0, d)).2 = d ^ ((levelAfter d n j (0, d)).1 + 1) := by + intro j + induction j with + | zero => simp [levelAfter] + | succ j ih => + rw [levelAfter] + by_cases h : (levelAfter d n j (0, d)).2 < 2 * n + · rw [if_pos h] + show (levelAfter d n j (0, d)).2 * d = d ^ ((levelAfter d n j (0, d)).1 + 1 + 1) + rw [ih] + ring + · rw [if_neg h] + exact ih + +/-- **The level the loop reaches names a size below `d + 2 n d`.** -/ +theorem pow_levelAfter_le (d n : ℕ) (j : ℕ) : + d ^ ((levelAfter d n j (0, d)).1 + 1) ≤ d + 2 * n * d := by + rw [← levelAfter_pow d n j] + exact levelAfter_snd_le d n j + +/-! ### The search as one function -/ + +/-- The shape of the state after `j` ticks: a level of at most `j` marks and a +size the clamp keeps below `d + 2 |z| d`, beside the request. -/ +theorem levelStep_iterate_shape (d : ℕ) (z : List Bool) : + ∀ j, ∃ K S : List Bool, + (levelStep d)^[j] (pair (pair [] (List.replicate d true)) z) = pair (pair K S) z + ∧ K.length ≤ j ∧ S.length ≤ d + 2 * z.length * d := by + intro j + induction j with + | zero => + refine ⟨[], List.replicate d true, rfl, by simp, ?_⟩ + rw [List.length_replicate] + omega + | succ j ih => + obtain ⟨K, S, hst, hK, hS⟩ := ih + rw [Function.iterate_succ_apply', hst, levelStep, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + by_cases h : S.length < (z ++ z).length + · refine ⟨K ++ [true], + (marks (mulC d S)).take (List.replicate d true ++ mulC (2 * d) z).length, ?_, ?_, ?_⟩ + · rw [ifLtLen_pos h] + · rw [List.length_append, List.length_cons, List.length_nil] + omega + · rw [List.length_take, List.length_append, List.length_replicate, length_mulC, + show d + z.length * (2 * d) = d + 2 * z.length * d from by ring] + exact Nat.min_le_left _ _ + · exact ⟨K, S, by rw [ifLtLen_neg h], by omega, hS⟩ + +theorem levelStep_iterate_length_le (d : ℕ) (z : List Bool) (j : ℕ) : + ((levelStep d)^[j] (pair (pair [] (List.replicate d true)) z)).length + ≤ 2 * (2 * j + 2 + (d + 2 * z.length * d)) + 2 + z.length := by + obtain ⟨K, S, hst, hK, hS⟩ := levelStep_iterate_shape d z j + rw [hst, pair_length, pair_length] + omega + +/-- The polynomial that bounds the loop's state. -/ +noncomputable def levelWidth (d : ℕ) (p : Polynomial ℕ) : Polynomial ℕ := + Polynomial.C 4 * p + Polynomial.C (2 * d + 6) + + Polynomial.C (4 * d + 1) * Polynomial.X + +/-- **The tower level for a requested count**, as one function: run the search +for polynomially many ticks and read off the level. -/ +noncomputable def levelFn (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : List Bool := + Cobham.fstBlock (Cobham.fstBlock + ((levelStep d)^[(polyRuler p z).length] (pair (pair [] (List.replicate d true)) z))) + +theorem levelFn_mem_FP (d : ℕ) (p : Polynomial ℕ) : levelFn d p ∈ FP := by + have hinit : (fun z : List Bool => pair (pair [] (List.replicate d true)) z) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP (pair [] (List.replicate d true))) id_mem_FP + have hruler : (fun z : List Bool => polyRuler p z) ∈ FP := polyRulerFn_mem_FP p id_mem_FP + have hwidth : (fun z : List Bool => polyRuler (levelWidth d p) z) ∈ FP := + polyRulerFn_mem_FP _ id_mem_FP + have hbound : ∀ z : List Bool, ∀ j ≤ (polyRuler p z).length, + ((levelStep d)^[j] (pair (pair [] (List.replicate d true)) z)).length + ≤ (polyRuler (levelWidth d p) z).length := by + intro z j hj + rw [polyRuler_length] at hj ⊢ + refine le_trans (levelStep_iterate_length_le d z j) ?_ + have heval : (levelWidth d p).eval z.length + = 4 * p.eval z.length + (2 * d + 6) + (4 * d + 1) * z.length := by + simp only [levelWidth, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X] + rw [heval] + nlinarith [hj] + have hiter := Cobham.iterate_mem_FP (levelStep_mem_FP d) hinit hruler hwidth hbound + have hproj := mem_FP_comp (mem_FP_comp hiter Cobham.fstBlock_mem_FP) Cobham.fstBlock_mem_FP + exact mem_FP_of_eq hproj fun z => rfl + +/-- The size at the level the search reports. -/ +noncomputable def sizeFn (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : List Bool := + Cobham.sndBlock (Cobham.fstBlock + ((levelStep d)^[(polyRuler p z).length] (pair (pair [] (List.replicate d true)) z))) + +theorem sizeFn_mem_FP (d : ℕ) (p : Polynomial ℕ) : sizeFn d p ∈ FP := by + have hinit : (fun z : List Bool => pair (pair [] (List.replicate d true)) z) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP (pair [] (List.replicate d true))) id_mem_FP + have hruler : (fun z : List Bool => polyRuler p z) ∈ FP := polyRulerFn_mem_FP p id_mem_FP + have hwidth : (fun z : List Bool => polyRuler (levelWidth d p) z) ∈ FP := + polyRulerFn_mem_FP _ id_mem_FP + have hbound : ∀ z : List Bool, ∀ j ≤ (polyRuler p z).length, + ((levelStep d)^[j] (pair (pair [] (List.replicate d true)) z)).length + ≤ (polyRuler (levelWidth d p) z).length := by + intro z j hj + rw [polyRuler_length] at hj ⊢ + refine le_trans (levelStep_iterate_length_le d z j) ?_ + have heval : (levelWidth d p).eval z.length + = 4 * p.eval z.length + (2 * d + 6) + (4 * d + 1) * z.length := by + simp only [levelWidth, Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X] + rw [heval] + nlinarith [hj] + have hiter := Cobham.iterate_mem_FP (levelStep_mem_FP d) hinit hruler hwidth hbound + have hproj := mem_FP_comp (mem_FP_comp hiter Cobham.fstBlock_mem_FP) Cobham.sndBlock_mem_FP + exact mem_FP_of_eq hproj fun z => rfl + +/-- **The size the search reports is the power its level names.** -/ +theorem sizeFn_length (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : + (sizeFn d p z).length = d ^ ((levelFn d p z).length + 1) := by + have hinit : (pair ([] : List Bool) (List.replicate d true)) + = pair (List.replicate 0 true) (List.replicate d true) := rfl + rw [sizeFn, levelFn, hinit, levelStep_iterate d z _ 0 d, Cobham.fstBlock_pair, + Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, List.length_replicate] + exact levelAfter_pow d z.length _ + +/-- **The search finds the first level that is large enough.** -/ +theorem levelFn_length (d : ℕ) (p : Polynomial ℕ) (z : List Bool) (L : ℕ) + (hL : 2 * z.length ≤ d ^ (L + 1)) (hmin : ∀ i < L, ¬ (2 * z.length ≤ d ^ (i + 1))) + (hp : L ≤ p.eval z.length) : + (levelFn d p z).length = L := by + have hinit : (pair ([] : List Bool) (List.replicate d true)) + = pair (List.replicate 0 true) (List.replicate d true) := rfl + have hL' : levelAfter d z.length L (0, d) = (L, d ^ (L + 1)) := levelAfter_of_lt d z.length L hmin + have hstable : ∀ i, levelAfter d z.length (L + i) (0, d) = (L, d ^ (L + 1)) := by + intro i + rw [levelAfter_stable d z.length (0, d) L (by rw [hL']; exact hL) i, hL'] + obtain ⟨i, hi⟩ : ∃ i, p.eval z.length = L + i := ⟨p.eval z.length - L, by omega⟩ + rw [levelFn, hinit, polyRuler_length, hi, levelStep_iterate d z (L + i) 0 d, hstable i, + Cobham.fstBlock_pair, Cobham.fstBlock_pair, List.length_replicate] + +/-- **Whatever level the search reports, its size is bounded** — which is what +lets the table at that level be written down. -/ +theorem pow_levelFn_le (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : + d ^ ((levelFn d p z).length + 1) ≤ d + 2 * z.length * d := by + have hinit : (pair ([] : List Bool) (List.replicate d true)) + = pair (List.replicate 0 true) (List.replicate d true) := rfl + have hlen : (levelFn d p z).length + = (levelAfter d z.length (polyRuler p z).length (0, d)).1 := by + rw [levelFn, hinit, levelStep_iterate d z _ 0 d, Cobham.fstBlock_pair, + Cobham.fstBlock_pair, List.length_replicate] + rw [hlen] + exact pow_levelAfter_le d z.length _ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgLog.lean b/Complexitylib/Classes/PCP/Internal/AlgLog.lean new file mode 100644 index 00000000..ec138c84 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgLog.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Materialize + +/-! +# A ruler of logarithmic length + +Amplification runs logarithmically many rounds, and the bounded-iteration rule +counts rounds by the *length* of a string. So an algorithm needs to write a +string whose length is the logarithm of its input's — the one shrinking step the +rest of the development never needed. + +The construction folds over the input carrying two counters: a ruler, and a +threshold that doubles. Every time the number of bits read reaches the +threshold, the ruler gains a mark and the threshold doubles, so the ruler counts +the doublings. + +## Main definitions + +- `Complexity.logStep` — one step of that fold +- `Complexity.logRuler` — the ruler itself + +## Main results + +- `Complexity.logRuler_mem_FP` — it is an `FP` function +-/ + +@[expose] public section + +namespace Complexity + +/-- How long the ruler is after reading `n` bits: it gains a mark exactly when +the count reaches the next power of two. -/ +def rulerLen : ℕ → ℕ + | 0 => 0 + | n + 1 => if n + 1 < 2 ^ rulerLen n then rulerLen n else rulerLen n + 1 + +/-- One step of the ruler fold, on `pair (pair W acc) t` where `acc` is +`pair ruler threshold`: on reaching the threshold, add a mark and double. -/ +noncomputable def logStep (z : List Bool) : List Bool := + ifLtLen (Cobham.sndBlock z) (dropOne (Cobham.sndBlock (Cobham.sndBlock + (Cobham.fstBlock z)))) + (Cobham.sndBlock (Cobham.fstBlock z)) + (pair (Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock z)) ++ [true]) + (Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock z)) + ++ Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock z)))) + +theorem logStep_mem_FP : logStep ∈ FP := by + have hacc : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hr : (fun z : List Bool => + Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := + mem_FP_comp hacc Cobham.fstBlock_mem_FP + have hth : (fun z : List Bool => + Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := + mem_FP_comp hacc Cobham.sndBlock_mem_FP + exact ifLtLen_mem_FP Cobham.sndBlock_mem_FP (dropOneFn_mem_FP hth) hacc + (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hr (constFn_mem_FP [true])) + (Cobham.appendFn_mem_FP hth hth)) + +theorem rulerLen_le (n : ℕ) : rulerLen n ≤ n := by + induction n with + | zero => rfl + | succ n ih => + rw [rulerLen] + split <;> omega + +theorem two_pow_rulerLen_le (n : ℕ) : 2 ^ rulerLen n ≤ 2 * n + 1 := by + induction n with + | zero => simp [rulerLen] + | succ n ih => + rw [rulerLen] + by_cases h : n + 1 < 2 ^ rulerLen n + · rw [if_pos h] + omega + · rw [if_neg h, pow_succ] + omega + +theorem lt_two_pow_rulerLen (n : ℕ) : n < 2 ^ rulerLen n := by + induction n with + | zero => simp [rulerLen] + | succ n ih => + rw [rulerLen] + by_cases h : n + 1 < 2 ^ rulerLen n + · rw [if_pos h] + exact h + · rw [if_neg h, pow_succ] + omega + +/-- **The ruler is at least the binary logarithm.** -/ +theorem log_lt_rulerLen (n : ℕ) (hn : n ≠ 0) : Nat.log 2 n < rulerLen n := + Nat.log_lt_of_lt_pow hn (lt_two_pow_rulerLen n) + +theorem rulerLen_pos {n : ℕ} (hn : 0 < n) : 0 < rulerLen n := by + cases n with + | zero => omega + | succ n => + rw [rulerLen] + split + · rename_i h + by_contra hc + have h0 : rulerLen n = 0 := by omega + rw [h0] at h + simp at h + · omega + +/-- The ruler is at most a logarithm: `2 ^ rulerLen n ≤ 2n + 1`. -/ +theorem rulerLen_le_log (n : ℕ) : rulerLen n ≤ Nat.log 2 (2 * n + 1) := by + refine le_trans (le_of_eq (Nat.log_pow (b := 2) (by omega) (rulerLen n)).symm) ?_ + exact Nat.log_mono_right (two_pow_rulerLen_le n) + +/-- **A ruler over a polynomially bounded quantity is logarithmic.** -/ +theorem rulerLen_bigO_log {N : ℕ → ℕ} {A B : ℕ} (hN : ∀ n, N n ≤ A * (n + 1) ^ B) : + (fun n => rulerLen (N n)) =O (fun n => Nat.log 2 n) := by + refine Asymptotics.IsBigO.of_bound (Nat.log 2 A + 2 * B + 6) ?_ + filter_upwards [Filter.eventually_ge_atTop 2] with n hn + simp only [Real.norm_natCast] + have hlog : 1 ≤ Nat.log 2 n := Nat.log_pos (by omega) hn + have hA : A ≤ 2 ^ (Nat.log 2 A + 1) := le_of_lt (Nat.lt_pow_succ_log_self (by omega) A) + have hn1 : n + 1 ≤ 2 ^ (Nat.log 2 n + 1) := by + have := Nat.lt_pow_succ_log_self (b := 2) (by omega) n + omega + have hpow : (n + 1) ^ B ≤ 2 ^ ((Nat.log 2 n + 1) * B) := by + rw [pow_mul] + exact Nat.pow_le_pow_left hn1 B + have hbound : 2 * N n + 1 ≤ 2 ^ (Nat.log 2 A + 3 + (Nat.log 2 n + 1) * B) := by + have h1 : N n ≤ 2 ^ (Nat.log 2 A + 1) * 2 ^ ((Nat.log 2 n + 1) * B) := + le_trans (hN n) (Nat.mul_le_mul hA hpow) + have h2 : 2 ^ (Nat.log 2 A + 3 + (Nat.log 2 n + 1) * B) + = 4 * (2 ^ (Nat.log 2 A + 1) * 2 ^ ((Nat.log 2 n + 1) * B)) := by + rw [← pow_add] + rw [show (4 : ℕ) = 2 ^ 2 from rfl, ← pow_add] + congr 1 + ring + have h3 : 0 < 2 ^ (Nat.log 2 A + 1) * 2 ^ ((Nat.log 2 n + 1) * B) := + Nat.mul_pos (Nat.two_pow_pos _) (Nat.two_pow_pos _) + omega + have hle : rulerLen (N n) ≤ Nat.log 2 A + 3 + (Nat.log 2 n + 1) * B := by + refine le_trans (rulerLen_le_log (N n)) ?_ + refine le_trans (Nat.log_mono_right hbound) ?_ + rw [Nat.log_pow (by omega)] + have hfin : rulerLen (N n) ≤ (Nat.log 2 A + 2 * B + 6) * Nat.log 2 n := by + have hmul : (Nat.log 2 n + 1) * B ≤ 2 * B * Nat.log 2 n := by + have : Nat.log 2 n + 1 ≤ 2 * Nat.log 2 n := by omega + calc (Nat.log 2 n + 1) * B ≤ (2 * Nat.log 2 n) * B := Nat.mul_le_mul_right _ this + _ = 2 * B * Nat.log 2 n := by ring + have hconst : Nat.log 2 A + 3 ≤ (Nat.log 2 A + 6) * Nat.log 2 n := by + calc Nat.log 2 A + 3 ≤ (Nat.log 2 A + 6) * 1 := by omega + _ ≤ (Nat.log 2 A + 6) * Nat.log 2 n := Nat.mul_le_mul_left _ hlog + calc rulerLen (N n) ≤ Nat.log 2 A + 3 + (Nat.log 2 n + 1) * B := hle + _ ≤ (Nat.log 2 A + 6) * Nat.log 2 n + 2 * B * Nat.log 2 n := by omega + _ = (Nat.log 2 A + 2 * B + 6) * Nat.log 2 n := by ring + exact_mod_cast hfin + +/-- **The fold's value after reading a list.** -/ +theorem logFold_eq (bound : ℕ) : ∀ z : List Bool, 4 * z.length + 4 ≤ bound → + Cobham.recFoldClamp logStep logStep bound (pair [] [true]) [] z + = pair (List.replicate (rulerLen z.length) true) + (List.replicate (2 ^ rulerLen z.length) true) := by + intro z + induction z with + | nil => + intro _ + rw [Cobham.recFoldClamp] + show (pair [] [true]).take bound = pair (List.replicate (rulerLen 0) true) + (List.replicate (2 ^ rulerLen 0) true) + rw [show rulerLen 0 = 0 from rfl] + simp only [pow_zero, List.replicate_zero, List.replicate_one] + rw [List.take_of_length_le] + simp + omega + | cons b t ih => + intro hb + have hbt : 4 * t.length + 4 ≤ bound := by simp at hb ⊢; omega + have hpow := two_pow_rulerLen_le (t.length + 1) + have hlen := rulerLen_le (t.length + 1) + rw [Cobham.recFoldClamp] + simp only [Bool.cond_self] + rw [ih hbt, logStep] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, dropOne] + have hb' : 4 * t.length + 8 ≤ bound := by simp at hb; omega + by_cases h : t.length < 2 ^ rulerLen t.length - 1 + · rw [ifLtLen_pos (by simpa using h), List.length_cons, + show rulerLen (t.length + 1) = rulerLen t.length from by + rw [rulerLen] + exact if_pos (by omega)] + refine List.take_of_length_le ?_ + rw [pair_length, List.length_replicate, List.length_replicate] + have h1 := rulerLen_le t.length + have h2 := two_pow_rulerLen_le t.length + omega + · rw [ifLtLen_neg (by simpa using h), List.length_cons, + show rulerLen (t.length + 1) = rulerLen t.length + 1 from by + rw [rulerLen] + exact if_neg (by omega), + ← List.replicate_add, ← two_mul, ← pow_succ', ← List.replicate_succ'] + refine List.take_of_length_le ?_ + rw [pair_length, List.length_replicate, List.length_replicate] + have h1 := rulerLen_le (t.length + 1) + have h2 := two_pow_rulerLen_le (t.length + 1) + rw [show rulerLen (t.length + 1) = rulerLen t.length + 1 from by + rw [rulerLen] + exact if_neg (by omega)] at h1 h2 + omega + +/-- The fold itself, on `pair W z`. -/ +noncomputable def logRulerRaw (w : List Bool) : List Bool := + Cobham.recFoldClamp logStep logStep (4 * w.length + 4) (pair [] [true]) + (Cobham.fstBlock w) (Cobham.sndBlock w) + +theorem logRulerRaw_mem_FP : logRulerRaw ∈ FP := by + refine mem_FP_of_eq (Cobham.recFoldClamp_mem_FP logStep_mem_FP logStep_mem_FP + (constFn_mem_FP (pair [] [true])) (4 * Polynomial.X + 4)) fun w => ?_ + rw [logRulerRaw] + simp + +/-- **A ruler of logarithmic length.** -/ +noncomputable def logRuler (z : List Bool) : List Bool := + Cobham.fstBlock (logRulerRaw (pair [] z)) + +theorem logRuler_mem_FP : logRuler ∈ FP := + mem_FP_of_eq (mem_FP_comp (Cobham.pairFn_mem_FP (constFn_mem_FP []) id_mem_FP) + (mem_FP_comp logRulerRaw_mem_FP Cobham.fstBlock_mem_FP)) fun _ => rfl + +/-- **The ruler is as long as the fold says.** -/ +theorem logRuler_eq (z : List Bool) : + logRuler z = List.replicate (rulerLen z.length) true := by + rw [logRuler, logRulerRaw, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + logFold_eq _ z (by rw [pair_length]; simp), Cobham.fstBlock_pair] + +@[simp] theorem length_logRuler (z : List Bool) : + (logRuler z).length = rulerLen z.length := by + rw [logRuler_eq, List.length_replicate] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgPCP.lean b/Complexitylib/Classes/PCP/Internal/AlgPCP.lean new file mode 100644 index 00000000..3cd08e92 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgPCP.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgGapCSP +public import Complexitylib.Classes.PCP.Internal.SquareVerifier + +/-! +# Every NP language has a PCP verifier + +The pieces are all in place: an `NP` language is the satisfiability of an `FP` +family of 3-CNFs, the gap reduction turns each into a constraint graph with a +constant gap, that graph is written by an `FP` function, and a verifier reading +one edge of it accepts members always and non-members with probability bounded +away from one. + +## Main definitions + +- `Complexity.gapNumEdges` — how many edges the gap graph of a length has + +## Main results + +- `Complexity.exists_pcp_of_mem_NP` — the hard half of the PCP theorem +-/ + +@[expose] public section + +set_option maxRecDepth 8000 + +namespace Complexity + +open SAT Dinur + +/-- The finite base the reduction's expander family comes from. -/ +noncomputable def algF : FinBase := algBase + +theorem algHd : 1 < algF.deg := one_lt_algBase_deg + +/-- How many edges the gap graph of an input of length `n` has: the padded +count, multiplied by the round's factor once per round. -/ +noncomputable def gapNumEdges (q : Polynomial ℕ) (n : ℕ) : ℕ := + edgeFactor (algF.toFamily algHd) (qOf algF algHd) ^ rulerLen (q.eval n) * q.eval n + +theorem gapNumEdges_pos {q : Polynomial ℕ} {n : ℕ} (hq : 0 < q.eval n) : + 0 < gapNumEdges q n := + Nat.mul_pos (Nat.pow_pos (one_le_edgeFactor algF algHd)) hq + +/-- The gap graph's size is polynomial in the input's length. -/ +theorem gapNumEdges_polyBounded (q : Polynomial ℕ) : PolyBounded (gapNumEdges q) := by + have hq : PolyBounded fun n => q.eval n := polyBounded_eval q + refine PolyBounded.mono (PolyBounded.mul + (PolyBounded.pow (PolyBounded.add (PolyBounded.mul (PolyBounded.const 2) hq) + (PolyBounded.const 1)) (growthExp algF algHd)) hq) fun n => ?_ + exact Nat.mul_le_mul_right _ (pow_edgeFactor_le algF algHd (q.eval n)) + +/-- **The coin count**: enough for the gap graph's edges, and no more than one +too many. -/ +noncomputable def gapCoins (q : Polynomial ℕ) (n : ℕ) : ℕ := rulerLen (gapNumEdges q n) + +theorem le_two_pow_gapCoins (q : Polynomial ℕ) (n : ℕ) : + gapNumEdges q n ≤ 2 ^ gapCoins q n := + le_of_lt (lt_two_pow_rulerLen _) + +theorem two_pow_gapCoins_le {q : Polynomial ℕ} {n : ℕ} (hq : 0 < q.eval n) : + 2 ^ gapCoins q n ≤ 2 * gapNumEdges q n := by + have hpos := gapNumEdges_pos (q := q) (n := n) hq + have hle := two_pow_rulerLen_le (gapNumEdges q n) + have hone : 0 < rulerLen (gapNumEdges q n) := rulerLen_pos hpos + have heven : 2 ∣ 2 ^ gapCoins q n := dvd_pow_self 2 (by rw [gapCoins]; omega) + obtain ⟨c, hc⟩ := heven + have hgc : gapCoins q n = rulerLen (gapNumEdges q n) := rfl + rw [hgc] at hc + rw [hgc] + omega + +theorem gapCoins_bigO_log (q : Polynomial ℕ) : + gapCoins q =O fun n => Nat.log 2 n := by + obtain ⟨A, B, hAB⟩ := gapNumEdges_polyBounded q + exact rulerLen_bigO_log hAB + +/-- Doubling a constructible bound `j` times keeps it constructible. -/ +theorem constructible_pow_mul {t : ℕ → ℕ} + (ht : (fun x : List Bool => List.replicate (t x.length) true) ∈ FP) (j : ℕ) : + (fun x : List Bool => List.replicate (2 ^ j * t x.length) true) ∈ FP := by + induction j with + | zero => simpa using ht + | succ j ih => + refine mem_FP_of_eq (constructible_double (r := fun n => 2 ^ j * t n) ih) fun x => ?_ + congr 1 + ring + +/-! ### The edge count of the algorithmic graph -/ + +theorem numEdges_gapAlg_eq {E padU : List Bool → List Bool} {Φ : List Bool → CNF} + (hgap : gapAll algF algHd E padU ∈ FP) + (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (hmark : ∀ x, padU x = List.replicate (padU x).length true) + (hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length) {q : Polynomial ℕ} + (hq : ∀ x, (padU x).length = q.eval x.length) (x : List Bool) : + (gapAlg algF algHd E padU hgap).numEdges x = gapNumEdges q x.length := by + rw [numEdges_gapAlg, gapAll_eq algF algHd E padU hE h3 hmark hle x, gEdges_encGraph, + gapAllG, numEdges_iterStep, ConstraintGraph.numEdges_padGraph, numEdges_baseCSP, + max_eq_left (by have := hle x; omega), hq, gapNumEdges] + +/-! ### The verifier -/ + +open scoped Complexity in +/-- **Every `NP` language has a PCP verifier** with logarithmically many coins +and constantly many queries. -/ +theorem exists_pcp_of_mem_NP {L : Language} (hL : L ∈ NP) : + ∃ r qc : ℕ → ℕ, r =O (fun n => Nat.log 2 n) ∧ Constructible r + ∧ qc =O (fun _ => 1) ∧ L ∈ PCP r qc := by + classical + obtain ⟨E, Φ, hEfp, hEeq, h3, hLiff⟩ := exists_reduction_cnf hL + obtain ⟨pad0, q0, hpad0fp, hmark0, hq0, hle0⟩ := exists_padRuler hEfp 3 + set padU : List Bool → List Bool := fun x => pad0 x ++ [true] with hpadU + set q : Polynomial ℕ := q0 + 1 with hqdef + have hpadfp : padU ∈ FP := Cobham.appendFn_mem_FP hpad0fp (constFn_mem_FP [true]) + have hlen : ∀ x, (padU x).length = (pad0 x).length + 1 := by + intro x + rw [hpadU] + simp + have hmark : ∀ x, padU x = List.replicate (padU x).length true := by + intro x + rw [hlen x, List.replicate_succ', ← hmark0 x, hpadU] + have hq : ∀ x : List Bool, (padU x).length = q.eval x.length := by + intro x + rw [hlen x, hq0 x, hqdef, Polynomial.eval_add, Polynomial.eval_one] + have hqpos : ∀ n, 0 < q.eval n := by + intro n + rw [hqdef, Polynomial.eval_add, Polynomial.eval_one] + omega + have hle : ∀ x, 3 * (Φ x).length ≤ (padU x).length := by + intro x + have h1 := hle0 x + have h2 := length_le_length_encode (Φ x) + rw [← hEeq x] at h2 + rw [hlen x] + omega + obtain ⟨p0, hp0⟩ := exists_length_bound hEfp + have hgap : gapAll algF algHd E padU ∈ FP := + gapAll_mem_FP algF algHd E padU hEfp hpadfp hEeq h3 hmark hle p0 q hp0 hq + have hmodels := gapAlg_models algF algHd E padU hgap hEeq h3 hmark hle + have hNE : ∀ x, (gapAlg algF algHd E padU hgap).numEdges x = gapNumEdges q x.length := + fun x => numEdges_gapAlg_eq hgap hEeq h3 hmark hle hq x + have ht : (fun x : List Bool => List.replicate (gapCoins q x.length) true) ∈ FP := by + have hfp : (fun x : List Bool => + logRuler (posCount (Cobham.sndBlock (gapAll algF algHd E padU x)))) ∈ FP := + mem_FP_of_eq (mem_FP_comp (gEdgesFn_mem_FP hgap) logRuler_mem_FP) fun _ => rfl + refine mem_FP_of_eq hfp fun x => ?_ + have h : gEdges (gapAll algF algHd E padU x) = gapNumEdges q x.length := by + rw [← numEdges_gapAlg algF algHd E padU hgap x] + exact hNE x + rw [logRuler_eq, length_posCount_sndBlock, h, gapCoins] + obtain ⟨Ac, Bc, hABc⟩ := gapNumEdges_polyBounded q + have hclamp : ∀ n : ℕ, 2 ^ gapCoins q n + ≤ (Polynomial.C (2 * Ac + 1) * (Polynomial.X + 1) ^ Bc).eval + (2 * n + 2 + gapCoins q n) := by + intro n + have h1 : 2 ^ gapCoins q n ≤ 2 * gapNumEdges q n := two_pow_gapCoins_le (hqpos n) + have h2 : gapNumEdges q n ≤ Ac * (n + 1) ^ Bc := hABc n + have h4 : (n + 1) ^ Bc ≤ (2 * n + 2 + gapCoins q n + 1) ^ Bc := + Nat.pow_le_pow_left (by omega) _ + have h5 : (Polynomial.C (2 * Ac + 1) * (Polynomial.X + 1) ^ Bc).eval + (2 * n + 2 + gapCoins q n) + = (2 * Ac + 1) * (2 * n + 2 + gapCoins q n + 1) ^ Bc := by + rw [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, + Polynomial.eval_add, Polynomial.eval_X, Polynomial.eval_one] + have h6 : 2 * (Ac * (n + 1) ^ Bc) + ≤ (2 * Ac + 1) * (2 * n + 2 + gapCoins q n + 1) ^ Bc := by + calc 2 * (Ac * (n + 1) ^ Bc) = (2 * Ac) * (n + 1) ^ Bc := by ring + _ ≤ (2 * Ac + 1) * (2 * n + 2 + gapCoins q n + 1) ^ Bc := + Nat.mul_le_mul (by omega) h4 + rw [h5] + omega + have hcomp : ∀ x ∈ L, ∃ π : List Bool, + ∀ e < (gapAlg algF algHd E padU hgap).numEdges x, + (gapAlg algF algHd E padU hgap).Sat x π e := by + intro x hx + exact hmodels.sat_of_satisfiable x + (satisfiable_gapAllG algF algHd padU h3 hle x ((hLiff x).mp hx)) + have hsound : ∀ x ∉ L, ∀ π : List Bool, + (((Finset.range ((gapAlg algF algHd E padU hgap).numEdges x)).filter + ((gapAlg algF algHd E padU hgap).Sat x π)).card : ℚ) + ≤ (1 - (Dinur.amplifier (algF.toFamily algHd)).gap) + * (gapAlg algF algHd E padU hgap).numEdges x := by + intro x hx π + exact hmodels.card_sat_le x + (gap_le_unsatVal_gapAllG algF algHd padU h3 hle x + (fun hs => hx ((hLiff x).mpr hs))) π + obtain ⟨j, hj⟩ := mem_PCP_of_algCSP (gapAlg algF algHd E padU hgap) + (Polynomial.C (2 * Ac + 1) * (Polynomial.X + 1) ^ Bc) (gapCoins q) ht hclamp + (fun x => by rw [hNE x]; exact le_two_pow_gapCoins q x.length) + (fun x => by rw [hNE x]; exact two_pow_gapCoins_le (hqpos x.length)) + (Dinur.amplifier (algF.toFamily algHd)).gap_pos + (Dinur.amplifier (algF.toFamily algHd)).gap_le_one hcomp hsound + refine ⟨fun n => 2 ^ j * gapCoins q n, + fun _ => 2 ^ j * (2 * (gapAlg algF algHd E padU hgap).width), ?_, ?_, ?_, hj⟩ + · exact BigO.const_mul_left _ (gapCoins_bigO_log q) + · exact constructible_pow_mul ht j + · have h := BigO.const_mul_left (2 ^ j * (2 * (gapAlg algF algHd E padU hgap).width)) + (BigO.refl fun _ : ℕ => 1) + simpa using h + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean b/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean new file mode 100644 index 00000000..e8f4f785 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgCompose +public import Complexitylib.Classes.PCP.Internal.AlgPreRel +public import Complexitylib.Classes.PCP.Internal.AlgStep + +/-! +# A composed position's number + +A read of the assembled tester lands in one of three kinds of block: the +encoding block of a vertex, a dart's linear table, or a dart's quadratic table. +Which kind, and which cube inside the block, depends only on the read and the +random string — with two exceptions, where the cube is shifted by the +arithmetization of the dart's satisfying set. Which *block*, on the other hand, +is a vertex or a dart of the outer graph, so it is the only part that grows with +the input. + +This module splits a position's number along that seam. + +## Main definitions + +- `Complexity.RegCSP.readKind` — which kind of block a read lands in +- `Complexity.RegCSP.blockNum`, `Complexity.RegCSP.cubeNum` — the block and the + cube inside it +- `Complexity.RegCSP.posNum` — the number the two make + +## Main results + +- `Complexity.RegCSP.enc_pos_compose` — that number is the position's +- `Complexity.RegCSP.val_head_toGraph_compose` — hence the second endpoint of a + composed edge +- `Complexity.RegCSP.satSet_congr`, `cubeNum_congr`, `check_congr` — all of it + depends on the outer system only through the dart's constraint +- `Complexity.satSet_eq_of_data`, `Complexity.cubeNum_eq_of_data`, + `Complexity.check_eq_of_data` — and for a killed power, only through the + walk's parities and codes, whatever graph it came from +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis Tester + +namespace RegCSP + +variable {β : Type} [Fintype β] [DecidableEq β] [Nonempty β] (R : RegCSP β) + [NumEnc R.graph.V] [NumEnc R.graph.D] {B : ℕ} (enc : β → Cube B) + +/-- Which kind of block a read's position lies in: an encoding block (`0`), a +dart's linear table (`1`), or a dart's quadratic table (`2`). -/ +def readKind : ReadIdx → ℕ + | .i5r | .i6r => 0 + | .g2x | .g2y | .g2s | .c3cQ | .c3tQ | .k4qG | .k4tG => 2 + | _ => 1 + +/-- The number of the vertex or dart whose block a read's position lies in. -/ +noncomputable def blockNum (p : R.Dart) : ReadIdx → ℕ + | .i5r => NumEnc.enc p.1 + | .i6r => NumEnc.enc (R.graph.nbr p.1 p.2) + | .f1x | .f1y | .f1s | .g2x | .g2y | .g2s | .c3cQ | .c3tQ | .c3cX | .c3xX | .c3cY | .c3yY + | .k4qG | .k4tG | .k4cF | .k4lF | .i5c | .i5b | .i6c | .i6b => NumEnc.enc p + +/-- The number of the cube a read's position names inside its block. -/ +noncomputable def cubeNum (p : R.Dart) (z : Cube (ROf B)) : ReadIdx → ℕ + | .f1x => NumEnc.enc (leftBlock (blk1 z)) + | .f1y => NumEnc.enc (rightBlock (blk1 z)) + | .f1s => NumEnc.enc (leftBlock (blk1 z) + rightBlock (blk1 z)) + | .g2x => NumEnc.enc (leftBlock (blk2 z)) + | .g2y => NumEnc.enc (rightBlock (blk2 z)) + | .g2s => NumEnc.enc (leftBlock (blk2 z) + rightBlock (blk2 z)) + | .c3cQ => NumEnc.enc (cQ (blk3 z)) + | .c3tQ => NumEnc.enc (tensor (qX (blk3 z)) (qY (blk3 z)) + cQ (blk3 z)) + | .c3cX => NumEnc.enc (cX (blk3 z)) + | .c3xX => NumEnc.enc (qX (blk3 z) + cX (blk3 z)) + | .c3cY => NumEnc.enc (cY (blk3 z)) + | .c3yY => NumEnc.enc (qY (blk3 z) + cY (blk3 z)) + | .k4qG => NumEnc.enc (rightBlock (rightBlock (blk4 z))) + | .k4tG => NumEnc.enc ((QuadConstraint.combine (oneHotSystem (R.satSet enc p)) + (leftBlock (blk4 z))).quad + rightBlock (rightBlock (blk4 z))) + | .k4cF => NumEnc.enc (leftBlock (rightBlock (blk4 z))) + | .k4lF => NumEnc.enc ((QuadConstraint.combine (oneHotSystem (R.satSet enc p)) + (leftBlock (blk4 z))).lin + leftBlock (rightBlock (blk4 z))) + | .i5r => NumEnc.enc (leftBlock (blk5 z)) + | .i5c => NumEnc.enc (rightBlock (blk5 z)) + | .i5b => NumEnc.enc (basisVec (inTail B (leftBlock (blk5 z))) + rightBlock (blk5 z)) + | .i6r => NumEnc.enc (leftBlock (blk6 z)) + | .i6c => NumEnc.enc (rightBlock (blk6 z)) + | .i6b => NumEnc.enc (basisVec (inHead B (leftBlock (blk6 z))) + rightBlock (blk6 z)) + +/-- The number a kind, a block and a cube make: encoding blocks first, then the +linear tables, then the quadratic ones. -/ +def posNum (cardV cardD cardB cardN cardNN k w c : ℕ) : ℕ := + if k = 0 then w * cardB + c + else if k = 1 then cardV * cardB + (w * cardN + c) + else cardV * cardB + (cardV * cardD * cardN + (w * cardNN + c)) + +omit [DecidableEq β] [Nonempty β] in +/-- **A composed position's number.** -/ +theorem enc_pos_compose (p : R.Dart) (z : Cube (ROf B)) (i : ReadIdx) : + NumEnc.enc ((R.compose enc).pos p z i) + = posNum (NumEnc.card R.graph.V) (NumEnc.card R.graph.D) (NumEnc.card (Cube B)) + (NumEnc.card (Cube (nOf B))) (NumEnc.card (Cube (nOf B * nOf B))) + (readKind i) (R.blockNum p i) (R.cubeNum enc p z i) := by + cases i <;> rfl + +omit [Fintype β] [DecidableEq β] [Nonempty β] in +/-- **The block of an input read is the dart's tail**, which its number names by +division. -/ +theorem blockNum_i5r (p : R.Dart) : + R.blockNum p .i5r = NumEnc.enc p / NumEnc.card R.graph.D := by + have hlt : NumEnc.enc p.2 < NumEnc.card R.graph.D := NumEnc.enc_lt p.2 + rw [blockNum, R.enc_dart p, Nat.add_comm, + Nat.add_mul_div_right _ _ (Nat.lt_of_le_of_lt (Nat.zero_le _) hlt), + Nat.div_eq_of_lt hlt, Nat.zero_add] + +omit [Fintype β] [DecidableEq β] [Nonempty β] in +/-- **The block of the other input read is the dart's head.** -/ +theorem blockNum_i6r (p : R.Dart) : + R.blockNum p .i6r = NumEnc.enc (R.graph.rot p).1 := rfl + +omit [DecidableEq β] [Nonempty β] in +/-- **The second endpoint of a composed edge.** -/ +theorem val_head_toGraph_compose (k : Fin (Fintype.card (R.compose enc).Edge)) : + ((R.compose enc).toGraph.head k).val + = posNum (NumEnc.card R.graph.V) (NumEnc.card R.graph.D) (NumEnc.card (Cube B)) + (NumEnc.card (Cube (nOf B))) (NumEnc.card (Cube (nOf B * nOf B))) + (readKind ((R.compose enc).edgeOf k).2.2) + (R.blockNum ((R.compose enc).edgeOf k).1 ((R.compose enc).edgeOf k).2.2) + (R.cubeNum enc ((R.compose enc).edgeOf k).1 ((R.compose enc).edgeOf k).2.1 + ((R.compose enc).edgeOf k).2.2) := by + rw [MultiTest.val_head_toGraph, enc_pos_compose] + +/-- The cube a read names, from the satisfying set alone. -/ +noncomputable def cubeOfSet (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) : ReadIdx → ℕ + | .f1x => NumEnc.enc (leftBlock (blk1 z)) + | .f1y => NumEnc.enc (rightBlock (blk1 z)) + | .f1s => NumEnc.enc (leftBlock (blk1 z) + rightBlock (blk1 z)) + | .g2x => NumEnc.enc (leftBlock (blk2 z)) + | .g2y => NumEnc.enc (rightBlock (blk2 z)) + | .g2s => NumEnc.enc (leftBlock (blk2 z) + rightBlock (blk2 z)) + | .c3cQ => NumEnc.enc (cQ (blk3 z)) + | .c3tQ => NumEnc.enc (tensor (qX (blk3 z)) (qY (blk3 z)) + cQ (blk3 z)) + | .c3cX => NumEnc.enc (cX (blk3 z)) + | .c3xX => NumEnc.enc (qX (blk3 z) + cX (blk3 z)) + | .c3cY => NumEnc.enc (cY (blk3 z)) + | .c3yY => NumEnc.enc (qY (blk3 z) + cY (blk3 z)) + | .k4qG => NumEnc.enc (rightBlock (rightBlock (blk4 z))) + | .k4tG => NumEnc.enc ((QuadConstraint.combine (oneHotSystem S) + (leftBlock (blk4 z))).quad + rightBlock (rightBlock (blk4 z))) + | .k4cF => NumEnc.enc (leftBlock (rightBlock (blk4 z))) + | .k4lF => NumEnc.enc ((QuadConstraint.combine (oneHotSystem S) + (leftBlock (blk4 z))).lin + leftBlock (rightBlock (blk4 z))) + | .i5r => NumEnc.enc (leftBlock (blk5 z)) + | .i5c => NumEnc.enc (rightBlock (blk5 z)) + | .i5b => NumEnc.enc (basisVec (inTail B (leftBlock (blk5 z))) + rightBlock (blk5 z)) + | .i6r => NumEnc.enc (leftBlock (blk6 z)) + | .i6c => NumEnc.enc (rightBlock (blk6 z)) + | .i6b => NumEnc.enc (basisVec (inHead B (leftBlock (blk6 z))) + rightBlock (blk6 z)) + +/-- The test's verdict, from the satisfying set alone. -/ +noncomputable def checkOfSet (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) + (rd : ReadIdx → ZMod 2) : Bool := + decide (bitFormula S z rd) + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **The cube depends on the satisfying set alone.** -/ +theorem cubeNum_eq_cubeOfSet (p : R.Dart) (z : Cube (ROf B)) (i : ReadIdx) : + R.cubeNum enc p z i = cubeOfSet (R.satSet enc p) z i := by + cases i <;> rfl + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **And so does the verdict.** -/ +theorem check_eq_checkOfSet (p : R.Dart) (z : Cube (ROf B)) : + (R.compose enc).check p z = checkOfSet (R.satSet enc p) z := rfl + +omit [DecidableEq β] [Nonempty β] in +set_option maxHeartbeats 2000000 in +/-- **An edge's data and all three of its numbers**, in one package: a caller +never has to spell the composed system out, nor match anything against it. -/ +theorem edge_facts (e : ℕ) (he : e < (R.compose enc).toGraph.numEdges) : + ∃ (p : R.Dart) (z : Cube (ROf B)) (i : ReadIdx), + e = ((NumEnc.enc p.1 * NumEnc.card R.graph.D + NumEnc.enc p.2) * 2 ^ ROf B + + NumEnc.enc z) * 22 + NumEnc.enc i + ∧ ((R.compose enc).toGraph.tail ⟨e, he⟩).val = (R.compose enc).tailNum e + ∧ ((R.compose enc).toGraph.head ⟨e, he⟩).val + = posNum (NumEnc.card R.graph.V) (NumEnc.card R.graph.D) + (NumEnc.card (Cube B)) (NumEnc.card (Cube (nOf B))) + (NumEnc.card (Cube (nOf B * nOf B))) + (readKind i) (R.blockNum p i) (R.cubeNum enc p z i) + ∧ (R.compose enc).toGraph.rel ⟨e, he⟩ + = MultiTest.relOfCheck ((R.compose enc).check p z) i := by + obtain ⟨p, z, i, hp, hz, hi, hsplit⟩ := R.edge_data B enc e he + subst hp + subst hz + subst hi + refine ⟨_, _, _, hsplit, (MultiTest.tailNum_eq _ ⟨e, he⟩).symm, ?_, + MultiTest.rel_toGraph_eq _ ⟨e, he⟩⟩ + rw [MultiTest.val_head_toGraph, enc_pos_compose] + rfl + +/-! ### Everything depends on the dart's constraint alone -/ + +variable {R' : RegCSP β} [NumEnc R'.graph.V] [NumEnc R'.graph.D] + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] + [NumEnc R'.graph.V] [NumEnc R'.graph.D] in +/-- **The satisfying set depends only on the dart's constraint.** -/ +theorem satSet_congr (p : R.Dart) (p' : R'.Dart) + (h : R.rel p.1 p.2 = R'.rel p'.1 p'.2) : + R.satSet enc p = R'.satSet enc p' := by + rw [satSet, satSet, h] + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **So does the cube a read names**, even across two different systems. -/ +theorem cubeNum_congr {β' : Type} [Fintype β'] [DecidableEq β'] [Nonempty β'] + {R' : RegCSP β'} [NumEnc R'.graph.V] [NumEnc R'.graph.D] {enc' : β' → Cube B} + (p : R.Dart) (p' : R'.Dart) (z : Cube (ROf B)) (i : ReadIdx) + (h : R.satSet enc p = R'.satSet enc' p') : + R.cubeNum enc p z i = R'.cubeNum enc' p' z i := by + cases i <;> rw [cubeNum, cubeNum] <;> rw [h] + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **And so does the test's verdict.** -/ +theorem check_congr {β' : Type} [Fintype β'] [DecidableEq β'] [Nonempty β'] + {R' : RegCSP β'} [NumEnc R'.graph.V] [NumEnc R'.graph.D] {enc' : β' → Cube B} + (p : R.Dart) (p' : R'.Dart) (z : Cube (ROf B)) + (h : R.satSet enc p = R'.satSet enc' p') : + (R.compose enc).check p z = (R'.compose enc').check p' z := by + show (fun rd => decide (bitFormula (R.satSet enc p) z rd)) + = fun rd => decide (bitFormula (R'.satSet enc' p') z rd) + rw [h] + +end RegCSP + +/-! ### Across two graphs -/ + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] + +omit [Nonempty α] in +/-- **Two graphs whose walks show the same data have the same satisfying set.** +Both sides live in `Finset (Cube (kOf B))`, a type that does not mention either +graph. -/ +theorem satSet_eq_of_data (G G' : ConstraintGraph α) (E : ExpanderFamily) {q T B : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) (v' : (G'.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (encβ : KOpinion (G.preprocess E).graph T α → Cube B) + (hpar : (fun i : Fin ((G.preprocess E).graph.kLen x) => + NumEnc.enc ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) i.val) % 2) + = fun i : Fin ((G'.preprocess E).graph.kLen x) => + NumEnc.enc ((G'.preprocess E).graph.walkAt ((G'.preprocess E).graph.kLen x) v' + ((G'.preprocess E).graph.kWalk x) i.val) % 2) + (hcode : (fun i : Fin ((G.preprocess E).graph.kLen x) => + codeOfRel (G.rel ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) i.val).1)) + = fun i : Fin ((G'.preprocess E).graph.kLen x) => + codeOfRel (G'.rel ((G'.preprocess E).graph.walkAt ((G'.preprocess E).graph.kLen x) v' + ((G'.preprocess E).graph.kWalk x) i.val).1)) + (hend : (G.preprocess E).graph.endIdx ((G.preprocess E).graph.kLen_le x) v + ((G.preprocess E).graph.kWalk x) + = (G'.preprocess E).graph.endIdx ((G'.preprocess E).graph.kLen_le x) v' + ((G'.preprocess E).graph.kWalk x)) : + ((G.preprocess E).killedPow q T hq).satSet encβ (v, x) + = ((G'.preprocess E).killedPow q T hq).satSet encβ (v', x) := by + have h := rel_eq_of_data G G' E hq v v' x hpar hcode hend + show (Finset.univ.filter fun st : KOpinion (G.preprocess E).graph T α + × KOpinion (G.preprocess E).graph T α => + ((G.preprocess E).killedPow q T hq).rel v x st.1 st.2 = true).image + (fun st => RegCSP.inputVec encβ st.1 st.2) = _ + rw [h] + rfl + +/-- **The cube a read names is the same across two such graphs.** -/ +theorem cubeNum_eq_of_data (G G' : ConstraintGraph α) (E : ExpanderFamily) {q T B : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) (v' : (G'.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (encβ : KOpinion (G.preprocess E).graph T α → Cube B) (z : Cube (Tester.ROf B)) + (i : ReadIdx) + (h : ((G.preprocess E).killedPow q T hq).satSet encβ (v, x) + = ((G'.preprocess E).killedPow q T hq).satSet encβ (v', x)) : + ((G.preprocess E).killedPow q T hq).cubeNum encβ (v, x) z i + = ((G'.preprocess E).killedPow q T hq).cubeNum encβ (v', x) z i := + RegCSP.cubeNum_congr (R := (G.preprocess E).killedPow q T hq) (enc := encβ) + (R' := (G'.preprocess E).killedPow q T hq) (enc' := encβ) (v, x) (v', x) z i h + +/-- **And so is the test's verdict.** -/ +theorem check_eq_of_data (G G' : ConstraintGraph α) (E : ExpanderFamily) {q T B : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) (v' : (G'.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (encβ : KOpinion (G.preprocess E).graph T α → Cube B) (z : Cube (Tester.ROf B)) + (h : ((G.preprocess E).killedPow q T hq).satSet encβ (v, x) + = ((G'.preprocess E).killedPow q T hq).satSet encβ (v', x)) : + (((G.preprocess E).killedPow q T hq).compose encβ).check (v, x) z + = (((G'.preprocess E).killedPow q T hq).compose encβ).check (v', x) z := + RegCSP.check_congr (R := (G.preprocess E).killedPow q T hq) (enc := encβ) + (R' := (G'.preprocess E).killedPow q T hq) (enc' := encβ) (v, x) (v', x) z h + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgPreRel.lean b/Complexitylib/Classes/PCP/Internal/AlgPreRel.lean new file mode 100644 index 00000000..49930744 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgPreRel.lean @@ -0,0 +1,204 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgGraph +public import Complexitylib.Classes.PCP.Internal.AlgPreprocess +public import Complexitylib.Classes.PCP.Internal.KilledCSP + +/-! +# The preprocessed constraint, in numbers + +Preprocessing leaves three kinds of constraint: the original one at an +edge-link, oriented by the half-edge's side; equality inside a cloud; and +nothing at all at a self-loop or an expander edge. So the constraint at a dart +is a fixed function of the dart's number, the half-edge's side, and the code of +the original constraint — a bounded amount of data. + +## Main definitions + +- `Complexity.preRelCode` — the constraint a dart's number and a code stand for + +## Main results + +- `Complexity.preRel_eq` — it is the preprocessed system's constraint +- `Complexity.rel_killedPow_preprocess` — the killed power's constraint runs + those codes along the walk +- `Complexity.rel_killedPow_eq_relOfSteps` — so it depends on the graph only + through the walk's parities and codes +- `Complexity.rel_killedPow_eq_preRelOfSteps` — the same, with every argument at + a type that does not mention the graph +-/ + +@[expose] public section + +namespace Complexity + +open NumEnc + +variable {α : Type} [Fintype α] [DecidableEq α] + +/-- The preprocessed system's constraint, from the dart's number `d`, the +half-edge's number `u` and the code `c` of the original constraint. -/ +noncomputable def preRelCode (α : Type) [Fintype α] [DecidableEq α] + (deg c u d : ℕ) (a b : α) : Bool := + if d = 0 then true + else if d = 1 then + (if u % 2 = 0 then relOfCode α c b a else relOfCode α c a b) + else if d < 2 + deg then decide (a = b) + else true + +/-- **The numbers give the preprocessed constraint.** -/ +theorem preRel_eq (G : ConstraintGraph α) (E : ExpanderFamily) (p : G.HalfEdge) + (d : (G.preprocess E).graph.D) (a b : α) : + (G.preprocess E).rel p d a b + = preRelCode α E.degree (codeOfRel (G.rel p.1)) (enc p) (enc d) a b := by + have hmod : enc p % 2 = (if p.2 then 0 else 1) := by + rw [ConstraintGraph.enc_halfEdge, ConstraintGraph.halfCode] + cases p.2 <;> simp + rcases G.preDart_cases E d with rfl | rfl | ⟨j, rfl⟩ | ⟨j, rfl⟩ + · rw [G.enc_preLoop E, preRelCode, if_pos rfl] + rfl + · rw [G.enc_preEdge E, preRelCode, if_neg one_ne_zero, if_pos rfl, relOfCode_codeOfRel, hmod] + show (if p.2 then G.rel p.1 b a else G.rel p.1 a b) = _ + cases hb : p.2 <;> simp + · have hj := j.isLt + rw [G.enc_preCloud E j, preRelCode, if_neg (by omega), if_neg (by omega), if_pos (by omega)] + rfl + · have hj := j.isLt + rw [G.enc_preExp E j, preRelCode, if_neg (by omega), if_neg (by omega), if_neg (by omega)] + rfl + +/-- Only the parity of a half-edge's number matters. -/ +theorem preRelCode_mod (deg c u d : ℕ) (a b : α) : + preRelCode α deg c (u % 2) d a b = preRelCode α deg c u d a b := by + rw [preRelCode, preRelCode, Nat.mod_mod_of_dvd u (dvd_refl 2)] + +/-- **The killed power's constraint, along the walk.** Each step contributes the +preprocessed constraint at the vertex it stands on, read off that vertex's +number and the code of the original constraint there. -/ +theorem rel_killedPow_preprocess (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (a b : KOpinion (G.preprocess E).graph T α) : + ((G.preprocess E).killedPow q T hq).rel v x a b + = decide (∀ i : Fin ((G.preprocess E).graph.kLen x), + preRelCode α E.degree + (codeOfRel (G.rel ((G.preprocess E).graph.walkAt + ((G.preprocess E).graph.kLen x) v ((G.preprocess E).graph.kWalk x) i.val).1)) + (enc ((G.preprocess E).graph.walkAt + ((G.preprocess E).graph.kLen x) v ((G.preprocess E).graph.kWalk x) i.val)) + (enc ((G.preprocess E).graph.kWalk x i)) + (a ((G.preprocess E).graph.startIdx ((G.preprocess E).graph.kLen_le x) + ((G.preprocess E).graph.kWalk x) i)) + (b ((G.preprocess E).graph.endIdx ((G.preprocess E).graph.kLen_le x) v + ((G.preprocess E).graph.kWalk x) i)) = true) := by + show decide (∀ i : Fin ((G.preprocess E).graph.kLen x), _ = true) = _ + simp only [preRel_eq] + rfl + +/-- What a killed dart's constraint runs: at each step, the dart it takes, the +parity of the vertex it stands on, the code of the constraint there, and where +the two ends hold their opinions about that step. -/ +noncomputable def relOfSteps {Gr : RegGraph} [NumEnc Gr.D] {T : ℕ} (deg n : ℕ) + (dart : Fin n → Gr.D) (par code : Fin n → ℕ) + (sIdx eIdx : Fin n → VarWalk Gr T) (a b : KOpinion Gr T α) : Bool := + decide (∀ i : Fin n, preRelCode α deg (code i) (par i) (NumEnc.enc (dart i)) + (a (sIdx i)) (b (eIdx i)) = true) + +/-- **The killed power's constraint depends on the graph only through the +walk's parities and codes** — a bounded amount of data. -/ +theorem rel_killedPow_eq_relOfSteps (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) : + ((G.preprocess E).killedPow q T hq).rel v x + = relOfSteps (Gr := (G.preprocess E).graph) E.degree + ((G.preprocess E).graph.kLen x) ((G.preprocess E).graph.kWalk x) + (fun i => enc ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) i.val) % 2) + (fun i => codeOfRel (G.rel ((G.preprocess E).graph.walkAt + ((G.preprocess E).graph.kLen x) v ((G.preprocess E).graph.kWalk x) i.val).1)) + ((G.preprocess E).graph.startIdx ((G.preprocess E).graph.kLen_le x) + ((G.preprocess E).graph.kWalk x)) + ((G.preprocess E).graph.endIdx ((G.preprocess E).graph.kLen_le x) v + ((G.preprocess E).graph.kWalk x)) := by + funext a b + rw [rel_killedPow_preprocess, relOfSteps] + simp only [preRelCode_mod] + +/-! ### Types that do not mention the graph -/ + +/-- The darts of a preprocessed system: the self-loop, the edge-link, the +cloud's and the expander's. This is the dart type of `preprocess` for *every* +graph, so data about a preprocessed walk lives at a type that does not grow with +the input. -/ +abbrev PreDart (E : ExpanderFamily) : Type := Unit ⊕ (Option (Fin E.degree) ⊕ Fin E.degree) + +omit [Fintype α] in +theorem D_preprocess (G : ConstraintGraph α) (E : ExpanderFamily) : + (G.preprocess E).graph.D = PreDart E := rfl + +/-- Walks of length at most `T` in a preprocessed system, likewise. -/ +abbrev PreWalk (E : ExpanderFamily) (T : ℕ) : Type := + Σ ℓ : Fin (T + 1), Fin ℓ.val → PreDart E + +omit [Fintype α] in +theorem varWalk_preprocess (G : ConstraintGraph α) (E : ExpanderFamily) (T : ℕ) : + VarWalk (G.preprocess E).graph T = PreWalk E T := rfl + +/-- The killed constraint, with every argument at a graph-free type. -/ +noncomputable def preRelOfSteps (E : ExpanderFamily) (T : ℕ) (deg n : ℕ) + (dart : Fin n → PreDart E) (par code : Fin n → ℕ) + (sIdx eIdx : Fin n → PreWalk E T) (a b : PreWalk E T → α) : Bool := + decide (∀ i : Fin n, preRelCode α deg (code i) (par i) (NumEnc.enc (dart i)) + (a (sIdx i)) (b (eIdx i)) = true) + +/-- **The killed power's constraint, as data at graph-free types.** Two graphs +whose walks show the same darts, parities, codes and opinion indices carry the +same constraint. -/ +theorem rel_killedPow_eq_preRelOfSteps (G : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) : + ((G.preprocess E).killedPow q T hq).rel v x + = preRelOfSteps E T E.degree ((G.preprocess E).graph.kLen x) + ((G.preprocess E).graph.kWalk x) + (fun i => enc ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) i.val) % 2) + (fun i => codeOfRel (G.rel ((G.preprocess E).graph.walkAt + ((G.preprocess E).graph.kLen x) v ((G.preprocess E).graph.kWalk x) i.val).1)) + ((G.preprocess E).graph.startIdx ((G.preprocess E).graph.kLen_le x) + ((G.preprocess E).graph.kWalk x)) + ((G.preprocess E).graph.endIdx ((G.preprocess E).graph.kLen_le x) v + ((G.preprocess E).graph.kWalk x)) := + rel_killedPow_eq_relOfSteps G E hq v x + +/-- **Two graphs whose walks show the same data carry the same constraint.** +The walk itself is shared: an algorithm reads it off the dart's number, which is +the same on both sides. -/ +theorem rel_eq_of_data (G G' : ConstraintGraph α) (E : ExpanderFamily) {q T : ℕ} + (hq : 0 < q) (v : (G.preprocess E).graph.V) (v' : (G'.preprocess E).graph.V) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + (hpar : (fun i : Fin ((G.preprocess E).graph.kLen x) => + enc ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) i.val) % 2) + = fun i : Fin ((G'.preprocess E).graph.kLen x) => + enc ((G'.preprocess E).graph.walkAt ((G'.preprocess E).graph.kLen x) v' + ((G'.preprocess E).graph.kWalk x) i.val) % 2) + (hcode : (fun i : Fin ((G.preprocess E).graph.kLen x) => + codeOfRel (G.rel ((G.preprocess E).graph.walkAt ((G.preprocess E).graph.kLen x) v + ((G.preprocess E).graph.kWalk x) i.val).1)) + = fun i : Fin ((G'.preprocess E).graph.kLen x) => + codeOfRel (G'.rel ((G'.preprocess E).graph.walkAt ((G'.preprocess E).graph.kLen x) v' + ((G'.preprocess E).graph.kWalk x) i.val).1)) + (hend : (G.preprocess E).graph.endIdx ((G.preprocess E).graph.kLen_le x) v + ((G.preprocess E).graph.kWalk x) + = (G'.preprocess E).graph.endIdx ((G'.preprocess E).graph.kLen_le x) v' + ((G'.preprocess E).graph.kWalk x)) : + ((G.preprocess E).killedPow q T hq).rel v x + = ((G'.preprocess E).killedPow q T hq).rel v' x := by + rw [rel_killedPow_eq_preRelOfSteps, rel_killedPow_eq_preRelOfSteps, hpar, hcode, hend] + rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean b/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean new file mode 100644 index 00000000..53fe1037 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean @@ -0,0 +1,797 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgGraph +public import Complexitylib.Classes.PCP.Internal.AlgPreprocess +public import Complexitylib.Classes.PCP.Internal.Materialize +public import Complexitylib.Classes.PCP.Internal.AlgFamily + +/-! +# Reading a half-edge's endpoint + +A half-edge is numbered `2 e` or `2 e + 1` according to which end of edge `e` it +is, so the vertex it hangs from is one of that edge's two endpoints — and both +are written down in the encoded graph. Halving the number picks the edge, its +parity picks the end. + +## Main definitions + +- `Complexity.ownerFn` — the vertex a half-edge number hangs from +- `Complexity.cloudSizeFn` — how many half-edges hang from a vertex +- `Complexity.cloudIdxFn` — how many of them come first + +## Main results + +- `Complexity.ownerFn_mem_FP`, `Complexity.ownerFn_eq` +- `Complexity.cloudSizeFn_mem_FP`, `Complexity.length_cloudSizeFn` — the count + is the number of half-edges the rule accepts +- `Complexity.ConstraintGraph.count_owner_eq_card_cloud` — and counting numbers + is counting half-edges +- `Complexity.cloudStepFn`, `Complexity.expStepFn` — the two moves that need the + expander +- `Complexity.preRotFn` — the preprocessed graph's rotation map, as one function + +## Main results + +- `Complexity.expStepFn_eq` — the expander move computes what it should +-/ + +@[expose] public section + +namespace Complexity + +/-- The vertex a half-edge hangs from, on `pair (encoded graph) (unary p)`. -/ +noncomputable def ownerFn (z : List Bool) : List Bool := + ifEqLen (modC 2 (Cobham.sndBlock z)) [] + (recSnd (Cobham.sndBlock (Cobham.fstBlock z)) (divC 2 (Cobham.sndBlock z)).length) + (recFst (Cobham.sndBlock (Cobham.fstBlock z)) (divC 2 (Cobham.sndBlock z)).length) + +theorem ownerFn_mem_FP : ownerFn ∈ FP := by + have hp : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hG : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) fun _ => rfl + have he := divC_mem_FP hp 2 + have hb := modC_mem_FP hp 2 + exact ifEqLen_mem_FP hb (constFn_mem_FP []) (recSnd_mem_FP he hG) (recFst_mem_FP he hG) + +/-! ### Counting a cloud -/ + +/-- One mark when the half-edge `j` hangs from the vertex asked for. The +argument is `pair (pair (encoded graph) (unary u)) (unary j)`. -/ +noncomputable def cloudMark (w : List Bool) : List Bool := + ifEqLen (ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) + (Cobham.sndBlock (Cobham.fstBlock w)) [true] [] + +set_option maxHeartbeats 1000000 in +theorem cloudMark_mem_FP : cloudMark ∈ FP := by + have hG : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hu : (fun w : List Bool => Cobham.sndBlock (Cobham.fstBlock w)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hj : (fun w : List Bool => Cobham.sndBlock w) ∈ FP := Cobham.sndBlock_mem_FP + have hown : (fun w : List Bool => + ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hj) ownerFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply] + exact ifEqLen_mem_FP hown hu (constFn_mem_FP [true]) (constFn_mem_FP []) + +theorem length_cloudMark (Gz u j : List Bool) : + (cloudMark (pair (pair Gz u) j)).length + = if (ownerFn (pair Gz j)).length = u.length then 1 else 0 := by + rw [cloudMark, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair] + by_cases h : (ownerFn (pair Gz j)).length = u.length + · rw [ifEqLen_pos h, if_pos h] + rfl + · rw [ifEqLen_neg h, if_neg h] + rfl + +/-- How many half-edges hang from the vertex asked for, on +`pair (encoded graph) (unary u)`. -/ +noncomputable def cloudSizeFn (z : List Bool) : List Bool := + countOver cloudMark + (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) z) + +set_option maxHeartbeats 1000000 in +theorem cloudSizeFn_mem_FP : cloudSizeFn ∈ FP := by + have hcnt : (fun z : List Bool => + marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) ∈ FP := by + have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact marks_mem_FP (mulC_mem_FP (posCount_mem_FP h1) 2) + have harg := Cobham.pairFn_mem_FP hcnt id_mem_FP + have h := mem_FP_comp harg (countOver_mem_FP cloudMark_mem_FP) + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply, cloudSizeFn] + rfl + +/-- **The count is the number of half-edges the rule accepts.** -/ +theorem length_cloudSizeFn (Gz u : List Bool) (m : ℕ) + (hm : (mulC 2 (posCount (Cobham.sndBlock Gz))).length = m) : + (cloudSizeFn (pair Gz u)).length + = ∑ j ∈ Finset.range m, + (if (ownerFn (pair Gz (List.replicate j true))).length = u.length then 1 else 0) := by + have hmarks : marks (mulC 2 (posCount (Cobham.sndBlock Gz))) = List.replicate m true := by + rw [marks_eq, hm] + rw [cloudSizeFn, Cobham.fstBlock_pair, hmarks, length_countOver] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [length_cloudMark] + +/-- How many half-edges before this one hang from the same vertex, on +`pair (encoded graph) (unary p)`. -/ +noncomputable def cloudIdxFn (z : List Bool) : List Bool := + countOver cloudMark + (pair (marks (Cobham.sndBlock z)) (pair (Cobham.fstBlock z) (ownerFn z))) + +set_option maxHeartbeats 1000000 in +theorem cloudIdxFn_mem_FP : cloudIdxFn ∈ FP := by + have hcnt := marks_mem_FP Cobham.sndBlock_mem_FP + have hdata := Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP ownerFn_mem_FP + have h := mem_FP_comp (Cobham.pairFn_mem_FP hcnt hdata) + (countOver_mem_FP cloudMark_mem_FP) + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply, cloudIdxFn] + +/-- **The index is the number of earlier half-edges in the same cloud.** -/ +theorem length_cloudIdxFn (Gz : List Bool) (p : ℕ) : + (cloudIdxFn (pair Gz (List.replicate p true))).length + = ∑ j ∈ Finset.range p, + (if (ownerFn (pair Gz (List.replicate j true))).length + = (ownerFn (pair Gz (List.replicate p true))).length then 1 else 0) := by + have hmarks : marks (Cobham.sndBlock (pair Gz (List.replicate p true))) + = List.replicate p true := by + rw [Cobham.sndBlock_pair, marks_eq, List.length_replicate] + rw [cloudIdxFn, hmarks, Cobham.fstBlock_pair, length_countOver] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [length_cloudMark] + +/-! ### Finding a cloud's members -/ + + + +/-- One mark when the half-edge `c` is the `k`-th of the cloud of `u`. The +argument is `pair (pair (encoded graph) (pair (unary u) (unary k))) (unary c)`. -/ +noncomputable def eltMark (w : List Bool) : List Bool := + ifEqLen (ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) + (Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock w))) + (ifEqLen (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) + (Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock w))) [true] []) + [] + +set_option maxHeartbeats 1000000 in +theorem eltMark_mem_FP : eltMark ∈ FP := by + have hG : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hc : (fun w : List Bool => Cobham.sndBlock w) ∈ FP := Cobham.sndBlock_mem_FP + have hu : (fun w : List Bool => + Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock w))) ∈ FP := + mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) + Cobham.fstBlock_mem_FP + have hk : (fun w : List Bool => + Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock w))) ∈ FP := + mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) + Cobham.sndBlock_mem_FP + have harg := Cobham.pairFn_mem_FP hG hc + have hown : (fun w : List Bool => + ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) ∈ FP := by + have h := mem_FP_comp harg ownerFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply] + have hidx : (fun w : List Bool => + cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) ∈ FP := by + have h := mem_FP_comp harg cloudIdxFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply] + exact ifEqLen_mem_FP hown hu + (ifEqLen_mem_FP hidx hk (constFn_mem_FP [true]) (constFn_mem_FP [])) + (constFn_mem_FP []) + +theorem length_eltMark (Gz u k c : List Bool) : + (eltMark (pair (pair Gz (pair u k)) c)).length + = if (ownerFn (pair Gz c)).length = u.length then + (if (cloudIdxFn (pair Gz c)).length = k.length then 1 else 0) + else 0 := by + rw [eltMark, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + by_cases h1 : (ownerFn (pair Gz c)).length = u.length + · rw [ifEqLen_pos h1, if_pos h1] + by_cases h2 : (cloudIdxFn (pair Gz c)).length = k.length + · rw [ifEqLen_pos h2, if_pos h2] + rfl + · rw [ifEqLen_neg h2, if_neg h2] + rfl + · rw [ifEqLen_neg h1, if_neg h1] + rfl + +/-- The `k`-th half-edge of the cloud of `u`, on +`pair (encoded graph) (pair (unary u) (unary k))`. -/ +noncomputable def cloudEltFn (z : List Bool) : List Bool := + findFirst eltMark + (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) z) + +theorem cloudEltFn_eq_replicate (z : List Bool) : + cloudEltFn z = List.replicate (cloudEltFn z).length true := by + conv_lhs => rw [cloudEltFn, findFirst_eq_replicate] + rw [← cloudEltFn] + +set_option maxHeartbeats 1000000 in +theorem cloudEltFn_mem_FP : cloudEltFn ∈ FP := by + have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hcnt := marks_mem_FP (mulC_mem_FP (posCount_mem_FP h1) 2) + have h := mem_FP_comp (Cobham.pairFn_mem_FP hcnt id_mem_FP) + (findFirst_mem_FP eltMark_mem_FP) + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply, cloudEltFn] + rfl + +variable {α : Type} [Fintype α] [DecidableEq α] + +/-- **The reading is the owner.** -/ +theorem ownerFn_eq (G : ConstraintGraph α) (p : ℕ) (hp : p / 2 < G.numEdges) : + ownerFn (pair (encGraph G) (List.replicate p true)) + = List.replicate (G.ownerNum p) true := by + have hdiv : (divC 2 (List.replicate p true)) = List.replicate (p / 2) true := by + rw [divC_eq (by norm_num), List.length_replicate] + have hmod : (modC 2 (List.replicate p true)) = List.replicate (p % 2) true := by + rw [modC_eq (by norm_num), List.length_replicate] + rw [ownerFn, Cobham.sndBlock_pair, Cobham.fstBlock_pair, hdiv, hmod, + List.length_replicate, ConstraintGraph.ownerNum, dif_pos hp] + by_cases h : p % 2 = 0 + · rw [if_pos h, ifEqLen_pos (by rw [h]; rfl)] + rw [encGraph, Cobham.sndBlock_pair, + recSnd_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact hp) + (getElem_edgeRecs G _ hp)] + · rw [if_neg h, ifEqLen_neg (by + rw [List.length_replicate, List.length_nil] + exact h)] + rw [encGraph, Cobham.sndBlock_pair, + recFst_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact hp) + (getElem_edgeRecs G _ hp)] + +namespace ConstraintGraph + +omit [Fintype α] [DecidableEq α] in +/-- **Counting numbers is counting half-edges.** -/ +theorem count_owner_eq_card_cloud (G : ConstraintGraph α) (v : Fin G.numVerts) : + ((Finset.range (2 * G.numEdges)).filter fun j => G.ownerNum j = v.val).card + = (G.cloud v).card := by + classical + refine (Finset.card_bij (fun p _ => NumEnc.enc p) ?_ ?_ ?_).symm + · intro p hp + have howner : G.owner p = v := (G.mem_cloud).mp hp + refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr ?_, ?_⟩ + · show NumEnc.enc p < 2 * G.numEdges + rw [enc_halfEdge, halfCode] + have he := p.1.isLt + cases p.2 + · simp + omega + · simp + · show G.ownerNum (NumEnc.enc p) = v.val + rw [G.ownerNum_enc p, howner] + · intro p _ q _ h + exact NumEnc.enc_injective h + · intro j hj + rw [Finset.mem_filter, Finset.mem_range] at hj + have he : j / 2 < G.numEdges := by omega + refine ⟨(⟨j / 2, he⟩, decide (j % 2 = 0)), ?_, ?_⟩ + · have hcode : NumEnc.enc ((⟨j / 2, he⟩, decide (j % 2 = 0)) : G.HalfEdge) = j := by + rw [enc_halfEdge, halfCode] + by_cases h2 : j % 2 = 0 <;> simp [h2] <;> omega + have hown := G.ownerNum_enc ((⟨j / 2, he⟩, decide (j % 2 = 0)) : G.HalfEdge) + rw [hcode] at hown + exact (G.mem_cloud).mpr (Fin.ext (hown.symm.trans hj.2)) + · show NumEnc.enc ((⟨j / 2, he⟩, decide (j % 2 = 0)) : G.HalfEdge) = j + rw [enc_halfEdge, halfCode] + by_cases h2 : j % 2 = 0 <;> simp [h2] <;> omega + +omit [Fintype α] [DecidableEq α] in +/-- **Counting numbers below a bound is counting codes below it.** -/ +theorem count_owner_lt_eq_countBelow (G : ConstraintGraph α) (v : Fin G.numVerts) (m : ℕ) + (hm : m ≤ 2 * G.numEdges) : + ((Finset.range m).filter fun j => G.ownerNum j = v.val).card + = countBelow (G.cloudCodes v) m := by + classical + rw [G.countBelow_cloudCodes v m] + refine (Finset.card_bij (fun p _ => NumEnc.enc p) ?_ ?_ ?_).symm + · intro p hp + rw [Finset.mem_filter] at hp + have howner : G.owner p = v := (G.mem_cloud).mp hp.1 + refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr ?_, ?_⟩ + · show NumEnc.enc p < m + rw [enc_halfEdge] + exact hp.2 + · show G.ownerNum (NumEnc.enc p) = v.val + rw [G.ownerNum_enc p, howner] + · intro p _ q _ h + exact NumEnc.enc_injective h + · intro j hj + rw [Finset.mem_filter, Finset.mem_range] at hj + have he : j / 2 < G.numEdges := by omega + refine ⟨(⟨j / 2, he⟩, decide (j % 2 = 0)), ?_, ?_⟩ + · have hcode : NumEnc.enc ((⟨j / 2, he⟩, decide (j % 2 = 0)) : G.HalfEdge) = j := by + rw [enc_halfEdge, halfCode] + by_cases h2 : j % 2 = 0 <;> simp [h2] <;> omega + have hown := G.ownerNum_enc ((⟨j / 2, he⟩, decide (j % 2 = 0)) : G.HalfEdge) + rw [hcode] at hown + refine Finset.mem_filter.mpr ⟨(G.mem_cloud).mpr (Fin.ext (hown.symm.trans hj.2)), ?_⟩ + rw [← enc_halfEdge, hcode] + exact hj.1 + · show NumEnc.enc ((⟨j / 2, he⟩, decide (j % 2 = 0)) : G.HalfEdge) = j + rw [enc_halfEdge, halfCode] + by_cases h2 : j % 2 = 0 <;> simp [h2] <;> omega + +end ConstraintGraph + +/-! ### What the counts compute -/ + +variable (G : ConstraintGraph α) + +theorem length_count_encGraph : + (mulC 2 (posCount (Cobham.sndBlock (encGraph G)))).length = 2 * G.numEdges := by + rw [encGraph, Cobham.sndBlock_pair, posCount_eq, length_mulC, List.length_replicate, + length_edgeRecs] + ring + +/-- **The size the algorithm counts is the size of the cloud.** -/ +theorem length_cloudSizeFn_eq (v : Fin G.numVerts) : + (cloudSizeFn (pair (encGraph G) (List.replicate v.val true))).length + = (G.cloud v).card := by + classical + rw [length_cloudSizeFn _ _ _ (length_count_encGraph G)] + rw [← ConstraintGraph.count_owner_eq_card_cloud G v, Finset.card_filter] + refine Finset.sum_congr rfl fun j hj => ?_ + rw [Finset.mem_range] at hj + have hje : j / 2 < G.numEdges := by omega + rw [ownerFn_eq G j hje, List.length_replicate, List.length_replicate] + +/-- **The index the algorithm counts is the position in the cloud.** -/ +theorem length_cloudIdxFn_eq (m : ℕ) (hm : m < 2 * G.numEdges) : + (cloudIdxFn (pair (encGraph G) (List.replicate m true))).length + = countBelow (G.cloudCodes ⟨G.ownerNum m, by + have hme : m / 2 < G.numEdges := by omega + rw [ConstraintGraph.ownerNum, dif_pos hme] + split <;> exact Fin.isLt _⟩) m := by + classical + have hme : m / 2 < G.numEdges := by omega + rw [length_cloudIdxFn, ← ConstraintGraph.count_owner_lt_eq_countBelow G _ m (by omega), + Finset.card_filter] + refine Finset.sum_congr rfl fun j hj => ?_ + rw [Finset.mem_range] at hj + have hje : j / 2 < G.numEdges := by omega + rw [ownerFn_eq G j hje, ownerFn_eq G m hme, List.length_replicate, List.length_replicate] + +omit [Fintype α] [DecidableEq α] in +/-- The code of a half-edge is below twice the edge count. -/ +theorem halfCode_lt (p : G.HalfEdge) : G.halfCode p < 2 * G.numEdges := by + have hp := p.1.isLt + rw [ConstraintGraph.halfCode] + by_cases hb : p.2 = true + · rw [if_pos hb] + omega + · rw [if_neg hb] + omega + +/-- **The search finds the `k`-th half-edge of the cloud.** -/ +theorem length_cloudEltFn_eq (v : Fin G.numVerts) (k : ℕ) + (hk : k < (G.cloudList v).length) : + (cloudEltFn (pair (encGraph G) (pair (List.replicate v.val true) + (List.replicate k true)))).length + = G.halfCode ((G.cloudList v)[k]) := by + classical + set q : G.HalfEdge := (G.cloudList v)[k] with hq + have hmem : q ∈ G.cloudList v := List.getElem_mem hk + have howner : G.owner q = v := (G.mem_cloud).mp ((G.mem_cloudList).mp hmem) + have hidx : (G.cloudList v).idxOf q = k := (G.nodup_cloudList v).idxOf_getElem _ hk + have hcount : countBelow (G.cloudCodes v) (G.halfCode q) = k := by + rw [← G.idxOf_cloudList howner, hidx] + have hclt : G.halfCode q < 2 * G.numEdges := halfCode_lt G q + have hmarks : marks (mulC 2 (posCount (Cobham.sndBlock (encGraph G)))) + = List.replicate (2 * G.numEdges) true := by + rw [marks_eq, length_count_encGraph] + rw [cloudEltFn, Cobham.fstBlock_pair, hmarks] + refine length_findFirst_eq hclt ?_ ?_ + · have howner' : G.ownerNum (G.halfCode q) = v.val := by + rw [← ConstraintGraph.enc_halfEdge, ConstraintGraph.ownerNum_enc, howner] + have hown1 : (ownerFn (pair (encGraph G) (List.replicate (G.halfCode q) true))).length + = (List.replicate v.val true).length := by + rw [ownerFn_eq G _ (by omega), List.length_replicate, List.length_replicate, howner'] + have hidx1 : (cloudIdxFn (pair (encGraph G) (List.replicate (G.halfCode q) true))).length + = (List.replicate k true).length := by + rw [length_cloudIdxFn_eq G _ hclt, List.length_replicate] + have hv : (⟨G.ownerNum (G.halfCode q), by + have hme : G.halfCode q / 2 < G.numEdges := by omega + rw [ConstraintGraph.ownerNum, dif_pos hme] + split <;> exact Fin.isLt _⟩ : Fin G.numVerts) = v := Fin.ext howner' + rw [hv, hcount] + rw [length_eltMark, if_pos hown1, if_pos hidx1] + omega + · intro j hj + rw [length_eltMark] + by_cases h1 : (ownerFn (pair (encGraph G) (List.replicate j true))).length + = (List.replicate v.val true).length + · rw [if_pos h1, if_neg ?_] + have hjlt : j < 2 * G.numEdges := by omega + have hjown : G.ownerNum j = v.val := by + rw [ownerFn_eq G j (by omega), List.length_replicate, List.length_replicate] at h1 + exact h1 + have hjmem : j ∈ G.cloudCodes v := by + refine (G.mem_cloudCodes).mpr ⟨(⟨j / 2, by omega⟩, decide (j % 2 = 0)), ?_, ?_⟩ + · have hcode : NumEnc.enc ((⟨j / 2, by omega⟩, decide (j % 2 = 0)) : G.HalfEdge) = j := by + rw [ConstraintGraph.enc_halfEdge, ConstraintGraph.halfCode] + by_cases h2 : j % 2 = 0 <;> simp [h2] <;> omega + have hown := G.ownerNum_enc ((⟨j / 2, by omega⟩, decide (j % 2 = 0)) : G.HalfEdge) + rw [hcode] at hown + exact Fin.ext (hown.symm.trans hjown) + · rw [ConstraintGraph.halfCode] + by_cases h2 : j % 2 = 0 <;> simp [h2] <;> omega + have hlt := countBelow_lt_countBelow hjmem hj + rw [hcount] at hlt + rw [length_cloudIdxFn_eq G _ hjlt, List.length_replicate] + have hjv : (⟨G.ownerNum j, by + have hme : j / 2 < G.numEdges := by omega + rw [ConstraintGraph.ownerNum, dif_pos hme] + split <;> exact Fin.isLt _⟩ : Fin G.numVerts) = v := Fin.ext hjown + rw [hjv] + omega + · rw [if_neg h1] + +/-! ### The two moves that need the expander -/ + +variable (F : FinBase) (pol : Polynomial ℕ) + +/-- The cloud move, on `pair (pair (graph) (unary owner)) (pair (unary code) +(unary dart))`: rotate the half-edge's index inside its cloud, then read off the +half-edge the new index names. -/ +noncomputable def cloudStepFn (z : List Bool) : List Bool := + pair + (cloudEltFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (pair (Cobham.sndBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (F.famRotFn pol + (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)))) + (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (Cobham.sndBlock z)))) + (Cobham.sndBlock (Cobham.sndBlock z))))))))) + (Cobham.sndBlock (F.famRotFn pol + (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)))) + (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (Cobham.sndBlock z)))) + (Cobham.sndBlock (Cobham.sndBlock z)))))) + +set_option maxHeartbeats 1000000 in +theorem cloudStepFn_mem_FP : cloudStepFn F pol ∈ FP := by + have hG : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hu : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hc : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP + have hj : (fun z : List Bool => Cobham.sndBlock (Cobham.sndBlock z)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP + have hsize : (fun z : List Bool => cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hu) cloudSizeFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply] + have hidx : (fun z : List Bool => cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (Cobham.sndBlock z)))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hc) cloudIdxFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply] + have hy : (fun z : List Bool => F.famRotFn pol + (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)))) + (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (Cobham.sndBlock z)))) + (Cobham.sndBlock (Cobham.sndBlock z))))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hsize (Cobham.pairFn_mem_FP hidx hj)) + (F.famRotFn_mem_FP pol) + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply] + have helt : (fun z : List Bool => cloudEltFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (pair (Cobham.sndBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (F.famRotFn pol + (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.sndBlock (Cobham.fstBlock z)))) + (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) + (Cobham.fstBlock (Cobham.sndBlock z)))) + (Cobham.sndBlock (Cobham.sndBlock z))))))))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hG + (Cobham.pairFn_mem_FP hu (mem_FP_comp hy Cobham.fstBlock_mem_FP))) cloudEltFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + simp only [Function.comp_apply] + have hout := Cobham.pairFn_mem_FP helt (mem_FP_comp hy Cobham.sndBlock_mem_FP) + refine mem_FP_of_eq hout fun w => ?_ + simp only [Function.comp_apply] + rw [cloudStepFn] + +/-- The expander move, on `pair (graph) (pair (unary vertex) (unary dart))`. -/ +noncomputable def expStepFn (z : List Bool) : List Bool := + F.famRotFn pol + (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) + (Cobham.sndBlock z)) + +set_option maxHeartbeats 1000000 in +theorem expStepFn_mem_FP : expStepFn F pol ∈ FP := by + have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hcnt := marks_mem_FP (mulC_mem_FP (posCount_mem_FP h1) 2) + have h := mem_FP_comp (Cobham.pairFn_mem_FP hcnt Cobham.sndBlock_mem_FP) + (F.famRotFn_mem_FP pol) + refine mem_FP_of_eq h fun w => ?_ + rw [Function.comp_apply, expStepFn] + +/-- **The cloud move computes what it should.** -/ +theorem cloudStepFn_eq (hd : 1 < F.deg) (v : Fin G.numVerts) (c j : ℕ) + (hc : c < 2 * G.numEdges) (hown : G.ownerNum c = v.val) + (hj : j < (F.toFamily hd).degree) + (hp : F.fitLevel hd (G.cloudList v).length ≤ pol.eval (G.cloudList v).length) : + cloudStepFn F pol (pair (pair (encGraph G) (List.replicate v.val true)) + (pair (List.replicate c true) (List.replicate j true))) + = pair (List.replicate (G.cloudStepNum (F.toFamily hd) v c ⟨j, hj⟩).1 true) + (List.replicate (G.cloudStepNum (F.toFamily hd) v c ⟨j, hj⟩).2 true) := by + classical + have hce : c / 2 < G.numEdges := by omega + have hcmem : c ∈ G.cloudCodes v := by + refine (G.mem_cloudCodes).mpr ⟨(⟨c / 2, hce⟩, decide (c % 2 = 0)), ?_, ?_⟩ + · have hcode : NumEnc.enc ((⟨c / 2, hce⟩, decide (c % 2 = 0)) : G.HalfEdge) = c := by + rw [ConstraintGraph.enc_halfEdge, ConstraintGraph.halfCode] + by_cases h2 : c % 2 = 0 <;> simp [h2] <;> omega + have hown' := G.ownerNum_enc ((⟨c / 2, hce⟩, decide (c % 2 = 0)) : G.HalfEdge) + rw [hcode] at hown' + exact Fin.ext (hown'.symm.trans hown) + · rw [ConstraintGraph.halfCode] + by_cases h2 : c % 2 = 0 <;> simp [h2] <;> omega + have hidxlt : countBelow (G.cloudCodes v) c < (G.cloudList v).length := by + rw [← G.card_cloudCodes_eq_length v] + exact countBelow_lt_card hcmem + have hpos : 0 < (G.cloudList v).length := by omega + have hsizelen : (cloudSizeFn (pair (encGraph G) (List.replicate v.val true))).length + = (G.cloudList v).length := by + rw [length_cloudSizeFn_eq, ConstraintGraph.length_cloudList] + have hsize : cloudSizeFn (pair (encGraph G) (List.replicate v.val true)) + = List.replicate (G.cloudList v).length true := by + conv_lhs => rw [cloudSizeFn, countOver_eq_replicate] + rw [← cloudSizeFn, hsizelen] + have hvfin : (⟨G.ownerNum c, by + rw [ConstraintGraph.ownerNum, dif_pos hce] + split <;> exact Fin.isLt _⟩ : Fin G.numVerts) = v := Fin.ext hown + have hidxlen : (cloudIdxFn (pair (encGraph G) (List.replicate c true))).length + = countBelow (G.cloudCodes v) c := by + rw [length_cloudIdxFn_eq G _ hc, hvfin] + have hidx : cloudIdxFn (pair (encGraph G) (List.replicate c true)) + = List.replicate (countBelow (G.cloudCodes v) c) true := by + conv_lhs => rw [cloudIdxFn, countOver_eq_replicate] + rw [← cloudIdxFn, hidxlen] + have hval : F.famRotVal hd (G.cloudList v).length (countBelow (G.cloudCodes v) c, j) + = (((F.toFamily hd).rot (G.cloudList v).length + ((⟨countBelow (G.cloudCodes v) c, hidxlt⟩ : Fin (G.cloudList v).length), + (⟨j, hj⟩ : Fin (F.toFamily hd).degree))).1.val, + ((F.toFamily hd).rot (G.cloudList v).length + ((⟨countBelow (G.cloudCodes v) c, hidxlt⟩ : Fin (G.cloudList v).length), + (⟨j, hj⟩ : Fin (F.toFamily hd).degree))).2.val) := + F.famRotVal_eq hd hpos (⟨_, hidxlt⟩ : Fin (G.cloudList v).length) ⟨j, hj⟩ + have hrot := F.famRotFn_eq pol hd (G.cloudList v).length + (countBelow (G.cloudCodes v) c) j hpos hp + rw [hval] at hrot + have helt : cloudEltFn (pair (encGraph G) (pair (List.replicate v.val true) + (List.replicate ((F.toFamily hd).rot (G.cloudList v).length + ((⟨countBelow (G.cloudCodes v) c, hidxlt⟩ : Fin (G.cloudList v).length), + (⟨j, hj⟩ : Fin (F.toFamily hd).degree))).1.val true))) + = List.replicate (G.halfCode ((G.cloudList v)[((F.toFamily hd).rot + (G.cloudList v).length + ((⟨countBelow (G.cloudCodes v) c, hidxlt⟩ : Fin (G.cloudList v).length), + (⟨j, hj⟩ : Fin (F.toFamily hd).degree))).1.val])) true := by + conv_lhs => rw [cloudEltFn_eq_replicate] + rw [length_cloudEltFn_eq G v _ (Fin.isLt _)] + rw [cloudStepFn] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [hsize, hidx, hrot] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [helt, ConstraintGraph.cloudStepNum, dif_pos hidxlt] + dsimp only + rw [← G.halfCode_getElem_cloudList v _ (Fin.isLt _)] + +/-- **The expander move computes what it should.** -/ +theorem expStepFn_eq (hd : 1 < F.deg) (v j : ℕ) (hn : 0 < 2 * G.numEdges) + (hp : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + expStepFn F pol (pair (encGraph G) + (pair (List.replicate v true) (List.replicate j true))) + = pair (List.replicate (F.famRotVal hd (2 * G.numEdges) (v, j)).1 true) + (List.replicate (F.famRotVal hd (2 * G.numEdges) (v, j)).2 true) := by + have hmarks : marks (mulC 2 (posCount (Cobham.sndBlock (encGraph G)))) + = List.replicate (2 * G.numEdges) true := by + rw [marks_eq, length_count_encGraph] + rw [expStepFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hmarks] + exact F.famRotFn_eq pol hd _ v j hn hp + +/-! ### The whole rotation map -/ + +/-- Crossing an edge: flip the last bit of the vertex number. -/ +noncomputable def flipFn (v : List Bool) : List Bool := + ifEqLen (modC 2 v) [] (v ++ [true]) (dropOne v) + +theorem flipFn_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : + (fun z => flipFn (f z)) ∈ FP := + ifEqLen_mem_FP (modC_mem_FP hf 2) (constFn_mem_FP []) + (Cobham.appendFn_mem_FP hf (constFn_mem_FP [true])) (dropOneFn_mem_FP hf) + +theorem flipFn_eq (v : ℕ) : + flipFn (List.replicate v true) + = List.replicate (if v % 2 = 0 then v + 1 else v - 1) true := by + by_cases h : v % 2 = 0 + · rw [flipFn, modC_eq (by norm_num), List.length_replicate, h, + ifEqLen_pos (by simp)] + simp [List.replicate_succ'] + · rw [flipFn, modC_eq (by norm_num), List.length_replicate, + ifEqLen_neg (by simp [h]), if_neg h, dropOne] + simp + +/-- **The preprocessed graph's rotation map**, on +`pair (graph) (pair (unary vertex) (unary dart))`. Dart `0` is the self-loop, +dart `1` crosses the edge, the next `deg` are the cloud's, and the rest are the +superposed expander's. -/ +noncomputable def preRotFn (deg : ℕ) (z : List Bool) : List Bool := + ifEqLen (Cobham.sndBlock (Cobham.sndBlock z)) [] + (pair (Cobham.fstBlock (Cobham.sndBlock z)) []) + (ifEqLen (Cobham.sndBlock (Cobham.sndBlock z)) [true] + (pair (flipFn (Cobham.fstBlock (Cobham.sndBlock z))) [true]) + (ifLtLen (Cobham.sndBlock (Cobham.sndBlock z)) (List.replicate (2 + deg) true) + (pair + (Cobham.fstBlock (cloudStepFn F pol + (pair (pair (Cobham.fstBlock z) + (ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z))))) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop 2))))) + (Cobham.sndBlock (cloudStepFn F pol + (pair (pair (Cobham.fstBlock z) + (ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z))))) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop 2)))) ++ [true, true])) + (pair + (Cobham.fstBlock (expStepFn F pol + (pair (Cobham.fstBlock z) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg)))))) + (Cobham.sndBlock (expStepFn F pol + (pair (Cobham.fstBlock z) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg))))) + ++ List.replicate (2 + deg) true)))) + +set_option maxHeartbeats 1000000 in +theorem preRotFn_mem_FP (deg : ℕ) : preRotFn F pol deg ∈ FP := by + have hG : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hv : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP + have hd : (fun z : List Bool => Cobham.sndBlock (Cobham.sndBlock z)) ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP + have hd2 : (fun z : List Bool => (Cobham.sndBlock (Cobham.sndBlock z)).drop 2) ∈ FP := by + have := dropLenFn_mem_FP (constFn_mem_FP (List.replicate 2 true)) hd + refine mem_FP_of_eq this fun w => ?_ + rw [List.length_replicate] + have hdk : (fun z : List Bool => + (Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg)) ∈ FP := by + have := dropLenFn_mem_FP (constFn_mem_FP (List.replicate (2 + deg) true)) hd + refine mem_FP_of_eq this fun w => ?_ + rw [List.length_replicate] + have hown : (fun z : List Bool => + ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z)))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hv) ownerFn_mem_FP + refine mem_FP_of_eq h fun w => ?_ + simp only [Function.comp_apply] + have hcs : (fun z : List Bool => cloudStepFn F pol + (pair (pair (Cobham.fstBlock z) + (ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z))))) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop 2)))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hG hown) + (Cobham.pairFn_mem_FP hv hd2)) (cloudStepFn_mem_FP F pol) + refine mem_FP_of_eq h fun w => ?_ + simp only [Function.comp_apply] + have hes : (fun z : List Bool => expStepFn F pol + (pair (Cobham.fstBlock z) + (pair (Cobham.fstBlock (Cobham.sndBlock z)) + ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg))))) ∈ FP := by + have h := mem_FP_comp (Cobham.pairFn_mem_FP hG (Cobham.pairFn_mem_FP hv hdk)) + (expStepFn_mem_FP F pol) + refine mem_FP_of_eq h fun w => ?_ + simp only [Function.comp_apply] + have hloop := Cobham.pairFn_mem_FP hv (constFn_mem_FP []) + have hflip := Cobham.pairFn_mem_FP (flipFn_mem_FP hv) (constFn_mem_FP [true]) + have hcloud := Cobham.pairFn_mem_FP (mem_FP_comp hcs Cobham.fstBlock_mem_FP) + (Cobham.appendFn_mem_FP (mem_FP_comp hcs Cobham.sndBlock_mem_FP) + (constFn_mem_FP [true, true])) + have hexp := Cobham.pairFn_mem_FP (mem_FP_comp hes Cobham.fstBlock_mem_FP) + (Cobham.appendFn_mem_FP (mem_FP_comp hes Cobham.sndBlock_mem_FP) + (constFn_mem_FP (List.replicate (2 + deg) true))) + have hinner := ifLtLen_mem_FP hd (constFn_mem_FP (List.replicate (2 + deg) true)) + hcloud hexp + have houter := ifEqLen_mem_FP hd (constFn_mem_FP []) hloop + (ifEqLen_mem_FP hd (constFn_mem_FP [true]) hflip hinner) + refine mem_FP_of_eq houter fun w => ?_ + simp only [Function.comp_apply] + rw [preRotFn] + +set_option maxHeartbeats 1000000 in +/-- **The whole rotation map computes what it should.** -/ +theorem preRotFn_eq (hd : 1 < F.deg) (v d : ℕ) (hv : v < 2 * G.numEdges) + (hdlt : d < 2 + 2 * (F.toFamily hd).degree) + (hpc : ∀ u : Fin G.numVerts, + F.fitLevel hd (G.cloudList u).length ≤ pol.eval (G.cloudList u).length) + (hpe : F.fitLevel hd (2 * G.numEdges) ≤ pol.eval (2 * G.numEdges)) : + preRotFn F pol (F.toFamily hd).degree + (pair (encGraph G) (pair (List.replicate v true) (List.replicate d true))) + = pair (List.replicate (G.preRotNum (F.toFamily hd) v d).1 true) + (List.replicate (G.preRotNum (F.toFamily hd) v d).2 true) := by + have hne : 0 < 2 * G.numEdges := Nat.lt_of_le_of_lt (Nat.zero_le _) hv + have hvd : v / 2 < G.numEdges := by omega + have hulr : G.ownerNum v < G.numVerts := by + rw [ConstraintGraph.ownerNum, dif_pos hvd] + split <;> exact Fin.isLt _ + rw [preRotFn] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [ConstraintGraph.preRotNum] + by_cases h0 : d = 0 + · subst h0 + rw [ifEqLen_pos (by simp), if_pos rfl] + rfl + rw [ifEqLen_neg (by simpa using h0), if_neg h0] + by_cases h1 : d = 1 + · subst h1 + rw [ifEqLen_pos (by simp), if_pos rfl, flipFn_eq] + rfl + rw [ifEqLen_neg (by simpa using h1), if_neg h1] + have hd2 : 2 ≤ d := by omega + have hdrop2 : (List.replicate d true).drop 2 = List.replicate (d - 2) true := by simp + by_cases h2 : d < 2 + (F.toFamily hd).degree + · -- the cloud's move + have hjlt : d - 2 < (F.toFamily hd).degree := by omega + rw [ifLtLen_pos (by simpa using h2), if_pos h2, hdrop2, + ownerFn_eq G v hvd, + cloudStepFn_eq G F pol hd ⟨G.ownerNum v, hulr⟩ v (d - 2) hv rfl hjlt + (hpc ⟨G.ownerNum v, hulr⟩)] + rw [ConstraintGraph.cloudStepN, dif_pos hulr, dif_pos hjlt] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have happ : ∀ n : ℕ, List.replicate n true ++ [true, true] + = List.replicate (n + 2) true := by + intro n + rw [List.replicate_add] + rfl + congr 1 + exact happ _ + · -- the expander's move + have hjlt : d - (2 + (F.toFamily hd).degree) < (F.toFamily hd).degree := by omega + have horder : (G.reduce (F.toFamily hd)).graph.order = 2 * G.numEdges := by + rw [ConstraintGraph.graph_reduce, ConstraintGraph.order_reduceGraph] + have hvlt : v < (G.reduce (F.toFamily hd)).graph.order := by rw [horder]; exact hv + have key : ∀ (n : ℕ) (_ : n = 2 * G.numEdges) (hvn : v < n) + (hjn : d - (2 + (F.toFamily hd).degree) < (F.toFamily hd).degree), + (((F.toFamily hd).rot n (⟨v, hvn⟩, ⟨d - (2 + (F.toFamily hd).degree), hjn⟩)).1.val, + ((F.toFamily hd).rot n + (⟨v, hvn⟩, ⟨d - (2 + (F.toFamily hd).degree), hjn⟩)).2.val) + = F.famRotVal hd (2 * G.numEdges) (v, d - (2 + (F.toFamily hd).degree)) := by + rintro n rfl hvn hjn + exact (F.famRotVal_eq hd hne ⟨v, hvn⟩ ⟨_, hjn⟩).symm + have hdropk : (List.replicate d true).drop (2 + (F.toFamily hd).degree) + = List.replicate (d - (2 + (F.toFamily hd).degree)) true := by simp + rw [ifLtLen_neg (by simpa using h2), if_neg h2, hdropk, + expStepFn_eq G F pol hd v (d - (2 + (F.toFamily hd).degree)) hne hpe] + rw [ConstraintGraph.expStepN, dif_pos hvlt, dif_pos hjlt] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hk := key _ horder hvlt hjlt + have hk1 := congrArg Prod.fst hk + have hk2 := congrArg Prod.snd hk + dsimp only at hk1 hk2 ⊢ + rw [hk1, hk2] + congr 1 + rw [Nat.add_assoc, ← List.replicate_add] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean b/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean new file mode 100644 index 00000000..1640f259 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean @@ -0,0 +1,257 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Preprocess +public import Complexitylib.Classes.PCP.Internal.CloudCount + +/-! +# The preprocessed graph, in numbers + +Preprocessing superposes three edge sets on the half-edges of a graph: the +edge-links pairing the two halves of an edge, the cloud-links joining the halves +that share an endpoint, and the expander's own edges, with a self-loop added at +every vertex. This module reads off what each of those does to a *number*. + +The numbering is the one `NumEnc` gives: a half-edge is `2 e` or `2 e + 1` +according to which end it is — the same number `DegreeReduction` sorts clouds by +— and a dart is `0` for the self-loop, `1` for the edge-link, `2 + j` for the +`j`-th cloud-link and `2 + degree + j` for the `j`-th expander edge. + +## Main results + +- `Complexity.ConstraintGraph.enc_halfEdge` — a half-edge's number is its code +- `Complexity.ConstraintGraph.enc_preLoop`, `enc_preEdge`, `enc_preCloud`, + `enc_preExp` — the four kinds of dart, and `preDart_cases`: there are no + others +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +open NumEnc + +variable {α : Type} [DecidableEq α] (G : ConstraintGraph α) (E : ExpanderFamily) + +omit [DecidableEq α] in +/-- **A half-edge's number is the code the clouds are sorted by.** -/ +theorem enc_halfEdge (p : G.HalfEdge) : enc p = G.halfCode p := by + show enc p.1 * 2 + enc p.2 = 2 * p.1.val + (if p.2 then 0 else 1) + show p.1.val * 2 + (if p.2 then 0 else 1) = _ + omega + +/-- The self-loop at a vertex. -/ +def preLoop : (G.preprocess E).graph.D := Sum.inl () + +/-- The link to the other half of the same edge. -/ +def preEdge : (G.preprocess E).graph.D := Sum.inr (Sum.inl none) + +/-- The `j`-th link inside the cloud. -/ +def preCloud (j : Fin E.degree) : (G.preprocess E).graph.D := Sum.inr (Sum.inl (some j)) + +/-- The `j`-th edge of the superposed expander. -/ +def preExp (j : Fin E.degree) : (G.preprocess E).graph.D := Sum.inr (Sum.inr j) + +/-- The darts of the preprocessed graph: a self-loop, an edge-link, the +cloud-links, and the expander's edges. -/ +theorem enc_preLoop : enc (G.preLoop E) = 0 := rfl + +theorem enc_preEdge : enc (G.preEdge E) = 1 := by + show 1 + 0 = 1 + omega + +theorem enc_preCloud (j : Fin E.degree) : enc (G.preCloud E j) = 2 + j.val := by + show 1 + (1 + j.val) = 2 + j.val + omega + +theorem enc_preExp (j : Fin E.degree) : enc (G.preExp E j) = 2 + E.degree + j.val := by + show 1 + ((E.degree + 1) + j.val) = 2 + E.degree + j.val + omega + +/-- Every dart is one of the four kinds. -/ +theorem preDart_cases (d : (G.preprocess E).graph.D) : + d = G.preLoop E ∨ d = G.preEdge E ∨ (∃ j, d = G.preCloud E j) ∨ ∃ j, d = G.preExp E j := by + match d with + | Sum.inl () => exact Or.inl rfl + | Sum.inr (Sum.inl none) => exact Or.inr (Or.inl rfl) + | Sum.inr (Sum.inl (some j)) => exact Or.inr (Or.inr (Or.inl ⟨j, rfl⟩)) + | Sum.inr (Sum.inr j) => exact Or.inr (Or.inr (Or.inr ⟨j, rfl⟩)) + +/-! ### What each kind of dart does -/ + +theorem rot_preLoop (v : (G.preprocess E).graph.V) : + (G.preprocess E).graph.rot (v, G.preLoop E) = (v, G.preLoop E) := rfl + +theorem rot_preEdge (v : G.HalfEdge) : + (G.preprocess E).graph.rot (v, G.preEdge E) = (G.flipHalf v, G.preEdge E) := rfl + +theorem rot_preCloud (v : G.HalfEdge) (j : Fin E.degree) : + (G.preprocess E).graph.rot (v, G.preCloud E j) + = ((G.cloudRot E v j).1, G.preCloud E (G.cloudRot E v j).2) := rfl + +theorem rot_preExp (v : G.HalfEdge) (j : Fin E.degree) : + (G.preprocess E).graph.rot (v, G.preExp E j) + = (E.vertexEquiv (G.reduce E).graph + (E.rot (G.reduce E).graph.order + ((E.vertexEquiv (G.reduce E).graph).symm v, j)).1, + G.preExp E (E.rot (G.reduce E).graph.order + ((E.vertexEquiv (G.reduce E).graph).symm v, j)).2) := rfl + +/-! ### The three moves, in numbers -/ + +omit [DecidableEq α] in +/-- **Crossing an edge flips the last bit of the number.** -/ +theorem enc_flipHalf (p : G.HalfEdge) : + enc (G.flipHalf p) = if enc p % 2 = 0 then enc p + 1 else enc p - 1 := by + rw [enc_halfEdge, enc_halfEdge, halfCode, halfCode, flipHalf] + cases p.2 <;> simp + +/-- **The expander's vertices are numbered as the graph's are.** -/ +theorem enc_vertexEquiv (x : Fin (G.reduce E).graph.order) : + enc (E.vertexEquiv (G.reduce E).graph x) = x.val := by + show enc ((NumEnc.equivFinCard (G.reduce E).graph.V).symm x) = _ + have h : NumEnc.enc ((NumEnc.equivFinCard (G.reduce E).graph.V).symm x) + = (NumEnc.equivFinCard (G.reduce E).graph.V + ((NumEnc.equivFinCard (G.reduce E).graph.V).symm x)).val := rfl + rw [h, Equiv.apply_symm_apply] + +theorem val_vertexEquiv_symm (v : (G.reduce E).graph.V) : + ((E.vertexEquiv (G.reduce E).graph).symm v).val = enc v := rfl + +/-! ### The cloud step, in numbers -/ + +/-- The cloud step on numbers: count how many of the cloud's half-edges come +before this one, let the expander family move that index, and read off the code +the new index names. -/ +noncomputable def cloudStepNum (v : Fin G.numVerts) (c : ℕ) (j : Fin E.degree) : ℕ × ℕ := + if h : countBelow (G.cloudCodes v) c < (G.cloudList v).length then + let q := E.rot (G.cloudList v).length (⟨countBelow (G.cloudCodes v) c, h⟩, j) + ((G.cloudCodes v).orderEmbOfFin (G.card_cloudCodes_eq_length v) q.1, q.2.val) + else (c, j.val) + +omit [DecidableEq α] in +/-- **The numbers run the cloud step.** -/ +theorem cloudStepNum_eq (p : G.HalfEdge) (j : Fin E.degree) : + G.cloudStepNum E (G.owner p) (enc p) j + = (enc (G.cloudRot E p j).1, (G.cloudRot E p j).2.val) := by + have hmem : p ∈ G.cloudList (G.owner p) := G.mem_cloudList_self p + have hlt : (G.cloudList (G.owner p)).idxOf p < (G.cloudList (G.owner p)).length := + List.idxOf_lt_length_iff.mpr hmem + have hidx : (G.cloudList (G.owner p)).idxOf p + = countBelow (G.cloudCodes (G.owner p)) (enc p) := by + rw [G.idxOf_cloudList rfl, enc_halfEdge] + have hlt' : countBelow (G.cloudCodes (G.owner p)) (enc p) + < (G.cloudList (G.owner p)).length := by rw [← hidx]; exact hlt + rw [cloudStepNum, dif_pos hlt'] + rw [cloudRot, cloudRotAux, dif_pos hlt] + simp only [← hidx] + refine Prod.ext ?_ rfl + dsimp only + conv_rhs => rw [enc_halfEdge] + have hq : (E.rot (G.cloudList (G.owner p)).length + (⟨(G.cloudList (G.owner p)).idxOf p, hlt⟩, j)).1.val + < (G.cloudList (G.owner p)).length := Fin.isLt _ + rw [← List.getElem_eq_getD (h := hq)] + exact G.halfCode_getElem_cloudList _ _ hq + +/-! ### The whole rotation map, in numbers -/ + +/-- The vertex a half-edge number is attached to. -/ +noncomputable def ownerNum (v : ℕ) : ℕ := + if h : v / 2 < G.numEdges then + (if v % 2 = 0 then (G.head ⟨v / 2, h⟩).val else (G.tail ⟨v / 2, h⟩).val) + else 0 + +omit [DecidableEq α] in +theorem ownerNum_enc (p : G.HalfEdge) : G.ownerNum (enc p) = (G.owner p).val := by + have hcode : enc p = 2 * p.1.val + (if p.2 then 0 else 1) := by + rw [enc_halfEdge, halfCode] + have hdiv : enc p / 2 = p.1.val := by + rw [hcode] + cases p.2 + · simp + omega + · simp + have hmod : enc p % 2 = (if p.2 then 0 else 1) := by + rw [hcode] + cases p.2 <;> simp + have hlt : enc p / 2 < G.numEdges := by rw [hdiv]; exact p.1.isLt + have hfin : (⟨enc p / 2, hlt⟩ : Fin G.numEdges) = p.1 := Fin.ext hdiv + rw [ownerNum, dif_pos hlt, hmod, owner, hfin] + cases p.2 <;> simp + +/-- The cloud step, on numbers throughout. -/ +noncomputable def cloudStepN (u c j : ℕ) : ℕ × ℕ := + if hu : u < G.numVerts then + if hj : j < E.degree then G.cloudStepNum E ⟨u, hu⟩ c ⟨j, hj⟩ else (c, j) + else (c, j) + +/-- The expander step, on numbers. -/ +noncomputable def expStepN (v j : ℕ) : ℕ × ℕ := + if hv : v < (G.reduce E).graph.order then + if hj : j < E.degree then + ((E.rot (G.reduce E).graph.order (⟨v, hv⟩, ⟨j, hj⟩)).1.val, + (E.rot (G.reduce E).graph.order (⟨v, hv⟩, ⟨j, hj⟩)).2.val) + else (v, j) + else (v, j) + +/-- **The preprocessed graph's rotation map, on numbers.** Dart `0` is the +self-loop, dart `1` crosses the edge, darts `2` to `deg + 1` rotate inside the +cloud, and the rest are the superposed expander's. -/ +noncomputable def preRotNum (v d : ℕ) : ℕ × ℕ := + if d = 0 then (v, 0) + else if d = 1 then ((if v % 2 = 0 then v + 1 else v - 1), 1) + else if d < 2 + E.degree then + ((G.cloudStepN E (G.ownerNum v) v (d - 2)).1, + (G.cloudStepN E (G.ownerNum v) v (d - 2)).2 + 2) + else + ((G.expStepN E v (d - (2 + E.degree))).1, + (G.expStepN E v (d - (2 + E.degree))).2 + 2 + E.degree) + +/-- **The numbers run the preprocessed graph's rotation map.** -/ +theorem preRotNum_eq (v : G.HalfEdge) (d : (G.preprocess E).graph.D) : + G.preRotNum E (enc v) (enc d) + = (enc (((G.preprocess E).graph.rot (v, d)).1 : G.HalfEdge), + enc ((G.preprocess E).graph.rot (v, d)).2) := by + rcases G.preDart_cases E d with rfl | rfl | ⟨j, rfl⟩ | ⟨j, rfl⟩ + · rw [G.enc_preLoop E, preRotNum, if_pos rfl, G.rot_preLoop E, G.enc_preLoop E] + rfl + · rw [G.enc_preEdge E, preRotNum, if_neg one_ne_zero, if_pos rfl, G.rot_preEdge E, + G.enc_preEdge E] + dsimp only + exact Prod.ext (G.enc_flipHalf v).symm rfl + · have hj := j.isLt + rw [G.enc_preCloud E j, preRotNum, if_neg (by omega), if_neg (by omega), + if_pos (by omega), G.rot_preCloud E, G.enc_preCloud E] + dsimp only + rw [G.ownerNum_enc] + have harg : (2 + j.val) - 2 = j.val := by omega + rw [harg, cloudStepN, dif_pos (G.owner v).isLt, dif_pos hj] + have hv : (⟨(G.owner v).val, (G.owner v).isLt⟩ : Fin G.numVerts) = G.owner v := rfl + have hjj : (⟨j.val, hj⟩ : Fin E.degree) = j := rfl + rw [hv, hjj, G.cloudStepNum_eq E v j] + exact Prod.ext rfl (by omega) + · have hj := j.isLt + have hvlt : enc v < (G.reduce E).graph.order := by + have := NumEnc.enc_lt v + rwa [NumEnc.card_eq_fintype_card] at this + rw [G.enc_preExp E j, preRotNum, if_neg (by omega), if_neg (by omega), + if_neg (by omega), G.rot_preExp E, G.enc_preExp E] + dsimp only + have harg : 2 + E.degree + j.val - (2 + E.degree) = j.val := by omega + rw [harg, expStepN, dif_pos hvlt, dif_pos hj] + have hv : (⟨enc v, hvlt⟩ : Fin (G.reduce E).graph.order) + = (E.vertexEquiv (G.reduce E).graph).symm v := + Fin.ext (G.val_vertexEquiv_symm E v).symm + have hjj : (⟨j.val, hj⟩ : Fin E.degree) = j := rfl + rw [hv, hjj] + exact Prod.ext (G.enc_vertexEquiv E _).symm (by omega) + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgRound.lean b/Complexitylib/Classes/PCP/Internal/AlgRound.lean new file mode 100644 index 00000000..32516f1a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgRound.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.AlgEdge +public import Complexitylib.Classes.PCP.Internal.AlgIter +public import Complexitylib.Classes.PCP.Internal.GapReduction + +/-! +# One round, uniformly + +`AlgEdge.stepFn_eq` computes a round of amplification for a graph whose sizes +match the constants it is given. Iterating a round needs more: *one* function +that is right for *every* graph. This module supplies the constants that do not +depend on the graph — the walk length, the degree, the tester's counts — and +specialises the round to them. + +The one fact that makes this possible is that the encoding a round composes with +does not depend on the graph either: the walks it is defined on are +`PreWalk E T`, whose type is fixed by the expander family alone. + +## Main definitions + +- `Complexity.roundOf` — the round's constants +- `Complexity.roundFn` — the round, as one `FP` function + +## Main results + +- `Complexity.roundFn_eq` — it computes a round of amplification, for every + graph +-/ + +@[expose] public section + +set_option maxRecDepth 8000 + +namespace Complexity + +open Dinur Tester BooleanAnalysis + +variable (F : FinBase) (hd : 1 < F.deg) + +/-! ### The constants -/ + +/-- The killing rate a round uses. -/ +noncomputable def qOf : ℕ := q₀ (F.toFamily hd) + +theorem qOf_pos : 0 < qOf F hd := by + have h := two_le_q₀ (F.toFamily hd) + show 0 < q₀ (F.toFamily hd) + omega + +/-- The walk length a round uses. -/ +noncomputable def walkLen : ℕ := powT K (qOf F hd) + +/-- How many random strings the tester has. -/ +noncomputable def cZOf : ℕ := 2 ^ ROf (bits (F.toFamily hd) (walkLen F hd)) + +/-- How many constraints the alphabet has. -/ +noncomputable def cRel : ℕ := Fintype.card (DinurAlpha → DinurAlpha → Bool) + +theorem cRel_eq : cRel = Fintype.card (DinurAlpha → DinurAlpha → Bool) := rfl + +theorem cRel_pos : 0 < cRel := Fintype.card_pos + +/-- The round's constants. -/ +noncomputable def roundOf : Round := + dinurRound F hd (qOf F hd) cRel (cZOf F hd) + +theorem roundOf_q : (roundOf F hd).q = qOf F hd := + dinurRound_q F hd (qOf F hd) cRel (cZOf F hd) + +theorem roundOf_T : (roundOf F hd).T = walkLen F hd := + dinurRound_T F hd (qOf F hd) cRel (cZOf F hd) + +theorem roundOf_C : (roundOf F hd).C = cRel := + dinurRound_C F hd (qOf F hd) cRel (cZOf F hd) + +theorem roundOf_cZ : (roundOf F hd).cZ = cZOf F hd := + dinurRound_cZ F hd (qOf F hd) cRel (cZOf F hd) + +theorem roundOf_deg : (roundOf F hd).deg = (F.toFamily hd).degree := + dinurRound_deg F hd (qOf F hd) cRel (cZOf F hd) + +theorem roundOf_P (G : ConstraintGraph DinurAlpha) : + (roundOf F hd).P = G.preDeg (F.toFamily hd) := + dinurRound_P F hd (qOf F hd) cRel (cZOf F hd) G + +theorem roundOf_cQ : (roundOf F hd).cQ = qOf F hd ^ walkLen F hd := + dinurRound_cQ F hd (qOf F hd) cRel (cZOf F hd) + +/-- A key to fall back on, for arguments that name no edge. -/ +noncomputable def dfltKey : StepKey (F.toFamily hd) (roundOf F hd).T (roundOf F hd).q + (bits (F.toFamily hd) (roundOf F hd).T) + (Fintype.card (DinurAlpha → DinurAlpha → Bool)) := + ⟨⟨fun _ => Sum.inl (), fun _ => ⟨0, qOf_pos F hd⟩⟩, + ⟨fun _ => 0, fun _ => ⟨0, Fintype.card_pos⟩⟩, + ⟨fun _ => Sum.inl (), ⟨0, ReadIdx.f1x⟩⟩⟩ + +/-- The encoding a round composes with. It is written at a graph, but does not +depend on it: the walks are those of the expander family. -/ +noncomputable def encOf : (PreWalk (F.toFamily hd) (roundOf F hd).T → DinurAlpha) → + Cube (bits (F.toFamily hd) (roundOf F hd).T) := + Dinur.enc (F.toFamily hd) (baseCSP []) (roundOf F hd).T + +theorem encOf_eq (G : ConstraintGraph DinurAlpha) : + encOf F hd = Dinur.enc (F.toFamily hd) G (roundOf F hd).T := rfl + +/-! ### The round -/ + +/-- **A round of amplification, as one function.** -/ +noncomputable def roundFn : List Bool → List Bool := + stepFn F (2 * Polynomial.X) (roundOf F hd) + (vertFactor (F.toFamily hd) (qOf F hd)) + (edgeFactor (F.toFamily hd) (qOf F hd)) + (posFactor (F.toFamily hd) (qOf F hd)) + (NumEnc.card (Cube (bits (F.toFamily hd) (roundOf F hd).T))) + (NumEnc.card (Cube (nOf (bits (F.toFamily hd) (roundOf F hd).T)))) + (NumEnc.card (Cube (nOf (bits (F.toFamily hd) (roundOf F hd).T) + * nOf (bits (F.toFamily hd) (roundOf F hd).T)))) + (dfltKey F hd) (encOf F hd) + +theorem roundOf_cQ_pos : 0 < (roundOf F hd).cQ := by + rw [roundOf_cQ] + exact Nat.pow_pos (qOf_pos F hd) + +theorem roundOf_cD_pos : 0 < (roundOf F hd).cD := by + rw [Round.cD, roundOf_q, roundOf_P F hd (baseCSP []), roundOf_T] + exact Nat.mul_pos (Nat.pow_pos ((baseCSP []).preDeg_pos (F.toFamily hd))) + (Nat.pow_pos (qOf_pos F hd)) + +theorem roundOf_cZ_pos : 0 < (roundOf F hd).cZ := by + rw [roundOf_cZ, cZOf] + exact Nat.two_pow_pos _ + +theorem roundOf_C_pos : 0 < (roundOf F hd).C := by + rw [roundOf_C] + exact cRel_pos + +theorem roundFn_mem_FP : roundFn F hd ∈ FP := + stepFn_mem_FP F (2 * Polynomial.X) (roundOf F hd) _ _ _ _ _ _ + (roundOf_cQ_pos F hd) (roundOf_cD_pos F hd) (roundOf_cZ_pos F hd) (roundOf_C_pos F hd) + (dfltKey F hd) (encOf F hd) + +/-- **The round computes a round of amplification, for every graph.** -/ +theorem roundFn_eq (G : ConstraintGraph DinurAlpha) : + roundFn F hd (encGraph G) + = encGraph (Dinur.step (F.toFamily hd) (qOf F hd) (qOf_pos F hd) G) := by + have hq : 0 < (roundOf F hd).q := by + rw [roundOf_q] + exact qOf_pos F hd + have hpol : ∀ n : ℕ, F.fitLevel hd n ≤ (2 * Polynomial.X : Polynomial ℕ).eval n := by + intro n + simpa using F.fitLevel_le hd n + have hrD : (roundOf F hd).cD + = NumEnc.card ((G.preprocess (F.toFamily hd)).killedPow + (roundOf F hd).q (roundOf F hd).T hq).graph.D := by + rw [NumEnc.card_eq_fintype_card, RegCSP.graph_killedPow] + show _ = ((G.preprocess (F.toFamily hd)).graph.killedPower + (roundOf F hd).q (roundOf F hd).T hq).deg + rw [RegGraph.deg_killedPower, G.deg_preprocess, Round.cD, roundOf_P F hd G, + G.preDeg_eq (F.toFamily hd)] + have hrZ : (roundOf F hd).cZ + = 2 ^ ROf (bits (F.toFamily hd) (roundOf F hd).T) := by + rw [roundOf_cZ, roundOf_T, cZOf] + refine stepFn_eq F (2 * Polynomial.X) hd G (roundOf F hd) hq _ _ _ _ _ _ + hrD hrZ (roundOf_deg F hd) (roundOf_P F hd G) ((roundOf_C F hd).trans cRel_eq) + ?_ ?_ ?_ ?_ rfl rfl rfl ?_ (dfltKey F hd) + · exact fun u => hpol _ + · exact hpol _ + · exact Dinur.numVerts_step (F.toFamily hd) _ hq G + · exact Dinur.numEdges_step (F.toFamily hd) _ hq G + · exact (Dinur.card_pos_step (F.toFamily hd) _ hq G).trans (Nat.mul_comm _ _) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgStep.lean b/Complexitylib/Classes/PCP/Internal/AlgStep.lean new file mode 100644 index 00000000..2fed6477 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgStep.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Dinur +public import Complexitylib.Classes.PCP.Internal.AlgCompose + +/-! +# One round, in numbers + +A round of amplification multiplies both counts of a constraint graph by a +constant factor. This module records those factors, so an algorithm that writes +the round's output knows how big it is. + +## Main results + +- `Complexity.MultiTest.numVerts_toGraph` — the vertices of a family's graph +- `Complexity.RegCSP.card_pos_compose` — the positions of a composed proof +- `Complexity.Dinur.numVerts_step` — a round's vertex count +- `Complexity.MultiTest.tailNum_eq` — the first endpoint of an edge +- `Complexity.MultiTest.rel_toGraph_eq` — its constraint, from the verdict and + the read +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +namespace MultiTest + +variable {Pos E Q : Type} (M : MultiTest Pos E Q) [Fintype Pos] [Fintype E] [Fintype Q] + [NumEnc Pos] [NumEnc E] [NumEnc Q] + +/-- **The vertices**: one per position, and one per (test, random string). -/ +theorem numVerts_toGraph : + M.toGraph.numVerts = Fintype.card Pos + Fintype.card E * 2 ^ M.R := by + show Fintype.card (Pos ⊕ (E × Cube M.R)) = _ + rw [Fintype.card_sum, Fintype.card_prod, card_cube] + +/-- Splitting a number into a quotient and a remainder, with the remainder +itself split. -/ +theorem split_mixed {a b c C Q : ℕ} (hb : b < C) (hc : c < Q) : + (a * (C * Q) + (b * Q + c)) / (C * Q) = a + ∧ (a * (C * Q) + (b * Q + c)) % (C * Q) / Q = b + ∧ (a * (C * Q) + (b * Q + c)) % Q = c := by + have hQ : 0 < Q := Nat.lt_of_le_of_lt (Nat.zero_le _) hc + have hCQ : 0 < C * Q := Nat.mul_pos (Nat.lt_of_le_of_lt (Nat.zero_le _) hb) hQ + have hlt : b * Q + c < C * Q := by + have : b * Q + Q ≤ C * Q := by + have : (b + 1) * Q ≤ C * Q := Nat.mul_le_mul_right _ hb + rw [Nat.add_mul, Nat.one_mul] at this + exact this + omega + have hmod : (a * (C * Q) + (b * Q + c)) % (C * Q) = b * Q + c := by + rw [Nat.mul_comm a (C * Q), Nat.mul_add_mod, Nat.mod_eq_of_lt hlt] + refine ⟨?_, ?_, ?_⟩ + · rw [Nat.mul_comm a (C * Q), Nat.mul_add_div hCQ, Nat.div_eq_of_lt hlt, Nat.add_zero] + · rw [hmod, Nat.mul_comm b Q, Nat.mul_add_div hQ, Nat.div_eq_of_lt hc, Nat.add_zero] + · have hre : a * (C * Q) + (b * Q + c) = c + (a * C + b) * Q := by ring + rw [hre, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hc] + +omit [Fintype Pos] [NumEnc Pos] in +/-- **How an edge number splits**: the test, the random string, the read. -/ +theorem enc_edgeOf_split (k : Fin (Fintype.card M.Edge)) : + NumEnc.enc (M.edgeOf k).1 = k.val / (2 ^ M.R * Fintype.card Q) + ∧ NumEnc.enc (M.edgeOf k).2.1 = k.val % (2 ^ M.R * Fintype.card Q) / Fintype.card Q + ∧ NumEnc.enc (M.edgeOf k).2.2 = k.val % Fintype.card Q := by + have hk : k.val = NumEnc.enc (M.edgeOf k).1 * (2 ^ M.R * Fintype.card Q) + + (NumEnc.enc (M.edgeOf k).2.1 * Fintype.card Q + NumEnc.enc (M.edgeOf k).2.2) := by + rw [← M.enc_edgeOf k, M.enc_edge] + rw [show NumEnc.card (Cube M.R) = 2 ^ M.R from by + rw [NumEnc.card_eq_fintype_card, card_cube]] + rw [show NumEnc.card Q = Fintype.card Q from NumEnc.card_eq_fintype_card Q] + have hb : NumEnc.enc (M.edgeOf k).2.1 < 2 ^ M.R := by + have := NumEnc.enc_lt (M.edgeOf k).2.1 + rwa [NumEnc.card_eq_fintype_card, card_cube] at this + have hc : NumEnc.enc (M.edgeOf k).2.2 < Fintype.card Q := by + have := NumEnc.enc_lt (M.edgeOf k).2.2 + rwa [NumEnc.card_eq_fintype_card] at this + obtain ⟨h1, h2, h3⟩ := split_mixed hb hc + exact ⟨by rw [hk, h1], by rw [hk, h2], by rw [hk, h3]⟩ + +/-- **The first endpoint of an edge, in numbers.** -/ +noncomputable def tailNum (k : ℕ) : ℕ := + Fintype.card Pos + + (k / (2 ^ M.R * Fintype.card Q) * 2 ^ M.R + + k % (2 ^ M.R * Fintype.card Q) / Fintype.card Q) + +theorem tailNum_eq (k : Fin (Fintype.card M.Edge)) : + M.tailNum k.val = (M.toGraph.tail k).val := by + obtain ⟨h1, h2, _⟩ := M.enc_edgeOf_split k + rw [tailNum, M.val_tail_toGraph, ← h1, ← h2, NumEnc.card_eq_fintype_card Pos, + NumEnc.card_eq_fintype_card (Cube M.R), card_cube] + +/-- The constraint an edge carries: the test vertex's answers must pass the +test, and the read's answer must be the position's bit. -/ +def relOfCheck (chk : (Q → ZMod 2) → Bool) (i : Q) : + Alpha Q → Alpha Q → Bool := + fun l₁ l₂ => decide (chk l₁.2 = true ∧ l₁.2 i = l₂.1) + +/-- **The constraint depends only on the verdict and the read.** -/ +theorem rel_toGraph_eq (k : Fin (Fintype.card M.Edge)) : + M.toGraph.rel k + = relOfCheck (M.check (M.edgeOf k).1 (M.edgeOf k).2.1) (M.edgeOf k).2.2 := rfl + +end MultiTest + +namespace RegCSP + +variable {β : Type} [Fintype β] [DecidableEq β] [Nonempty β] (R : RegCSP β) + [NumEnc R.graph.V] [NumEnc R.graph.D] (B : ℕ) + +omit [Fintype β] [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **The positions of a composed proof**: an encoding block per vertex, and a +linear and a quadratic table per dart. -/ +theorem card_pos_compose : + Fintype.card (R.Pos (B := B)) + = R.graph.order * 2 ^ B + + (R.graph.order * R.graph.deg * 2 ^ Tester.nOf B + + R.graph.order * R.graph.deg * 2 ^ (Tester.nOf B * Tester.nOf B)) := by + show Fintype.card ((R.graph.V × Cube B) ⊕ + ((R.Dart × Cube (Tester.nOf B)) ⊕ (R.Dart × Cube (Tester.nOf B * Tester.nOf B)))) = _ + rw [Fintype.card_sum, Fintype.card_sum, + show Fintype.card (R.graph.V × Cube B) = R.graph.order * 2 ^ B from by + rw [Fintype.card_prod, card_cube]; rfl, + show Fintype.card (R.Dart × Cube (Tester.nOf B)) + = R.graph.order * R.graph.deg * 2 ^ Tester.nOf B from by + rw [Fintype.card_prod, card_cube, R.card_dart], + show Fintype.card (R.Dart × Cube (Tester.nOf B * Tester.nOf B)) + = R.graph.order * R.graph.deg * 2 ^ (Tester.nOf B * Tester.nOf B) from by + rw [Fintype.card_prod, card_cube, R.card_dart]] + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- The composed test's randomness. -/ +theorem R_compose (enc : β → Cube B) : (R.compose enc).R = Tester.ROf B := rfl + +omit [DecidableEq β] [Nonempty β] in +/-- **An edge number splits into a vertex, a dart, a string and a read.** -/ +theorem edge_split (enc : β → Cube B) (k : Fin (Fintype.card (R.compose enc).Edge)) : + k.val = ((NumEnc.enc ((R.compose enc).edgeOf k).1.1 * NumEnc.card R.graph.D + + NumEnc.enc ((R.compose enc).edgeOf k).1.2) + * 2 ^ Tester.ROf B + + NumEnc.enc ((R.compose enc).edgeOf k).2.1) * 22 + + NumEnc.enc ((R.compose enc).edgeOf k).2.2 := by + have h1 := MultiTest.enc_edgeOf (M := R.compose enc) k + have h2 := MultiTest.enc_edge (M := R.compose enc) ((R.compose enc).edgeOf k) + have h3 := RegCSP.enc_dart R ((R.compose enc).edgeOf k).1 + have hq : NumEnc.card ReadIdx = 22 := rfl + have hcube : NumEnc.card (Cube (R.compose enc).R) = 2 ^ Tester.ROf B := by + rw [NumEnc.card_eq_fintype_card, card_cube, R_compose] + rw [h2, h3, hq, hcube] at h1 + rw [← h1] + ring + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **The first endpoint, from an edge's split.** -/ +theorem tailNum_split (enc : β → Cube B) (a c d : ℕ) (hc : c < 2 ^ Tester.ROf B) + (hd : d < 22) : + (R.compose enc).tailNum ((a * 2 ^ Tester.ROf B + c) * 22 + d) + = Fintype.card (R.Pos (B := B)) + (a * 2 ^ Tester.ROf B + c) := by + have hQ : Fintype.card ReadIdx = 22 := rfl + have hR : (2 : ℕ) ^ (R.compose enc).R = 2 ^ Tester.ROf B := rfl + have hre : (a * 2 ^ Tester.ROf B + c) * 22 + d + = a * (2 ^ Tester.ROf B * 22) + (c * 22 + d) := by ring + obtain ⟨h1, h2, _⟩ := MultiTest.split_mixed (a := a) hc hd + rw [MultiTest.tailNum, hQ, hR, hre, h1, h2] + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **The first endpoint**, with the string count given by name. -/ +theorem tailNum_split' (enc : β → Cube B) (cZ a c d : ℕ) (hcZ : cZ = 2 ^ Tester.ROf B) + (hc : c < cZ) (hd : d < 22) : + (R.compose enc).tailNum ((a * cZ + c) * 22 + d) + = Fintype.card (R.Pos (B := B)) + (a * cZ + c) := by + subst hcZ + exact tailNum_split R B enc a c d hc hd + +omit [DecidableEq β] [Nonempty β] in +/-- **An edge's data**, packaged so that a caller never has to spell the +composed system out: the test, the string and the read it names, together with +how its number splits. -/ +theorem edge_data (enc : β → Cube B) (e : ℕ) + (he : e < (R.compose enc).toGraph.numEdges) : + ∃ (p : R.Dart) (z : Cube (Tester.ROf B)) (i : ReadIdx), + p = ((R.compose enc).edgeOf ⟨e, he⟩).1 + ∧ z = ((R.compose enc).edgeOf ⟨e, he⟩).2.1 + ∧ i = ((R.compose enc).edgeOf ⟨e, he⟩).2.2 + ∧ e = ((NumEnc.enc p.1 * NumEnc.card R.graph.D + NumEnc.enc p.2) + * 2 ^ Tester.ROf B + NumEnc.enc z) * 22 + NumEnc.enc i := by + refine ⟨((R.compose enc).edgeOf ⟨e, he⟩).1, ((R.compose enc).edgeOf ⟨e, he⟩).2.1, + ((R.compose enc).edgeOf ⟨e, he⟩).2.2, rfl, rfl, rfl, ?_⟩ + exact edge_split R B enc ⟨e, he⟩ + +end RegCSP + +namespace Dinur + +variable (E : ExpanderFamily) + +/-- The constant factor by which a round multiplies the vertex count. -/ +noncomputable def vertFactor (q : ℕ) : ℕ := + 2 * (2 ^ bits E (powT K q) + + powDeg E ^ powT K q * q ^ powT K q + * (2 ^ Tester.nOf (bits E (powT K q)) + + 2 ^ (Tester.nOf (bits E (powT K q)) * Tester.nOf (bits E (powT K q))) + + 2 ^ Tester.ROf (bits E (powT K q)))) + +/-- The constant number of positions a round makes per edge of its input. -/ +noncomputable def posFactor (q : ℕ) : ℕ := + 2 * (2 ^ bits E (powT K q) + + powDeg E ^ powT K q * q ^ powT K q + * (2 ^ Tester.nOf (bits E (powT K q)) + + 2 ^ (Tester.nOf (bits E (powT K q)) * Tester.nOf (bits E (powT K q))))) + +/-- **The positions of a round's proof, counted.** -/ +theorem card_pos_step (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) : + Fintype.card (((G.preprocess E).killedPow q (powT K q) hq).Pos + (B := bits E (powT K q))) + = posFactor E q * G.numEdges := by + have horder : ((G.preprocess E).killedPow q (powT K q) hq).graph.order = 2 * G.numEdges := by + rw [RegCSP.graph_killedPow, RegGraph.order_killedPower, G.order_preprocess] + have hdeg : ((G.preprocess E).killedPow q (powT K q) hq).graph.deg + = powDeg E ^ powT K q * q ^ powT K q := by + rw [RegCSP.graph_killedPow, RegGraph.deg_killedPower, G.deg_preprocess, powDeg] + rw [RegCSP.card_pos_compose, horder, hdeg, posFactor] + ring + +/-- A round's output, named. -/ +theorem step_eq (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) : + step E q hq G + = (((G.preprocess E).killedPow q (powT K q) hq).compose + (enc E G (powT K q))).toGraph := rfl + +/-- **The first endpoint of a round's edge**: the test vertex it belongs to, +after all the positions. -/ +theorem tail_step (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) + (k : Fin (Fintype.card (((G.preprocess E).killedPow q (powT K q) hq).compose + (enc E G (powT K q))).Edge)) : + ((((G.preprocess E).killedPow q (powT K q) hq).compose + (enc E G (powT K q))).toGraph.tail k).val + = posFactor E q * G.numEdges + + (k.val / (2 ^ (((G.preprocess E).killedPow q (powT K q) hq).compose + (enc E G (powT K q))).R * 22) + * 2 ^ (((G.preprocess E).killedPow q (powT K q) hq).compose + (enc E G (powT K q))).R + + k.val % (2 ^ (((G.preprocess E).killedPow q (powT K q) hq).compose + (enc E G (powT K q))).R * 22) / 22) := by + have h := MultiTest.tailNum_eq + (M := ((G.preprocess E).killedPow q (powT K q) hq).compose (enc E G (powT K q))) k + rw [← h, MultiTest.tailNum, card_pos_step, card_readIdx] + +/-- **A round multiplies the vertex count by a constant.** -/ +theorem numVerts_step (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) : + (step E q hq G).numVerts = vertFactor E q * G.numEdges := by + have horder : ((G.preprocess E).killedPow q (powT K q) hq).graph.order = 2 * G.numEdges := by + rw [RegCSP.graph_killedPow, RegGraph.order_killedPower, G.order_preprocess] + have hdeg : ((G.preprocess E).killedPow q (powT K q) hq).graph.deg + = powDeg E ^ powT K q * q ^ powT K q := by + rw [RegCSP.graph_killedPow, RegGraph.deg_killedPower, G.deg_preprocess, powDeg] + have hdart : Fintype.card ((G.preprocess E).killedPow q (powT K q) hq).Dart + = 2 * G.numEdges * (powDeg E ^ powT K q * q ^ powT K q) := by + rw [RegCSP.card_dart, horder, hdeg] + have hR : (RegCSP.compose (enc E G (powT K q)) + ((G.preprocess E).killedPow q (powT K q) hq)).R + = Tester.ROf (bits E (powT K q)) := rfl + rw [step, MultiTest.numVerts_toGraph, RegCSP.card_pos_compose, horder, hdeg, hdart, hR, + vertFactor] + ring + +end Dinur + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgUniform.lean b/Complexitylib/Classes/PCP/Internal/AlgUniform.lean new file mode 100644 index 00000000..599b95b0 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgUniform.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Classes.PCP.Internal.UnaryList +public import Complexitylib.SAT.Encoding +public import Complexitylib.Classes.Containments.Internal.LogSpaceBound + +/-! +# A size that only the length decides + +A `PCP` verifier's coin count is a function of the input's *length*. The graph +it reads therefore has to have a size the length alone decides, which the graph +of a formula does not. The remedy is to pad every graph up to one common size — +and for that one needs a size that is both computable and large enough for every +input of that length. + +Any `FP` function has one: a machine that runs in time `p` writes at most +`p |x|` bits, so `p` bounds the output length uniformly over inputs of a given +length, and `Cobham.exists_exact_ruler` writes `p |x|` marks. + +## Main results + +- `Complexity.exists_length_bound` — an `FP` function's output is polynomially + long +- `Complexity.exists_padRuler` — hence a uniform, computable padding size +-/ + +@[expose] public section + +namespace Complexity + +/-- **An `FP` function's output is polynomially long.** -/ +theorem exists_length_bound {f : List Bool → List Bool} (hf : f ∈ FP) : + ∃ p : Polynomial ℕ, ∀ x, (f x).length ≤ p.eval x.length := by + rw [mem_FP_iff_computesInTime_polynomial] at hf + obtain ⟨_, _, p, hcomp⟩ := hf + exact ⟨p, fun x => hcomp.output_length_le x⟩ + +/-- A formula is no longer than its encoding. -/ +theorem length_le_length_encode (φ : SAT.CNF) : φ.length ≤ φ.encode.length := by + induction φ with + | nil => simp + | cons c cs ih => + rw [SAT.CNF.encode_cons, List.length_cons, List.length_append, List.length_append] + simp only [List.length_cons, List.length_nil] + omega + +/-- **A uniform padding size**: marks, as many as any input of that length can +force, and as many for one input as for any other of the same length. -/ +theorem exists_padRuler {f : List Bool → List Bool} (hf : f ∈ FP) (c : ℕ) : + ∃ (padU : List Bool → List Bool) (q : Polynomial ℕ), padU ∈ FP + ∧ (∀ x, padU x = List.replicate (padU x).length true) + ∧ (∀ x, (padU x).length = q.eval x.length) + ∧ ∀ x, c * (f x).length ≤ (padU x).length := by + obtain ⟨p, hp⟩ := exists_length_bound hf + obtain ⟨R, hR, hRlen⟩ := Cobham.exists_exact_ruler (Polynomial.C c * p) + refine ⟨fun z => marks (R z), Polynomial.C c * p, marks_mem_FP hR, fun x => ?_, ?_, ?_⟩ + · show marks (R x) = List.replicate (marks (R x)).length true + rw [marks_eq, List.length_replicate] + · intro x + show (marks (R x)).length = _ + rw [marks_eq, List.length_replicate, hRlen] + · intro x + show c * (f x).length ≤ (marks (R x)).length + rw [marks_eq, List.length_replicate, hRlen, Polynomial.eval_mul, Polynomial.eval_C] + exact Nat.mul_le_mul_left c (hp x) + +/-! ### Rulers, structurally + +Writing a polynomial out and evaluating it is unworkable here: the constants +involved are the alphabet's constraint count and the round's growth factor, and +no tactic may be allowed near them. So the width is built from closure +properties instead — a sum of rulers is an append, a product is a length +multiplication — and no arithmetic is ever performed on a constant. -/ + +/-- A function of the input's length that an `FP` string is long enough for. -/ +def HasRuler (f : ℕ → ℕ) : Prop := + ∃ R : List Bool → List Bool, R ∈ FP ∧ ∀ z : List Bool, f z.length ≤ (R z).length + +/-- A polynomial's own values are polynomially bounded. -/ +theorem polyBounded_eval (p : Polynomial ℕ) : PolyBounded fun n => p.eval n := by + refine ⟨∑ i ∈ Finset.range (p.natDegree + 1), p.coeff i, p.natDegree, fun n => ?_⟩ + show p.eval n ≤ _ + rw [Polynomial.eval_eq_sum_range, Finset.sum_mul] + refine Finset.sum_le_sum fun i hi => ?_ + have hi' : i ≤ p.natDegree := by + rw [Finset.mem_range] at hi + omega + exact Nat.mul_le_mul_left _ + (le_trans (Nat.pow_le_pow_left (by omega) i) (Nat.pow_le_pow_right (by omega) hi')) + +namespace HasRuler + +theorem of_poly (p : Polynomial ℕ) : HasRuler fun n => p.eval n := Cobham.exists_ruler p + +theorem const (c : ℕ) : HasRuler fun _ => c := + ⟨fun _ => List.replicate c false, constFn_mem_FP _, fun _ => by rw [List.length_replicate]⟩ + +theorem mono {f g : ℕ → ℕ} (hg : HasRuler g) (h : ∀ n, f n ≤ g n) : HasRuler f := by + obtain ⟨R, hR, hlen⟩ := hg + exact ⟨R, hR, fun z => le_trans (h z.length) (hlen z)⟩ + +theorem add {f g : ℕ → ℕ} (hf : HasRuler f) (hg : HasRuler g) : + HasRuler fun n => f n + g n := by + obtain ⟨R, hR, hRlen⟩ := hf + obtain ⟨S, hS, hSlen⟩ := hg + refine ⟨fun z => R z ++ S z, Cobham.appendFn_mem_FP hR hS, fun z => ?_⟩ + rw [List.length_append] + exact Nat.add_le_add (hRlen z) (hSlen z) + +theorem mul {f g : ℕ → ℕ} (hf : HasRuler f) (hg : HasRuler g) : + HasRuler fun n => f n * g n := by + obtain ⟨R, hR, hRlen⟩ := hf + obtain ⟨S, hS, hSlen⟩ := hg + refine ⟨fun z => List.replicate ((R z).length * (S z).length) false, + Cobham.mulLenFn_mem_FP hR hS, fun z => ?_⟩ + rw [List.length_replicate] + exact Nat.mul_le_mul (hRlen z) (hSlen z) + +theorem pow {f : ℕ → ℕ} (hf : HasRuler f) (d : ℕ) : HasRuler fun n => f n ^ d := by + induction d with + | zero => exact mono (const 1) fun n => by rw [pow_zero] + | succ d ih => exact mono (mul ih hf) fun n => by rw [pow_succ] + +end HasRuler + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgWalk.lean b/Complexitylib/Classes/PCP/Internal/AlgWalk.lean new file mode 100644 index 00000000..adeb6c73 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlgWalk.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.KilledCSP +public import Complexitylib.Classes.PCP.Internal.NumEncPi +public import Complexitylib.Classes.PCP.Internal.AlgPreprocess + +/-! +# The killed walk, in numbers + +A dart of the powered graph is a tuple of steps together with a tuple of coins; +the walk runs until the first coin that is zero. `NumEncPi` numbers both tuples +digit by digit, so an algorithm recovers a step or a coin by dividing and taking +the remainder. This module reads the stopping rule off those digits. + +## Main definitions + +- `Complexity.stopAtNum` — where a killed walk stops, from the coins' number + +## Main results + +- `Complexity.stopAtNum_eq` — it is the abstract stopping index +- `Complexity.ConstraintGraph.walkNum_eq` — and following the step digits walks + the preprocessed graph +- `Complexity.ConstraintGraph.killedRevNum_eq` — the dart a killed walk comes + back by, digit by digit +- `Complexity.ConstraintGraph.killedRotNum_eq` — the powered graph's rotation + map, in numbers +-/ + +@[expose] public section + +namespace Complexity + +open NumEnc + +theorem findIdx_congr {β : Type} {l : List β} {p q : β → Bool} (h : ∀ x ∈ l, p x = q x) : + l.findIdx p = l.findIdx q := by + induction l with + | nil => rfl + | cons a t ih => + rw [List.findIdx_cons, List.findIdx_cons, h a List.mem_cons_self, + ih fun x hx => h x (List.mem_cons_of_mem _ hx)] + +/-- Where a killed walk stops, read off the coins' number: the first digit that +is zero, or the whole length if there is none. -/ +def stopAtNum (T q c : ℕ) : ℕ := + (List.finRange T).findIdx fun j => (c / q ^ j.val) % q == 0 + +/-- **The digits give the stopping index.** -/ +theorem stopAtNum_eq {T q : ℕ} (hq : 0 < q) (c : Fin T → Fin q) : + stopAtNum T q (enc c) = stopAt c := by + rw [stopAtNum, stopAt] + refine findIdx_congr fun j _ => ?_ + have hcard : card (Fin q) = q := rfl + have hdig : (enc c / q ^ j.val) % q = enc (c j) := by + have h := digit_sum (c := card (Fin q)) hq (encAt c) j.isLt + (fun i hi => encAt_lt c hi) + rw [hcard] at h + rw [show (enc c : ℕ) = ∑ i ∈ Finset.range T, encAt c i * q ^ i from rfl, h, encAt, + dif_pos j.isLt] + rw [hdig] + rfl + +namespace ConstraintGraph + +variable {α : Type} [DecidableEq α] (G : ConstraintGraph α) (E : ExpanderFamily) + +/-- How many darts the preprocessed graph has at each vertex. -/ +noncomputable def preDeg : ℕ := card (G.preprocess E).graph.D + +/-- The vertex reached after `k` steps, following the digits of `s`. -/ +noncomputable def walkNum (G : ConstraintGraph α) (E : ExpanderFamily) (s : ℕ) : + ℕ → ℕ → ℕ + | 0, v => v + | k + 1, v => + (G.preRotNum E (walkNum G E s k v) ((s / G.preDeg E ^ k) % G.preDeg E)).1 + +/-- The digits of a tuple's number are its entries' numbers. -/ +theorem digit_enc {T : ℕ} (s : Fin T → (G.preprocess E).graph.D) (hpos : 0 < G.preDeg E) + (k : ℕ) (hk : k < T) : (enc s / G.preDeg E ^ k) % G.preDeg E = enc (s ⟨k, hk⟩) := by + have h := digit_sum (c := card (G.preprocess E).graph.D) hpos (encAt s) hk + (fun i hi => encAt_lt s hi) + rw [show (enc s : ℕ) + = ∑ i ∈ Finset.range T, encAt s i * card (G.preprocess E).graph.D ^ i from rfl, + preDeg, h, encAt, dif_pos hk] + +/-- **Following the digits walks the graph.** The steps are read from any number +whose digits are the tuple's entries, so a prefix of a longer walk may be run +from that walk's own number. -/ +theorem walkNum_eq {T : ℕ} (v : G.HalfEdge) (s : Fin T → (G.preprocess E).graph.D) (n : ℕ) + (hdig : ∀ (k : ℕ) (hk : k < T), (n / G.preDeg E ^ k) % G.preDeg E = enc (s ⟨k, hk⟩)) : + ∀ {k : ℕ}, k ≤ T → + G.walkNum E n k (enc v) = enc ((G.preprocess E).graph.walkAt T v s k) := by + intro k + induction k with + | zero => intro _; rfl + | succ k ih => + intro hk + have hkT : k < T := by omega + rw [walkNum, ih (by omega), hdig k hkT, + (G.preprocess E).graph.walkAt_succ_of_lt v s hkT, RegGraph.nbr] + exact congrArg Prod.fst (G.preRotNum_eq E _ _) + +/-! ### The dart the walk comes back by -/ + +/-- The dart a killed walk comes back by, in numbers: below the stopping index +the digits are the labels pointing back, read in reverse order; above it they +are the original steps. -/ +noncomputable def killedRevNum (T q v s c : ℕ) : ℕ := + ∑ j ∈ Finset.range T, + (if j < stopAtNum T q c then + (G.preRotNum E (G.walkNum E s (stopAtNum T q c - 1 - j) v) + ((s / G.preDeg E ^ (stopAtNum T q c - 1 - j)) % G.preDeg E)).2 + else (s / G.preDeg E ^ j) % G.preDeg E) * G.preDeg E ^ j + +/-- **The digits give the dart the walk comes back by.** -/ +theorem killedRevNum_eq {T q : ℕ} (hq : 0 < q) (hpos : 0 < G.preDeg E) (v : G.HalfEdge) + (s : Fin T → (G.preprocess E).graph.D) (c : Fin T → Fin q) : + G.killedRevNum E T q (enc v) (enc s) (enc c) + = enc ((G.preprocess E).graph.killedRev v s c) := by + have hdig : ∀ (k : ℕ) (hk : k < T), + (enc s / G.preDeg E ^ k) % G.preDeg E = enc (s ⟨k, hk⟩) := by + intro k hk + have h := digit_sum (c := card (G.preprocess E).graph.D) hpos (encAt s) hk + (fun i hi => encAt_lt s hi) + rw [show (enc s : ℕ) + = ∑ i ∈ Finset.range T, encAt s i * card (G.preprocess E).graph.D ^ i from rfl, + preDeg, h, encAt, dif_pos hk] + have hstop : stopAtNum T q (enc c) = stopAt c := stopAtNum_eq hq c + have hle : stopAt c ≤ T := stopAt_le c + rw [killedRevNum, hstop, + show (enc ((G.preprocess E).graph.killedRev v s c) : ℕ) + = ∑ j ∈ Finset.range T, + encAt ((G.preprocess E).graph.killedRev v s c) j * G.preDeg E ^ j from rfl] + refine Finset.sum_congr rfl fun j hj => ?_ + rw [Finset.mem_range] at hj + congr 1 + rw [encAt, dif_pos hj] + by_cases hjlt : j < stopAt c + · rw [if_pos hjlt] + have hk : stopAt c - 1 - j < T := by omega + rw [hdig _ hk] + have hrev : ((G.preprocess E).graph.killedRev v s c) ⟨j, hj⟩ + = (G.preprocess E).graph.backLabel v + ((G.preprocess E).graph.preWalk s hle) (Fin.rev ⟨j, hjlt⟩) := by + rw [RegGraph.killedRev, RegGraph.extWalk, dif_pos hjlt, RegGraph.revWalk] + rw [hrev, RegGraph.backLabel] + have hidx : (Fin.rev (⟨j, hjlt⟩ : Fin (stopAt c))).val = stopAt c - 1 - j := by + rw [Fin.val_rev] + show stopAt c - (j + 1) = stopAt c - 1 - j + omega + rw [hidx] + have hwalk : ((G.preprocess E).graph.preWalk s hle) (Fin.rev (⟨j, hjlt⟩ : Fin (stopAt c))) + = s ⟨stopAt c - 1 - j, hk⟩ := by + rw [RegGraph.preWalk] + congr 1 + exact Fin.ext hidx + rw [hwalk] + have hpre : ∀ (k : ℕ) (hk : k < stopAt c), + (enc s / G.preDeg E ^ k) % G.preDeg E + = enc (((G.preprocess E).graph.preWalk s hle) ⟨k, hk⟩) := by + intro k hk + rw [G.digit_enc E s hpos k (lt_of_lt_of_le hk hle), RegGraph.preWalk] + rw [G.walkNum_eq E v ((G.preprocess E).graph.preWalk s hle) (enc s) hpre (by omega)] + exact congrArg Prod.snd (G.preRotNum_eq E _ _) + · rw [if_neg hjlt, hdig _ hj] + congr 1 + rw [RegGraph.killedRev, RegGraph.extWalk, dif_neg hjlt] + +/-! ### The powered graph's rotation map -/ + +/-- The powered graph's rotation map, in numbers: walk to the end, come back by +the reversed labels, and keep the coins. -/ +noncomputable def killedRotNum (T q v s c : ℕ) : ℕ × ℕ := + (G.walkNum E s (stopAtNum T q c) v, G.killedRevNum E T q v s c * q ^ T + c) + +/-- **The numbers run the powered graph's rotation map.** -/ +theorem killedRotNum_eq {T q : ℕ} (hq : 0 < q) (hpos : 0 < G.preDeg E) (v : G.HalfEdge) + (x : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)) + {w : G.HalfEdge} {y : (Fin T → (G.preprocess E).graph.D) × (Fin T → Fin q)} + (hw : ((G.preprocess E).graph.killedPower q T hq).rot (v, x) = (w, y)) : + G.killedRotNum E T q (enc v) (enc x.1) (enc x.2) = (enc w, enc y) := by + have hle : stopAt x.2 ≤ T := stopAt_le x.2 + have hstop : stopAtNum T q (enc x.2) = stopAt x.2 := stopAtNum_eq hq x.2 + have hw1 : ((G.preprocess E).graph.killedEnd v x.1 x.2) = w := congrArg Prod.fst hw + have hw2 : (((G.preprocess E).graph.killedRev v x.1 x.2), x.2) = y := congrArg Prod.snd hw + refine Prod.ext ?_ ?_ + · show G.walkNum E (enc x.1) (stopAtNum T q (enc x.2)) (enc v) = _ + rw [hstop] + have hpre : ∀ (k : ℕ) (hk : k < stopAt x.2), + (enc x.1 / G.preDeg E ^ k) % G.preDeg E + = enc (((G.preprocess E).graph.preWalk x.1 hle) ⟨k, hk⟩) := by + intro k hk + rw [G.digit_enc E x.1 hpos k (lt_of_lt_of_le hk hle), RegGraph.preWalk] + rw [G.walkNum_eq E v ((G.preprocess E).graph.preWalk x.1 hle) (enc x.1) hpre le_rfl] + rw [← hw1, RegGraph.killedEnd, ← RegGraph.walkAt_self_eq_walkEnd] + rfl + · show G.killedRevNum E T q (enc v) (enc x.1) (enc x.2) * q ^ T + enc x.2 = _ + rw [G.killedRevNum_eq E hq hpos v x.1 x.2, ← hw2] + rfl + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean b/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean new file mode 100644 index 00000000..04467118 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph + +/-! +# Enlarging the alphabet of a constraint graph + +Dinur's round is an endomorphism of constraint graphs over one fixed alphabet — +the one its composition step produces — while the reduction from 3-SAT lands in +an alphabet of its own. This module bridges the two: an injection of alphabets +carries a constraint graph to a graph over the larger alphabet, keeping the same +vertices and edges, and preserving satisfiability in both directions. + +An edge of the lifted graph accepts a pair of symbols exactly when both are +images and the originals satisfied the original edge. So an assignment using a +symbol outside the image fails every edge at that vertex, and a satisfying +assignment of the lift can be pulled back. + +## Main definitions + +- `Complexity.ConstraintGraph.lift` — the graph over the larger alphabet + +## Main results + +- `Complexity.ConstraintGraph.satisfiable_lift_iff` — satisfiability is preserved +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α β : Type} [Fintype α] [DecidableEq β] + +/-- The same graph, read over a larger alphabet along `f`. -/ +def lift (G : ConstraintGraph α) (f : α → β) : ConstraintGraph β where + numVerts := G.numVerts + numEdges := G.numEdges + tail := G.tail + head := G.head + rel := fun e b₁ b₂ => + decide (∃ a₁ : α, ∃ a₂ : α, f a₁ = b₁ ∧ f a₂ = b₂ ∧ G.rel e a₁ a₂ = true) + +@[simp] theorem rel_lift (G : ConstraintGraph α) (f : α → β) (e : Fin (G.lift f).numEdges) + (b₁ b₂ : β) : + (G.lift f).rel e b₁ b₂ + = decide (∃ a₁ : α, ∃ a₂ : α, f a₁ = b₁ ∧ f a₂ = b₂ ∧ G.rel e a₁ a₂ = true) := rfl + +@[simp] theorem tail_lift (G : ConstraintGraph α) (f : α → β) + (e : Fin (G.lift f).numEdges) : (G.lift f).tail e = G.tail e := rfl + +@[simp] theorem head_lift (G : ConstraintGraph α) (f : α → β) + (e : Fin (G.lift f).numEdges) : (G.lift f).head e = G.head e := rfl + +@[simp] theorem numEdges_lift (G : ConstraintGraph α) (f : α → β) : + (G.lift f).numEdges = G.numEdges := rfl + +@[simp] theorem numVerts_lift (G : ConstraintGraph α) (f : α → β) : + (G.lift f).numVerts = G.numVerts := rfl + +theorem satisfies_lift_iff (G : ConstraintGraph α) (f : α → β) + (b : (G.lift f).Assignment) (e : Fin (G.lift f).numEdges) : + (G.lift f).Satisfies b e ↔ + ∃ a₁ : α, ∃ a₂ : α, f a₁ = b (G.tail e) ∧ f a₂ = b (G.head e) + ∧ G.rel e a₁ a₂ = true := by + rw [Satisfies, satisfies] + simp [lift] + +/-- **Satisfiability is unchanged.** -/ +theorem satisfiable_lift_iff (G : ConstraintGraph α) {f : α → β} (hf : Function.Injective f) + [Nonempty α] : (G.lift f).Satisfiable ↔ G.Satisfiable := by + classical + constructor + · rintro ⟨b, hb⟩ + refine ⟨fun v => if h : ∃ x : α, f x = b v then h.choose else Classical.arbitrary α, ?_⟩ + intro e + have he := (satisfies_lift_iff G f b e).1 (hb e) + obtain ⟨a₁, a₂, h₁, h₂, hrel⟩ := he + have hex₁ : ∃ x : α, f x = b (G.tail e) := ⟨a₁, h₁⟩ + have hex₂ : ∃ x : α, f x = b (G.head e) := ⟨a₂, h₂⟩ + have hc₁ : hex₁.choose = a₁ := hf (hex₁.choose_spec.trans h₁.symm) + have hc₂ : hex₂.choose = a₂ := hf (hex₂.choose_spec.trans h₂.symm) + show G.rel e _ _ = true + dsimp only + rw [dif_pos hex₁, dif_pos hex₂, hc₁, hc₂] + exact hrel + · rintro ⟨a, ha⟩ + refine ⟨fun v => f (a v), fun e => ?_⟩ + rw [satisfies_lift_iff] + exact ⟨a (G.tail e), a (G.head e), rfl, rfl, ha e⟩ + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Amplification.lean b/Complexitylib/Classes/PCP/Internal/Amplification.lean new file mode 100644 index 00000000..50e1b92a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Amplification.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph +public import Mathlib.Tactic.Ring +public import Mathlib.Tactic.Linarith + +/-! +# Gap amplification: the iteration spine of Dinur's proof + +Dinur's proof of the PCP theorem rests on a single transformation of constraint +graphs over a *fixed* alphabet that + +* blows the graph up by at most a constant factor, +* keeps satisfiable graphs satisfiable, and +* **doubles** the unsatisfiability value, until it reaches a universal + constant `gap`. + +This module packages those three properties as `Amplifier` and derives the +consequence that drives everything else: iterating the transformation +logarithmically many times turns *any* unsatisfiable graph into one whose value +is at least `gap`, while a satisfiable graph stays satisfiable. That is the +constant-gap dichotomy an `O(log n)`-randomness, `O(1)`-query verifier needs. + +The construction of an `Amplifier` — degree reduction, expanderization, +powering, and alphabet reduction by composition — is the mathematical content +of the proof and lives in the sibling modules. Everything here is independent +of it, and independent of any machine model: the polynomial-time computability +of the iterated transformation is tracked separately. + +## Main definitions + +- `Amplifier` — the interface above +- `Amplifier.iter` — the `k`-fold iterate + +## Main results + +- `Amplifier.numEdges_iter_le` — the size grows by at most `edgeFactor ^ k` +- `Amplifier.satisfiable_iter` — satisfiability is preserved +- `Amplifier.unsatVal_iter_ge` — the value is at least `min gap (2 ^ k · v)` +- `Amplifier.gap_le_unsatVal_iter` — after `k` rounds with `numEdges ≤ 2 ^ k`, + an unsatisfiable graph has value at least `gap` +- `Amplifier.dichotomy` — the two cases together +-/ + +@[expose] public section + +namespace Complexity + +open ConstraintGraph + +/-- A gap amplifier for constraint graphs over the alphabet `α`: a +size-bounded, satisfiability-preserving transformation that doubles the +unsatisfiability value up to the threshold `gap`. -/ +structure Amplifier (α : Type) [Fintype α] [Nonempty α] where + /-- The transformation on constraint graphs. -/ + transform : ConstraintGraph α → ConstraintGraph α + /-- The constant factor by which the number of edges may grow. -/ + edgeFactor : ℕ + /-- The universal threshold beyond which the value need not grow. -/ + gap : ℚ + /-- The threshold is positive. -/ + gap_pos : 0 < gap + /-- The threshold is at most one, as any unsatisfiability value is. -/ + gap_le_one : gap ≤ 1 + /-- The transformation blows the graph up by at most a constant factor. -/ + numEdges_transform_le : ∀ G, (transform G).numEdges ≤ edgeFactor * G.numEdges + /-- Satisfiable graphs stay satisfiable: this is perfect completeness. -/ + satisfiable_transform : ∀ G, G.Satisfiable → (transform G).Satisfiable + /-- The value doubles, until it reaches `gap`. -/ + unsatVal_transform_ge : ∀ G, min gap (2 * G.unsatVal) ≤ (transform G).unsatVal + +namespace Amplifier + +variable {α : Type} [Fintype α] [Nonempty α] (A : Amplifier α) + +/-- The `k`-fold iterate of the amplifier. -/ +def iter (A : Amplifier α) (k : ℕ) (G : ConstraintGraph α) : ConstraintGraph α := + A.transform^[k] G + +@[simp] theorem iter_zero (G : ConstraintGraph α) : A.iter 0 G = G := rfl + +theorem iter_succ (k : ℕ) (G : ConstraintGraph α) : + A.iter (k + 1) G = A.transform (A.iter k G) := + Function.iterate_succ_apply' _ _ _ + +/-! ### Size -/ + +theorem numEdges_iter_le (k : ℕ) (G : ConstraintGraph α) : + (A.iter k G).numEdges ≤ A.edgeFactor ^ k * G.numEdges := by + induction k with + | zero => simp + | succ k ih => + calc (A.iter (k + 1) G).numEdges + ≤ A.edgeFactor * (A.iter k G).numEdges := by + rw [iter_succ]; exact A.numEdges_transform_le _ + _ ≤ A.edgeFactor * (A.edgeFactor ^ k * G.numEdges) := by + exact Nat.mul_le_mul_left _ ih + _ = A.edgeFactor ^ (k + 1) * G.numEdges := by ring + +/-! ### Completeness -/ + +theorem satisfiable_iter {G : ConstraintGraph α} (h : G.Satisfiable) (k : ℕ) : + (A.iter k G).Satisfiable := by + induction k with + | zero => simpa using h + | succ k ih => rw [iter_succ]; exact A.satisfiable_transform _ ih + +theorem unsatVal_iter_eq_zero_of_satisfiable {G : ConstraintGraph α} + (h : G.Satisfiable) (k : ℕ) : (A.iter k G).unsatVal = 0 := + (unsatVal_eq_zero_iff_satisfiable _).mpr (A.satisfiable_iter h k) + +/-! ### Soundness -/ + +/-- One doubling step, at the level of the truncated value `min gap ·`. -/ +private theorem min_le_min_two_mul {g X : ℚ} (hg : 0 ≤ g) (hX : 0 ≤ X) : + min g X ≤ min g (2 * min g X) := by + refine le_min (min_le_left _ _) ?_ + have h1 : (0 : ℚ) ≤ min g X := le_min hg hX + linarith + +theorem unsatVal_iter_ge (k : ℕ) (G : ConstraintGraph α) : + min A.gap (2 ^ k * G.unsatVal) ≤ (A.iter k G).unsatVal := by + induction k with + | zero => simp + | succ k ih => + have hstep : min A.gap (2 * (A.iter k G).unsatVal) ≤ (A.iter (k + 1) G).unsatVal := by + rw [iter_succ]; exact A.unsatVal_transform_ge _ + refine le_trans ?_ hstep + have hmono : min A.gap (2 * min A.gap (2 ^ k * G.unsatVal)) + ≤ min A.gap (2 * (A.iter k G).unsatVal) := by + refine le_min (min_le_left _ _) ?_ + have := min_le_right A.gap (2 * min A.gap (2 ^ k * G.unsatVal)) + linarith [this, ih] + refine le_trans ?_ hmono + have hX : (0 : ℚ) ≤ 2 ^ k * G.unsatVal := by + have := G.unsatVal_nonneg + positivity + have := min_le_min_two_mul (g := A.gap) (X := 2 ^ k * G.unsatVal) + (le_of_lt A.gap_pos) hX + calc min A.gap (2 ^ (k + 1) * G.unsatVal) + = min A.gap (2 * (2 ^ k * G.unsatVal)) := by ring_nf + _ ≤ min A.gap (2 * min A.gap (2 ^ k * G.unsatVal)) := by + refine le_min (min_le_left _ _) ?_ + rcases le_total A.gap (2 ^ k * G.unsatVal) with hle | hle + · have : min A.gap (2 ^ k * G.unsatVal) = A.gap := min_eq_left hle + rw [this] + have : min A.gap (2 * (2 ^ k * G.unsatVal)) ≤ A.gap := min_le_left _ _ + linarith [A.gap_pos] + · have : min A.gap (2 ^ k * G.unsatVal) = 2 ^ k * G.unsatVal := min_eq_right hle + rw [this] + exact min_le_right _ _ + +/-- After enough rounds an unsatisfiable graph has value at least `gap`. The +hypothesis `numEdges ≤ 2 ^ k` is what makes `k = O(log (size))` rounds +suffice. -/ +theorem gap_le_unsatVal_iter {G : ConstraintGraph α} (h : ¬ G.Satisfiable) {k : ℕ} + (hk : G.numEdges ≤ 2 ^ k) : A.gap ≤ (A.iter k G).unsatVal := by + refine le_trans ?_ (A.unsatVal_iter_ge k G) + refine le_min (le_refl _) ?_ + have hm : 0 < G.numEdges := numEdges_pos_of_not_satisfiable h + have hmq : (0 : ℚ) < (G.numEdges : ℚ) := by exact_mod_cast hm + have hkq : ((G.numEdges : ℚ)) ≤ 2 ^ k := by exact_mod_cast hk + have hlow : 1 / (G.numEdges : ℚ) ≤ G.unsatVal := inv_numEdges_le_unsatVal h + have h1 : (1 : ℚ) ≤ 2 ^ k * (1 / (G.numEdges : ℚ)) := by + rw [mul_one_div, le_div_iff₀ hmq, one_mul] + exact hkq + have h2 : (2 : ℚ) ^ k * (1 / (G.numEdges : ℚ)) ≤ 2 ^ k * G.unsatVal := by + have : (0 : ℚ) < 2 ^ k := by positivity + exact mul_le_mul_of_nonneg_left hlow (le_of_lt this) + linarith [A.gap_le_one] + +/-- The constant-gap dichotomy delivered by logarithmically many rounds: a +satisfiable graph maps to a satisfiable graph, and an unsatisfiable one to a +graph of value at least `gap`. -/ +theorem dichotomy (G : ConstraintGraph α) {k : ℕ} (hk : G.numEdges ≤ 2 ^ k) : + (G.Satisfiable → (A.iter k G).Satisfiable) ∧ + (¬ G.Satisfiable → A.gap ≤ (A.iter k G).unsatVal) := + ⟨fun h => A.satisfiable_iter h k, fun h => A.gap_le_unsatVal_iter h hk⟩ + +end Amplifier + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Arithmetize.lean b/Complexitylib/Classes/PCP/Internal/Arithmetize.lean new file mode 100644 index 00000000..b75ac86c --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Arithmetize.lean @@ -0,0 +1,359 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Hadamard + +/-! +# Arithmetizing a constraint + +The Hadamard tester checks a single quadratic equation over `𝔽₂`. The +constraint it is composed with in Dinur's proof is an arbitrary predicate on a +constant number of bits — the relation of an outer edge, spelled out on the +encodings of the two labels. Two gaps to close, both classical: + +* An arbitrary predicate is not one quadratic equation, but it is a *system* of + them once auxiliary variables are allowed. The system used here is the + **one-hot** encoding: a selector variable for each candidate assignment, + constrained to have exactly one selector set (a linear equation for the sum + and a quadratic one for each pair), only selectors of satisfying candidates + allowed, and the input bits equal to the selected candidate. + +* A system of equations is checked with one query by taking a **random linear + combination**: if any equation fails, the combination fails on exactly half + of the coefficient vectors, because the failing values form a nonzero vector + and a nonzero vector has odd inner product with half of all vectors. + +## Main definitions + +- `Complexity.QuadConstraint.combine` — a linear combination of constraints +- `Complexity.oneHotSystem` — the one-hot system for a set of satisfying + assignments + +## Main results + +- `Complexity.checkValue_combine` — the check of a combination is the + combination of the checks +- `Complexity.forall_checkValue_of_prob` — a combination passing on more than + half the coefficient vectors means every equation passes +- `Complexity.exists_sat_oneHotSystem`, `Complexity.mem_of_sat_oneHotSystem` + — the one-hot system is satisfiable exactly on the given set +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +variable {n : ℕ} + +/-! ### Linearity of the Hadamard table -/ + +/-- Reading a Hadamard table at a sum of vectors. -/ +theorem hadamard_add_arg (a x y : Cube n) : + hadamard a (x + y) = hadamard a x + hadamard a y := by + show ∑ i, a i * (x i + y i) = (∑ i, a i * x i) + (∑ i, a i * y i) + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun i _ => by ring + +/-- Reading a Hadamard table at a scalar multiple. -/ +theorem hadamard_smul_arg (a : Cube n) (c : ZMod 2) (x : Cube n) : + hadamard a (fun i => c * x i) = c * hadamard a x := by + show ∑ i, a i * (c * x i) = c * ∑ i, a i * x i + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun i _ => by ring + +/-- Reading a Hadamard table at a finite sum of scaled vectors. -/ +theorem hadamard_sum_smul {J : ℕ} (a : Cube n) (c : Cube J) (v : Fin J → Cube n) : + hadamard a (fun i => ∑ j, c j * v j i) = ∑ j, c j * hadamard a (v j) := by + show ∑ i, a i * ∑ j, c j * v j i = ∑ j, c j * ∑ i, a i * v j i + simp only [Finset.mul_sum] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun j _ => Finset.sum_congr rfl fun i _ => ?_ + ring + +/-! ### Random linear combinations -/ + +/-- A linear combination of constraints with coefficients `c`. -/ +def QuadConstraint.combine {J : ℕ} (C : Fin J → QuadConstraint n) (c : Cube J) : + QuadConstraint n where + quad := fun p => ∑ j, c j * (C j).quad p + lin := fun i => ∑ j, c j * (C j).lin i + const := ∑ j, c j * (C j).const + +/-- **The check of a combination is the combination of the checks**, when the +tables are Hadamard codewords (so linear). -/ +theorem checkValue_combine {J : ℕ} (a : Cube n) (b : Cube (n * n)) + (C : Fin J → QuadConstraint n) (c : Cube J) : + checkValue (hadamard b) (hadamard a) (QuadConstraint.combine C c) + = hadamard (fun j => checkValue (hadamard b) (hadamard a) (C j)) c := by + show hadamard b (fun p => ∑ j, c j * (C j).quad p) + hadamard a (fun i => ∑ j, c j * (C j).lin i) + + ∑ j, c j * (C j).const + = ∑ j, (hadamard b (C j).quad + hadamard a (C j).lin + (C j).const) * c j + rw [hadamard_sum_smul, hadamard_sum_smul, ← Finset.sum_add_distrib, ← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun j _ => ?_ + ring + +/-- **Rigidity of the combination.** If the combined check passes on more than +half of the coefficient vectors, every constraint's check passes. -/ +theorem forall_checkValue_of_prob {J : ℕ} (a : Cube n) (b : Cube (n * n)) + (C : Fin J → QuadConstraint n) + (h : 1 / 2 < Pr[fun c : Cube J => + checkValue (hadamard b) (hadamard a) (QuadConstraint.combine C c) = 0]) : + ∀ j, checkValue (hadamard b) (hadamard a) (C j) = 0 := by + classical + by_contra hcon + push Not at hcon + obtain ⟨j, hj⟩ := hcon + have hv : (fun j => checkValue (hadamard b) (hadamard a) (C j)) ≠ 0 := by + intro h0 + exact hj (congrFun h0 j) + have hhalf := prob_hadamard_ne_zero _ hv + have hrw : (fun c : Cube J => + checkValue (hadamard b) (hadamard a) (QuadConstraint.combine C c) = 0) + = fun c : Cube J => + ¬ (hadamard (fun j => checkValue (hadamard b) (hadamard a) (C j)) c ≠ 0) := by + funext c + rw [checkValue_combine] + exact propext not_not.symm + rw [hrw] at h + have hcompl := BooleanAnalysis.Internal.prob_compl + (fun c : Cube J => hadamard (fun j => checkValue (hadamard b) (hadamard a) (C j)) c ≠ 0) + linarith + +/-- The combination of constraints satisfied by `a` is satisfied by `a`. -/ +theorem QuadConstraint.sat_combine {J : ℕ} (C : Fin J → QuadConstraint n) (a : Cube n) + (h : ∀ j, (C j).Sat a) (c : Cube J) : (QuadConstraint.combine C c).Sat a := by + show hadamard (tensorAssign a) (fun p => ∑ j, c j * (C j).quad p) + + hadamard a (fun i => ∑ j, c j * (C j).lin i) + ∑ j, c j * (C j).const = 0 + rw [hadamard_sum_smul, hadamard_sum_smul, ← Finset.sum_add_distrib, ← Finset.sum_add_distrib] + refine Finset.sum_eq_zero fun j _ => ?_ + have hj : hadamard (tensorAssign a) (C j).quad + hadamard a (C j).lin + (C j).const = 0 := + h j + calc c j * hadamard (tensorAssign a) (C j).quad + c j * hadamard a (C j).lin + + c j * (C j).const + = c j * (hadamard (tensorAssign a) (C j).quad + hadamard a (C j).lin + (C j).const) := by + ring + _ = 0 := by rw [hj, mul_zero] + +/-! ### Reading a table at an appended vector -/ + +/-- Reading at an appended vector reads the two blocks separately. -/ +theorem hadamard_append {k t : ℕ} (a : Cube (k + t)) (u : Cube k) (v : Cube t) : + hadamard a (Fin.append u v) = hadamard (leftBlock a) u + hadamard (rightBlock a) v := by + show ∑ i : Fin (k + t), a i * (Fin.append u v) i + = (∑ i : Fin k, a (Fin.castAdd t i) * u i) + ∑ j : Fin t, a (Fin.natAdd k j) * v j + rw [Fin.sum_univ_add] + congr 1 + · exact Finset.sum_congr rfl fun i _ => by rw [Fin.append_left] + · exact Finset.sum_congr rfl fun j _ => by rw [Fin.append_right] + +theorem hadamard_zero_arg (a : Cube n) : hadamard a 0 = 0 := by + show ∑ i, a i * (0 : ZMod 2) = 0 + simp + +theorem hadamard_tensorAssign_basisVec (a : Cube n) (u v : Fin n) : + hadamard (tensorAssign a) (basisVec (finProdFinEquiv (u, v))) = a u * a v := by + rw [hadamard_basisVec] + show a (finProdFinEquiv.symm (finProdFinEquiv (u, v))).1 + * a (finProdFinEquiv.symm (finProdFinEquiv (u, v))).2 = a u * a v + rw [Equiv.symm_apply_apply] + +/-! ### The one-hot system -/ + +/-- Candidate assignments, numbered. -/ +noncomputable def candIdx (k : ℕ) : Cube k ≃ Fin (2 ^ k) := + Fintype.equivFinOfCardEq (card_cube k) + +/-- The selector variable of candidate number `m`. -/ +def auxVar (k : ℕ) (m : Fin (2 ^ k)) : Fin (k + 2 ^ k) := Fin.natAdd k m + +/-- The trivial constraint `0 = 0`. -/ +def QuadConstraint.trivial (n : ℕ) : QuadConstraint n := ⟨0, 0, 0⟩ + +theorem QuadConstraint.sat_trivial (a : Cube n) : (QuadConstraint.trivial n).Sat a := by + show hadamard (tensorAssign a) 0 + hadamard a 0 + 0 = 0 + rw [hadamard_zero_arg, hadamard_zero_arg] + simp + +/-- The index set of the one-hot system: the sum constraint, a constraint per +pair of candidates, a constraint per candidate, and a constraint per input +coordinate. -/ +abbrev OneHotIdx (k : ℕ) : Type := + Unit ⊕ ((Fin (2 ^ k) × Fin (2 ^ k)) ⊕ (Fin (2 ^ k) ⊕ Fin k)) + +/-- The constraints of the one-hot system for the satisfying set `S`. -/ +noncomputable def oneHotOf {k : ℕ} (S : Finset (Cube k)) : OneHotIdx k → QuadConstraint (k + 2 ^ k) + | Sum.inl () => ⟨0, Fin.append 0 (fun _ => 1), 1⟩ + | Sum.inr (Sum.inl (m, m')) => + if m = m' then QuadConstraint.trivial _ + else ⟨basisVec (finProdFinEquiv (auxVar k m, auxVar k m')), 0, 0⟩ + | Sum.inr (Sum.inr (Sum.inl m)) => + if (candIdx k).symm m ∈ S then QuadConstraint.trivial _ + else ⟨0, basisVec (auxVar k m), 0⟩ + | Sum.inr (Sum.inr (Sum.inr i)) => + ⟨0, Fin.append (basisVec i) (fun m => ((candIdx k).symm m) i), 0⟩ + +/-- **The one-hot system**, as a `Fin`-indexed family for `combine`. -/ +noncomputable def oneHotSystem {k : ℕ} (S : Finset (Cube k)) : + Fin (Fintype.card (OneHotIdx k)) → QuadConstraint (k + 2 ^ k) := + fun j => oneHotOf S ((Fintype.equivFin (OneHotIdx k)).symm j) + +theorem forall_oneHotSystem_iff {k : ℕ} (S : Finset (Cube k)) (a : Cube (k + 2 ^ k)) : + (∀ j, (oneHotSystem S j).Sat a) ↔ ∀ x, (oneHotOf S x).Sat a := by + constructor + · intro h x + have := h (Fintype.equivFin (OneHotIdx k) x) + simpa [oneHotSystem] using this + · intro h j + exact h _ + +/-! #### Evaluating the constraints -/ + +theorem sat_oneHot_sum_iff {k : ℕ} (S : Finset (Cube k)) (a : Cube (k + 2 ^ k)) : + (oneHotOf S (Sum.inl ())).Sat a ↔ ∑ m, rightBlock a m = 1 := by + show hadamard (tensorAssign a) 0 + hadamard a (Fin.append 0 (fun _ => 1)) + 1 = 0 ↔ _ + rw [hadamard_zero_arg, hadamard_append, hadamard_zero_arg] + have h : hadamard (rightBlock a) (fun _ => 1) = ∑ m, rightBlock a m := by + show ∑ m, rightBlock a m * 1 = _ + simp + rw [h] + rcases (by decide : ∀ u : ZMod 2, (0 + (0 + u) + 1 = 0) ↔ (u = 1)) (∑ m, rightBlock a m) + with h' + exact h' + +theorem sat_oneHot_pair_iff {k : ℕ} (S : Finset (Cube k)) (a : Cube (k + 2 ^ k)) + (m m' : Fin (2 ^ k)) (hne : m ≠ m') : + (oneHotOf S (Sum.inr (Sum.inl (m, m')))).Sat a ↔ rightBlock a m * rightBlock a m' = 0 := by + unfold QuadConstraint.Sat QuadConstraint.eval + simp only [oneHotOf, if_neg hne] + rw [hadamard_tensorAssign_basisVec, hadamard_zero_arg, add_zero, add_zero] + rfl + +theorem sat_oneHot_allowed_iff {k : ℕ} (S : Finset (Cube k)) (a : Cube (k + 2 ^ k)) + (m : Fin (2 ^ k)) (hm : (candIdx k).symm m ∉ S) : + (oneHotOf S (Sum.inr (Sum.inr (Sum.inl m)))).Sat a ↔ rightBlock a m = 0 := by + unfold QuadConstraint.Sat QuadConstraint.eval + simp only [oneHotOf, if_neg hm] + rw [hadamard_zero_arg, hadamard_basisVec, zero_add, add_zero] + rfl + +theorem sat_oneHot_coord_iff {k : ℕ} (S : Finset (Cube k)) (a : Cube (k + 2 ^ k)) (i : Fin k) : + (oneHotOf S (Sum.inr (Sum.inr (Sum.inr i)))).Sat a + ↔ leftBlock a i + ∑ m, rightBlock a m * ((candIdx k).symm m) i = 0 := by + show hadamard (tensorAssign a) 0 + + hadamard a (Fin.append (basisVec i) (fun m => ((candIdx k).symm m) i)) + 0 = 0 ↔ _ + rw [hadamard_zero_arg, hadamard_append, hadamard_basisVec, zero_add, add_zero] + rfl + +/-! #### Exactly one selector -/ + +/-- A `0`/`1` vector with odd sum and pairwise zero products is a basis vector. -/ +theorem eq_basis_of_sum_one {T : ℕ} (y : Fin T → ZMod 2) (hsum : ∑ m, y m = 1) + (hpair : ∀ m m', m ≠ m' → y m * y m' = 0) : + ∃ m₀, y m₀ = 1 ∧ ∀ m, m ≠ m₀ → y m = 0 := by + classical + have hex : ∃ m₀, y m₀ ≠ 0 := by + by_contra hcon + push Not at hcon + have : ∑ m, y m = 0 := Finset.sum_eq_zero fun m _ => hcon m + rw [this] at hsum + exact absurd hsum (by decide) + obtain ⟨m₀, hm₀⟩ := hex + have hone : y m₀ = 1 := by + rcases (by decide : ∀ u : ZMod 2, u ≠ 0 → u = 1) (y m₀) hm₀ with h + exact h + refine ⟨m₀, hone, fun m hm => ?_⟩ + have := hpair m m₀ hm + rw [hone, mul_one] at this + exact this + +/-! #### The characterization -/ + +/-- **Satisfying the one-hot system puts the input in the set.** -/ +theorem mem_of_sat_oneHotSystem {k : ℕ} (S : Finset (Cube k)) (a : Cube (k + 2 ^ k)) + (h : ∀ j, (oneHotSystem S j).Sat a) : leftBlock a ∈ S := by + classical + rw [forall_oneHotSystem_iff] at h + have hsum := (sat_oneHot_sum_iff S a).1 (h (Sum.inl ())) + obtain ⟨m₀, hm₀, hother⟩ := eq_basis_of_sum_one (rightBlock a) hsum + fun m m' hne => (sat_oneHot_pair_iff S a m m' hne).1 (h _) + have hmem : (candIdx k).symm m₀ ∈ S := by + by_contra hnot + have := (sat_oneHot_allowed_iff S a m₀ hnot).1 (h _) + rw [hm₀] at this + exact absurd this (by decide) + have hw : leftBlock a = (candIdx k).symm m₀ := by + funext i + have hc := (sat_oneHot_coord_iff S a i).1 (h _) + rw [Finset.sum_eq_single m₀ (fun m _ hm => by rw [hother m hm, zero_mul]) + (fun hn => absurd (Finset.mem_univ m₀) hn), hm₀, one_mul] at hc + rcases (by decide : ∀ u v : ZMod 2, u + v = 0 → u = v) _ _ hc with h' + exact h' + rw [hw] + exact hmem + +/-- The honest extension of an input: select its own candidate. -/ +noncomputable def oneHotExtend {k : ℕ} (w : Cube k) : Cube (k + 2 ^ k) := + Fin.append w (fun m => if m = candIdx k w then 1 else 0) + +theorem leftBlock_oneHotExtend {k : ℕ} (w : Cube k) : leftBlock (oneHotExtend w) = w := by + funext i + unfold leftBlock oneHotExtend + rw [Fin.append_left] + +theorem rightBlock_oneHotExtend {k : ℕ} (w : Cube k) (m : Fin (2 ^ k)) : + rightBlock (oneHotExtend w) m = if m = candIdx k w then 1 else 0 := by + unfold rightBlock oneHotExtend + rw [Fin.append_right] + +/-- **An input in the set satisfies the one-hot system**, once extended by its +own selector. -/ +theorem sat_oneHotSystem_extend {k : ℕ} (S : Finset (Cube k)) (w : Cube k) (hw : w ∈ S) : + ∀ j, (oneHotSystem S j).Sat (oneHotExtend w) := by + classical + rw [forall_oneHotSystem_iff] + intro x + rcases x with _ | ⟨⟨m, m'⟩ | m | i⟩ + · rw [sat_oneHot_sum_iff] + rw [Finset.sum_eq_single (candIdx k w) + (fun m _ hm => by rw [rightBlock_oneHotExtend, if_neg hm]) + (fun hn => absurd (Finset.mem_univ _) hn), rightBlock_oneHotExtend, if_pos rfl] + · by_cases hne : m = m' + · simp only [oneHotOf, if_pos hne] + exact QuadConstraint.sat_trivial _ + · rw [sat_oneHot_pair_iff S _ m m' hne, rightBlock_oneHotExtend, rightBlock_oneHotExtend] + by_cases hm : m = candIdx k w + · have hm' : m' ≠ candIdx k w := fun h => hne (hm.trans h.symm) + rw [if_neg hm', mul_zero] + · rw [if_neg hm, zero_mul] + · by_cases hm : (candIdx k).symm m ∈ S + · simp only [oneHotOf, if_pos hm] + exact QuadConstraint.sat_trivial _ + · rw [sat_oneHot_allowed_iff S _ m hm, rightBlock_oneHotExtend, if_neg] + intro hmw + apply hm + rw [hmw, Equiv.symm_apply_apply] + exact hw + · rw [sat_oneHot_coord_iff, leftBlock_oneHotExtend] + rw [Finset.sum_eq_single (candIdx k w) + (fun m _ hm => by rw [rightBlock_oneHotExtend, if_neg hm, zero_mul]) + (fun hn => absurd (Finset.mem_univ _) hn), rightBlock_oneHotExtend, if_pos rfl, + one_mul, Equiv.symm_apply_apply] + rcases (by decide : ∀ u : ZMod 2, u + u = 0) (w i) with h' + exact h' + +/-- **The one-hot system is satisfiable exactly on the set.** -/ +theorem exists_sat_oneHotSystem_iff {k : ℕ} (S : Finset (Cube k)) (w : Cube k) : + (∃ a : Cube (k + 2 ^ k), leftBlock a = w ∧ ∀ j, (oneHotSystem S j).Sat a) ↔ w ∈ S := by + constructor + · rintro ⟨a, ha, hsat⟩ + rw [← ha] + exact mem_of_sat_oneHotSystem S a hsat + · intro hw + exact ⟨oneHotExtend w, leftBlock_oneHotExtend w, sat_oneHotSystem_extend S w hw⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/BaseAlg.lean b/Complexitylib/Classes/PCP/Internal/BaseAlg.lean new file mode 100644 index 00000000..55a26c38 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/BaseAlg.lean @@ -0,0 +1,483 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CNFMaxVar +public import Complexitylib.Classes.PCP.Internal.GapReduction +public import Complexitylib.Classes.PCP.Internal.FiniteKey +public import Complexitylib.Classes.PCP.Internal.SymbolCodec +public import Complexitylib.Classes.PCP.Internal.CSPVerifier +public import Complexitylib.Classes.PCP.Internal.AlgCSPModel + +/-! +# The base graph, as an algorithm sees it + +The constraint graph of a 3CNF formula has three edges per clause, a vertex per +variable and a vertex per clause. This module computes those numbers and those +endpoints from the formula's encoding, in polynomial time. + +The vertex numbering puts variables first, so a clause vertex sits at +`maxVar + 1 + j`; both quantities are read off the encoding by the loops of +`MaxLoop` and the parser. + +## Main definitions + +- `Complexity.baseEdgesU` — the edge count, in unary +- `Complexity.baseMaxU` — the largest variable index, in unary + +## Main results + +- `Complexity.baseEdgesU_eq`, `Complexity.baseMaxU_eq` — what they compute +- `Complexity.baseTailU_eq`, `Complexity.baseHeadU_eq` — the two endpoints +- `Complexity.baseKey_mem_FP`, `Complexity.length_baseKey_le` — the constraint's + bounded key +- `Complexity.baseOk_mem_P` — the constraint is polynomial-time decidable +- `Complexity.baseAlg` — the base graph as an `AlgCSP` +- `Complexity.baseAlg_numEdges_eq`, `Complexity.baseAlg_tail_eq`, + `Complexity.baseAlg_head_eq` — it agrees with `baseCSP` +- `Complexity.card_gapAlpha` — the alphabet fits in `23` bits +- `Complexity.litSignFn_encode` — the sign flag is the literal's sign +- `Complexity.baseAlg_models` — the base graph is modelled faithfully +-/ + +@[expose] public section + +namespace Complexity + +open SAT ThreeSATCSP + +variable (E : List Bool → List Bool) + +/-- The number of edges, in unary: three per clause. -/ +noncomputable def baseEdgesU (z : List Bool) : List Bool := + clauseCountFn (E z) ++ clauseCountFn (E z) ++ clauseCountFn (E z) + +theorem baseEdgesU_mem_FP (hE : E ∈ FP) : baseEdgesU E ∈ FP := by + have hc : (fun z => clauseCountFn (E z)) ∈ FP := by + have := mem_FP_comp hE clauseCountFn_mem_FP + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply] + exact Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP hc hc) hc + +theorem baseEdgesU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) (x : List Bool) : + baseEdgesU E x = List.replicate (3 * (Φ x).length) true := by + rw [baseEdgesU, hE, clauseCountFn_eq (even_length_encode _), sepCount_encode] + rw [← List.replicate_add, ← List.replicate_add] + congr 1 + ring + +/-- The largest variable index, in unary. -/ +noncomputable def baseMaxU (z : List Bool) : List Bool := + maxFn slotVar (pair (baseEdgesU E z) (E z)) + +theorem baseMaxU_mem_FP (hE : E ∈ FP) : baseMaxU E ∈ FP := by + have hpair : (fun z => pair (baseEdgesU E z) (E z)) ∈ FP := + Cobham.pairFn_mem_FP (baseEdgesU_mem_FP E hE) hE + have := mem_FP_comp hpair (maxFn_mem_FP slotVar_mem_FP) + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply, baseMaxU] + +theorem baseMaxU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) : + (baseMaxU E x).length = (Φ x).maxVar := by + rw [baseMaxU, baseEdgesU_eq E hE, hE, maxFn_eq, maxOver_slotVar _ (h3 x)] + +/-- The unary form of the first endpoint: the clause vertex. -/ +noncomputable def baseTailU (w : List Bool) : List Bool := + baseMaxU E (Cobham.fstBlock w) ++ [true] + ++ List.replicate (divFn [false, false, false] (Cobham.sndBlock w)).length true + +/-- The unary form of the second endpoint: the variable vertex. -/ +noncomputable def baseHeadU (w : List Bool) : List Bool := + slotVar (pair (E (Cobham.fstBlock w)) (Cobham.sndBlock w)) + +theorem baseTailU_mem_FP (hE : E ∈ FP) : baseTailU E ∈ FP := by + have hm : (fun w => baseMaxU E (Cobham.fstBlock w)) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP (baseMaxU_mem_FP E hE) + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + have hd : (fun w : List Bool => + List.replicate (divFn [false, false, false] (Cobham.sndBlock w)).length true) ∈ FP := by + have h1 : (fun w : List Bool => divFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + have := mem_FP_comp Cobham.sndBlock_mem_FP (divFn_mem_FP [false, false, false]) + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + have := mem_FP_comp h1 unaryLength_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + exact Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP hm (constFn_mem_FP [true])) hd + +theorem baseHeadU_mem_FP (hE : E ∈ FP) : baseHeadU E ∈ FP := by + have hp : (fun w => pair (E (Cobham.fstBlock w)) (Cobham.sndBlock w)) ∈ FP := by + refine Cobham.pairFn_mem_FP ?_ Cobham.sndBlock_mem_FP + have := mem_FP_comp Cobham.fstBlock_mem_FP hE + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + have := mem_FP_comp hp slotVar_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply, baseHeadU] + +/-! ### What the endpoints compute -/ + +theorem baseTailU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) (e : ℕ) : + (baseTailU E (pair x (List.replicate e true))).length + = ((Φ x).maxVar + 1) + e / 3 := by + rw [baseTailU, Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_append, + List.length_append, List.length_replicate, List.length_singleton, + divFn_eq (by simp) (List.replicate e true), List.length_replicate, + List.length_replicate, baseMaxU_eq E hE h3] + congr 1 + +theorem baseHeadU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) {e : ℕ} (he : e < 3 * (Φ x).length) : + (baseHeadU E (pair x (List.replicate e true))).length + = (litOf (Φ x) (e / 3) ⟨e % 3, Nat.mod_lt _ (by omega)⟩).var := by + have hj : e / 3 < (Φ x).length := by omega + have hp : e % 3 < ((Φ x)[e / 3]'hj).length := by + rw [h3 x _ (List.getElem_mem hj)] + omega + rw [baseHeadU, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hE, + slotVar_eq (Φ x) hj hp rfl rfl] + congr 1 + rw [litOf, List.getElem?_eq_getElem hj] + simp only [Option.getD_some] + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hp] + rfl + +/-! ### The key the constraint looks at -/ + +/-- The three literal signs of the clause an edge belongs to. -/ +noncomputable def baseSigns (z : List Bool) : List Bool := + let j := divFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z)) + let x := Cobham.fstBlock (Cobham.fstBlock z) + litSignFn (pair (pair j []) (E x)) + ++ litSignFn (pair (pair j [true]) (E x)) + ++ litSignFn (pair (pair j [true, true]) (E x)) + +/-- Everything the constraint depends on: the clause's signs, the position +inside the clause, and the two symbol blocks. -/ +noncomputable def baseKey (w : ℕ) (z : List Bool) : List Bool := + pair (pair (baseSigns E z) + (modFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z)))) + ((Cobham.sndBlock z).take (2 * w)) + +theorem baseSigns_mem_FP (hE : E ∈ FP) : baseSigns E ∈ FP := by + have hx : (fun z : List Bool => E (Cobham.fstBlock (Cobham.fstBlock z))) ∈ FP := by + have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP) hE + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply, Function.comp_apply] + have hj : (fun z : List Bool => + divFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := by + have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) + (divFn_mem_FP [false, false, false]) + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply, Function.comp_apply] + have hsign : ∀ c : List Bool, (fun z : List Bool => + litSignFn (pair (pair (divFn [false, false, false] + (Cobham.sndBlock (Cobham.fstBlock z))) c) + (E (Cobham.fstBlock (Cobham.fstBlock z))))) ∈ FP := by + intro c + have := mem_FP_comp + (Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hj (constFn_mem_FP c)) hx) litSignFn_mem_FP + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply] + exact Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP (hsign []) (hsign [true])) + (hsign [true, true]) + +theorem baseKey_mem_FP (hE : E ∈ FP) (w : ℕ) : baseKey E w ∈ FP := by + have hm : (fun z : List Bool => + modFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := by + have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) + (modFn_mem_FP [false, false, false]) + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply, Function.comp_apply] + have ht : (fun z : List Bool => (Cobham.sndBlock z).take (2 * w)) ∈ FP := by + have := Cobham.takeLenFn_mem_FP + (constFn_mem_FP (List.replicate (2 * w) false)) Cobham.sndBlock_mem_FP + refine mem_FP_of_eq this fun z => ?_ + rw [List.length_replicate] + exact Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP (baseSigns_mem_FP E hE) hm) ht + +theorem length_baseSigns_le (z : List Bool) : (baseSigns E z).length ≤ 3 := by + have hs : ∀ y, (litSignFn y).length ≤ 1 := by + intro y + rw [litSignFn, Cobham.selectHead] + split + · simp + · split <;> simp + rw [baseSigns, List.length_append, List.length_append] + have h1 := hs (pair (pair (divFn [false, false, false] + (Cobham.sndBlock (Cobham.fstBlock z))) []) (E (Cobham.fstBlock (Cobham.fstBlock z)))) + have h2 := hs (pair (pair (divFn [false, false, false] + (Cobham.sndBlock (Cobham.fstBlock z))) [true]) (E (Cobham.fstBlock (Cobham.fstBlock z)))) + have h3 := hs (pair (pair (divFn [false, false, false] + (Cobham.sndBlock (Cobham.fstBlock z))) [true, true]) + (E (Cobham.fstBlock (Cobham.fstBlock z)))) + omega + +theorem length_baseKey_le (w : ℕ) (z : List Bool) : + (baseKey E w z).length ≤ 2 * w + 22 := by + have hs := length_baseSigns_le E z + have hm : (modFn [false, false, false] + (Cobham.sndBlock (Cobham.fstBlock z))).length ≤ 2 := by + rw [modFn_eq (by simp)] + simp only [List.length_replicate, + show ([false, false, false] : List Bool).length = 3 from rfl] + omega + have ht : ((Cobham.sndBlock z).take (2 * w)).length ≤ 2 * w := by + rw [List.length_take] + omega + rw [baseKey, pair_length, pair_length] + omega + +/-! ### The constraint -/ + +open Classical in +/-- What the constraint says, as a predicate of the key alone: the two blocks +name symbols in the image of the alphabet embedding whose preimages satisfy the +clause and agree on the checked position. -/ +noncomputable def baseOkKey (w : ℕ) (k : List Bool) : Prop := + ∃ a₁ a₂ : Fin 3 → Bool, + alphaEmb a₁ = symDec GapAlpha ((Cobham.sndBlock k).take w) ∧ + alphaEmb a₂ = symDec GapAlpha ((Cobham.sndBlock k).drop w) ∧ + (∃ q : Fin 3, a₁ q = (Cobham.fstBlock (Cobham.fstBlock k)).getD q.val false) ∧ + a₁ ⟨(Cobham.sndBlock (Cobham.fstBlock k)).length % 3, + Nat.mod_lt _ (by omega)⟩ = a₂ 0 + +/-- The constraint, as a language on the verifier's verdict argument. -/ +noncomputable def baseOk (w : ℕ) : Language := + {z : List Bool | baseOkKey w (baseKey E w z)} + +theorem baseOk_mem_P (hE : E ∈ FP) (w : ℕ) : baseOk E w ∈ P := + mem_P_of_bounded_key (baseKey_mem_FP E hE w) (length_baseKey_le E w) (baseOkKey w) + +/-! ### The record -/ + +/-- **The base graph as an algorithm.** -/ +noncomputable def baseAlg (hE : E ∈ FP) : AlgCSP where + numEdges x := (baseEdgesU E x).length + numEdges_mem := by + have := mem_FP_comp (baseEdgesU_mem_FP E hE) unaryLength_mem_FP + refine mem_FP_of_eq this fun x => ?_ + rw [Function.comp_apply] + width := 23 + width_pos := by omega + vert b x e := + cond b (baseHeadU E (pair x (List.replicate e true))).length + (baseTailU E (pair x (List.replicate e true))).length + vert_mem := by + intro b + have hu : (fun w : List Bool => List.replicate (Cobham.sndBlock w).length true) ∈ FP := by + have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + have harg : (fun w : List Bool => + pair (Cobham.fstBlock w) (List.replicate (Cobham.sndBlock w).length true)) ∈ FP := + Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP hu + cases b + · have := mem_FP_comp (mem_FP_comp harg (baseTailU_mem_FP E hE)) unaryLength_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply, Function.comp_apply] + simp only [cond_false] + · have := mem_FP_comp (mem_FP_comp harg (baseHeadU_mem_FP E hE)) unaryLength_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply, Function.comp_apply] + simp only [cond_true] + ok := baseOk E 23 + ok_mem := baseOk_mem_P E hE 23 + +@[simp] theorem numEdges_baseAlg (hE : E ∈ FP) (x : List Bool) : + (baseAlg E hE).numEdges x = (baseEdgesU E x).length := rfl + +@[simp] theorem width_baseAlg (hE : E ∈ FP) : (baseAlg E hE).width = 23 := rfl + +theorem vert_baseAlg_false (hE : E ∈ FP) (x : List Bool) (e : ℕ) : + (baseAlg E hE).vert false x e + = (baseTailU E (pair x (List.replicate e true))).length := by + simp only [baseAlg, cond_false] + +theorem vert_baseAlg_true (hE : E ∈ FP) (x : List Bool) (e : ℕ) : + (baseAlg E hE).vert true x e + = (baseHeadU E (pair x (List.replicate e true))).length := by + simp only [baseAlg, cond_true] + +@[simp] theorem ok_baseAlg (hE : E ∈ FP) : (baseAlg E hE).ok = baseOk E 23 := rfl + +/-! ### The symbol codec fits -/ + +theorem card_gapAlpha : Fintype.card GapAlpha = 2 ^ 23 := by + show Fintype.card (ZMod 2 × (ReadIdx → ZMod 2)) = 2 ^ 23 + rw [Fintype.card_prod, Fintype.card_fun, ZMod.card, card_readIdx] + norm_num + +theorem length_symEnc_gapAlpha (s : GapAlpha) : (symEnc GapAlpha 23 s).length = 23 := + length_symEnc 23 s + +theorem symDec_symEnc_gapAlpha (s : GapAlpha) : + symDec GapAlpha (symEnc GapAlpha 23 s) = s := + symDec_symEnc (by rw [card_gapAlpha]) s + +/-! ### The sign flag -/ + +theorem litSignFn_encode (φ : CNF) {j p : ℕ} (hj : j < φ.length) + (hp : p < (φ[j]'hj).length) : + litSignFn (pair (pair (List.replicate j true) (List.replicate p true)) φ.encode) + = [((φ[j]'hj)[p]'hp).sign] := by + have hseg : litSegFn (pair (pair (List.replicate j true) (List.replicate p true)) φ.encode) + = encodeTokens (Lit.rawTokens ((φ[j]'hj)[p]'hp)) := litSegFn_encode φ hj hp + have hhead : encodeTokens (Lit.rawTokens ((φ[j]'hj)[p]'hp)) + = ((φ[j]'hj)[p]'hp).sign :: ((φ[j]'hj)[p]'hp).sign + :: encodeTokens ((Lit.encodeRaw ((φ[j]'hj)[p]'hp)).tail.map EncToken.bit) := by + rw [Lit.rawTokens, Lit.encodeRaw] + simp only [List.map_cons, List.tail_cons] + rw [encodeTokens_cons] + cases h : ((φ[j]'hj)[p]'hp).sign <;> rfl + rw [litSignFn, hseg, hhead, selectHead_cons] + cases ((φ[j]'hj)[p]'hp).sign <;> simp + +theorem litOf_eq (φ : CNF) {j : ℕ} (hj : j < φ.length) (p : Fin 3) + (hq : p.val < (φ[j]'hj).length) : litOf φ j p = (φ[j]'hj)[p.val]'hq := by + rw [litOf, List.getElem?_eq_getElem hj] + simp only [Option.getD_some] + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hq] + rfl + +/-! ### Agreement with the real graph -/ + +variable {Φ : List Bool → CNF} + +theorem baseAlg_numEdges_eq (hE' : E ∈ FP) (hE : ∀ x, E x = (Φ x).encode) (x : List Bool) : + (baseAlg E hE').numEdges x = (baseCSP (Φ x)).numEdges := by + rw [numEdges_baseAlg, baseEdgesU_eq E hE, List.length_replicate, numEdges_baseCSP] + +theorem baseAlg_tail_eq (hE' : E ∈ FP) (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) (e : ℕ) + (he : e < (baseCSP (Φ x)).numEdges) : + (baseAlg E hE').vert false x e = ((baseCSP (Φ x)).tail ⟨e, he⟩).val := by + rw [numEdges_baseCSP] at he + rw [vert_baseAlg_false, baseTailU_eq E hE h3] + show _ = (clauseVertex (Φ x) (edgeClause e)).val + rw [clauseVertex, edgeClause, dif_pos (by rw [numVerts]; omega)] + +theorem baseAlg_head_eq (hE' : E ∈ FP) (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) (e : ℕ) + (he : e < (baseCSP (Φ x)).numEdges) : + (baseAlg E hE').vert true x e = ((baseCSP (Φ x)).head ⟨e, he⟩).val := by + rw [numEdges_baseCSP] at he + have hj : e / 3 < (Φ x).length := by omega + have hp : e % 3 < ((Φ x)[e / 3]'hj).length := by + rw [h3 x _ (List.getElem_mem hj)] + omega + have hlit : litOf (Φ x) (e / 3) ⟨e % 3, Nat.mod_lt _ (by omega)⟩ + = ((Φ x)[e / 3]'hj)[e % 3]'hp := by + rw [litOf, List.getElem?_eq_getElem hj] + simp only [Option.getD_some] + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hp] + rfl + have hvar : (litOf (Φ x) (e / 3) ⟨e % 3, Nat.mod_lt _ (by omega)⟩).var ≤ (Φ x).maxVar := by + rw [hlit] + exact var_le_maxVar (Φ x) hj hp + rw [vert_baseAlg_true, baseHeadU_eq E hE h3 x he] + show _ = (varVertex (Φ x) (litOf (Φ x) (edgeClause e) (edgePos e)).var).val + rw [varVertex, edgeClause, edgePos, dif_pos (by rw [numVerts]; omega)] + +/-! ### The key on a well-formed argument -/ + +theorem baseSigns_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) {e : ℕ} (he : e < 3 * (Φ x).length) (a : List Bool) : + baseSigns E (pair (pair x (List.replicate e true)) a) + = [(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, + (litOf (Φ x) (e / 3) 2).sign] := by + have hj : e / 3 < (Φ x).length := by omega + have hlen : ((Φ x)[e / 3]'hj).length = 3 := h3 x _ (List.getElem_mem hj) + have hsign : ∀ q : Fin 3, + litSignFn (pair (pair (List.replicate (e / 3) true) + (List.replicate q.val true)) (E x)) = [(litOf (Φ x) (e / 3) q).sign] := by + intro q + have hq : q.val < ((Φ x)[e / 3]'hj).length := by + rw [hlen] + exact q.isLt + rw [hE, litSignFn_encode (Φ x) hj hq, litOf_eq (Φ x) hj q hq] + rw [baseSigns, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + divFn_eq (by simp) (List.replicate e true), List.length_replicate, + show ([false, false, false] : List Bool).length = 3 from rfl] + have h0 : litSignFn (pair (pair (List.replicate (e / 3) true) []) (E x)) + = [(litOf (Φ x) (e / 3) 0).sign] := hsign 0 + have h1 : litSignFn (pair (pair (List.replicate (e / 3) true) [true]) (E x)) + = [(litOf (Φ x) (e / 3) 1).sign] := hsign 1 + have h2 : litSignFn (pair (pair (List.replicate (e / 3) true) [true, true]) (E x)) + = [(litOf (Φ x) (e / 3) 2).sign] := hsign 2 + rw [h0, h1, h2] + rfl + +theorem baseKey_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) + (x : List Bool) {e : ℕ} (he : e < 3 * (Φ x).length) {a : List Bool} + (ha : a.length = 46) : + baseKey E 23 (pair (pair x (List.replicate e true)) a) + = pair (pair [(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, + (litOf (Φ x) (e / 3) 2).sign] (List.replicate (e % 3) true)) a := by + rw [baseKey, baseSigns_pair E hE h3 x he a, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + Cobham.sndBlock_pair, modFn_eq (by simp) (List.replicate e true), + List.length_replicate, show ([false, false, false] : List Bool).length = 3 from rfl, + List.take_of_length_le (by omega)] + +/-! ### The constraint agrees -/ + +set_option maxRecDepth 8000 in +theorem baseAlg_ok_iff (hE' : E ∈ FP) (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) (e : ℕ) + (he : e < (baseCSP (Φ x)).numEdges) (u v : List Bool) + (hu : u.length = 23) (hv : v.length = 23) : + pair (pair x (List.replicate e true)) (u ++ v) ∈ (baseAlg E hE').ok + ↔ (baseCSP (Φ x)).rel ⟨e, he⟩ (symDec GapAlpha u) (symDec GapAlpha v) = true := by + have he' : e < 3 * (Φ x).length := by + rw [numEdges_baseCSP] at he + exact he + have ha : (u ++ v).length = 46 := by + rw [List.length_append, hu, hv] + have htake : (u ++ v).take 23 = u := by + rw [← hu, List.take_left] + have hdrop : (u ++ v).drop 23 = v := by + rw [← hu, List.drop_left] + have hmod : e % 3 % 3 = e % 3 := by omega + show baseOkKey 23 (baseKey E 23 (pair (pair x (List.replicate e true)) (u ++ v))) ↔ _ + rw [baseKey_pair E hE h3 x he' ha] + show _ ↔ (ConstraintGraph.lift (toGraph (Φ x)) alphaEmb).rel ⟨e, he⟩ _ _ = true + rw [ConstraintGraph.rel_lift, decide_eq_true_iff] + simp only [baseOkKey, Cobham.sndBlock_pair, Cobham.fstBlock_pair, htake, hdrop, + List.length_replicate, hmod] + have hsign : ∀ q : Fin 3, + ([(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, + (litOf (Φ x) (e / 3) 2).sign].getD q.val false) = (litOf (Φ x) (e / 3) q).sign := by + intro q + fin_cases q <;> rfl + have hpos : edgePos e = ⟨e % 3, Nat.mod_lt _ (by omega)⟩ := rfl + + constructor + · rintro ⟨a₁, a₂, h1, h2, ⟨q, hq⟩, hagree⟩ + refine ⟨a₁, a₂, h1, h2, ?_⟩ + show (clauseSat (Φ x) (edgeClause e) a₁ && (a₁ (edgePos e) == a₂ 0)) = true + rw [Bool.and_eq_true, clauseSat_eq_true_iff, beq_iff_eq, hpos] + exact ⟨⟨q, by rw [hq, hsign, edgeClause]⟩, hagree⟩ + · rintro ⟨a₁, a₂, h1, h2, hr⟩ + replace hr : (clauseSat (Φ x) (edgeClause e) a₁ && (a₁ (edgePos e) == a₂ 0)) = true := hr + rw [Bool.and_eq_true, clauseSat_eq_true_iff, beq_iff_eq, hpos] at hr + obtain ⟨⟨q, hq⟩, hagree⟩ := hr + exact ⟨a₁, a₂, h1, h2, ⟨q, by rw [hq, hsign, edgeClause]⟩, hagree⟩ + +/-- **The base graph is modelled faithfully.** -/ +theorem baseAlg_models (hE' : E ∈ FP) (hE : ∀ x, E x = (Φ x).encode) + (h3 : ∀ x, CNF.Is3CNF (Φ x)) : + (baseAlg E hE').Models (fun x => baseCSP (Φ x)) (symEnc GapAlpha 23) + (symDec GapAlpha) where + numEdges_eq := baseAlg_numEdges_eq E hE' hE + tail_eq := baseAlg_tail_eq E hE' hE h3 + head_eq := baseAlg_head_eq E hE' hE h3 + length_enc := length_symEnc_gapAlpha + dec_enc := symDec_symEnc_gapAlpha + ok_iff := fun x e he u v hu hv => baseAlg_ok_iff E hE' hE h3 x e he u v hu hv + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/BinToUnary.lean b/Complexitylib/Classes/PCP/Internal/BinToUnary.lean new file mode 100644 index 00000000..c7bb9105 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/BinToUnary.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CoinEnum + +/-! +# Counting out the value of a bit string + +A verifier turns its coins into an index — into a list of edges, say — and an +index has to be counted out in unary before a polynomial-time loop can use it. +This module does that: it reads a bit string as a little-endian binary number +and writes that many marks. + +The conversion is only polynomial time when the value is, which is why the +result is clamped: the fold's state is truncated to a width the caller supplies. +On strings short enough for the clamp — logarithmically many coins, say — the +answer is exact. + +## Main definitions + +- `Complexity.unaryVal` — the value of a bit string, in unary + +## Main results + +- `Complexity.unaryVal_eq` — it is exact when the clamp is wide enough +- `Complexity.unaryVal_mem_FP` — it is polynomial time +-/ + +@[expose] public section + +namespace Complexity + +/-- Reading a zero: the value doubles. -/ +def binDbl (z : List Bool) : List Bool := + Cobham.sndBlock (Cobham.fstBlock z) ++ Cobham.sndBlock (Cobham.fstBlock z) + +/-- Reading a one: the value doubles and gains one. -/ +def binDblOne (z : List Bool) : List Bool := + Cobham.sndBlock (Cobham.fstBlock z) ++ Cobham.sndBlock (Cobham.fstBlock z) ++ [true] + +theorem binDbl_mem_FP : binDbl ∈ FP := by + have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact Cobham.appendFn_mem_FP h h + +theorem binDblOne_mem_FP : binDblOne ∈ FP := by + have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP h h) (constFn_mem_FP [true]) + +/-- **The value of a bit string, in unary**, computed on `pair anything bits`. -/ +def unaryVal (p : Polynomial ℕ) (z : List Bool) : List Bool := + Cobham.recFoldClamp binDbl binDblOne (p.eval z.length) [] (Cobham.fstBlock z) + (Cobham.sndBlock z) + +theorem unaryVal_mem_FP (p : Polynomial ℕ) : unaryVal p ∈ FP := + Cobham.recFoldClamp_mem_FP binDbl_mem_FP binDblOne_mem_FP (constFn_mem_FP []) p + +theorem binValLE_cons_false (l : List Bool) : binValLE (false :: l) = 2 * binValLE l := by + rw [binValLE]; simp + +theorem binValLE_cons_true (l : List Bool) : + binValLE (true :: l) = 2 * binValLE l + 1 := by + rw [binValLE]; simp; omega + +/-- The fold really counts out the value, as long as the clamp is wide enough. -/ +theorem recFoldClamp_binValLE (bound : ℕ) (W : List Bool) : + ∀ l : List Bool, 2 ^ l.length ≤ bound → + Cobham.recFoldClamp binDbl binDblOne bound [] W l + = List.replicate (binValLE l) true := by + intro l + induction l with + | nil => + intro _ + rw [Cobham.recFoldClamp] + simp [binValLE] + | cons b l ih => + intro hb + have hb' : 2 ^ l.length ≤ bound := by + have : 2 ^ l.length ≤ 2 ^ (b :: l).length := + Nat.pow_le_pow_right (by omega) (by simp) + omega + have hval : binValLE l < 2 ^ l.length := binValLE_lt l + have hlen : 2 ^ (l.length + 1) ≤ bound := by + have : (b :: l).length = l.length + 1 := by simp + omega + have hpow : 2 ^ (l.length + 1) = 2 ^ l.length + 2 ^ l.length := by + rw [pow_succ]; ring + rw [Cobham.recFoldClamp, ih hb'] + have hstate : Cobham.sndBlock (Cobham.fstBlock + (pair (pair W (List.replicate (binValLE l) true)) l)) + = List.replicate (binValLE l) true := by + rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + cases b with + | false => + show (binDbl _).take bound = _ + rw [binDbl, hstate, binValLE_cons_false, two_mul, ← List.replicate_add] + refine List.take_of_length_le ?_ + rw [List.length_replicate] + omega + | true => + show (binDblOne _).take bound = _ + rw [binDblOne, hstate, binValLE_cons_true, two_mul, + show List.replicate (binValLE l) true ++ List.replicate (binValLE l) true ++ [true] + = List.replicate (binValLE l + binValLE l + 1) true from by + rw [List.replicate_add, List.replicate_add] + rfl] + refine List.take_of_length_le ?_ + rw [List.length_replicate] + omega + +/-- **The conversion is exact** when the clamp is wide enough for the value. -/ +theorem unaryVal_eq {p : Polynomial ℕ} {z : List Bool} + (h : 2 ^ (Cobham.sndBlock z).length ≤ p.eval z.length) : + unaryVal p z = List.replicate (binValLE (Cobham.sndBlock z)) true := + recFoldClamp_binValLE _ _ _ h + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean b/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean new file mode 100644 index 00000000..41f64222 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal +public import Complexitylib.Classes.P.UnaryLength +public import Complexitylib.Classes.P.PairWithInput +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.Containments.Internal.FPBridge +public import Complexitylib.Classes.Containments.Internal.PVerdict + +/-! +# Computing an output one bit at a time + +A polynomial-time function is usually easiest to describe not as a string +transformation but as a rule for each output bit: "the `i`-th bit of `f x` is +whatever this decision procedure says". This module turns such a description +into `f ∈ FP`. + +The two inputs are a unary length function — how long the output is, given in +unary so that it is itself a plausible `FP` output — and a bit oracle, a +polynomial-time function reading `pair x (unary i)` and returning the single +bit. The construction is an iteration of an append-one-bit step, run once per +output position, and `iterate_mem_FP` supplies the closure of `FP` under such +iterations. + +This is the bridge that lets a decision procedure written on the RAM surface +(where `RAM_P_eq_P` transfers it to `P`) be used to build a *function* in `FP`, +for which no direct RAM bridge exists. + +## Main definitions + +- `Complexity.bitStep` — the append-one-bit step + +## Main results + +- `Complexity.bitwise_mem_FP` — a bitwise description puts the function in `FP` +- `Complexity.bitwise_mem_FP_of_mem_P` — the same with the bit rule given as a + language in `P`, which is the form the RAM surface produces +-/ + +@[expose] public section + +namespace Complexity + +open Cobham + +/-- One step of the construction: consult the oracle at the current output +length and append the bit it returns. The state is `pair (output so far) input`. +-/ +def bitStep (G : List Bool → List Bool) (z : List Bool) : List Bool := + pair (fstBlock z ++ G (pair (sndBlock z) (List.replicate (fstBlock z).length true))) + (sndBlock z) + +theorem bitStep_mem_FP {G : List Bool → List Bool} (hG : G ∈ FP) : bitStep G ∈ FP := by + have hfst : (fun z : List Bool => fstBlock z) ∈ FP := fstBlock_mem_FP + have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := sndBlock_mem_FP + have hcnt : (fun z : List Bool => List.replicate (fstBlock z).length true) ∈ FP := by + have := mem_FP_comp hfst unaryLength_mem_FP + simpa [Function.comp] using this + have hquery : (fun z : List Bool => + G (pair (sndBlock z) (List.replicate (fstBlock z).length true))) ∈ FP := by + have := mem_FP_comp (pairFn_mem_FP hsnd hcnt) hG + simpa [Function.comp] using this + exact pairFn_mem_FP (appendFn_mem_FP hfst hquery) hsnd + +/-- Running the step from the empty output builds the first `n` bits. -/ +theorem bitStep_iterate {G : List Bool → List Bool} {b : List Bool → ℕ → Bool} + (hGspec : ∀ x i, G (pair x (List.replicate i true)) = [b x i]) (x : List Bool) : + ∀ n : ℕ, (bitStep G)^[n] (pair [] x) = pair ((List.range n).map (b x)) x := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply', ih, bitStep, fstBlock_pair, sndBlock_pair, + List.length_map, List.length_range, hGspec, List.range_succ, List.map_append] + simp + +/-- **A function described bit by bit is polynomial time.** If the output length +is computable in unary and each output bit is computable from the input and the +position in unary, the function itself is in `FP`. -/ +theorem bitwise_mem_FP {len : List Bool → ℕ} {b : List Bool → ℕ → Bool} + (hlen : (fun x => List.replicate (len x) true) ∈ FP) + {G : List Bool → List Bool} (hG : G ∈ FP) + (hGspec : ∀ x i, G (pair x (List.replicate i true)) = [b x i]) : + (fun x => (List.range (len x)).map (b x)) ∈ FP := by + have hinit : (fun x : List Bool => pair [] x) ∈ FP := + mem_FP_pairWithInput (constFn_mem_FP []) + have hwidth : (fun x : List Bool => pair (List.replicate (len x) true) x) ∈ FP := + mem_FP_pairWithInput hlen + have hbound : ∀ z : List Bool, ∀ n ≤ (List.replicate (len z) true).length, + ((bitStep G)^[n] (pair [] z)).length + ≤ (pair (List.replicate (len z) true) z).length := by + intro z n hn + rw [List.length_replicate] at hn + rw [bitStep_iterate hGspec, pair_length, pair_length, List.length_map, + List.length_range, List.length_replicate] + omega + have hiter := iterate_mem_FP (bitStep_mem_FP hG) hinit hlen hwidth hbound + have := mem_FP_comp hiter fstBlock_mem_FP + refine mem_FP_of_eq this ?_ + intro x + rw [Function.comp_apply, List.length_replicate, bitStep_iterate hGspec, fstBlock_pair] + +/-- **The same, from a language in `P`.** The bit rule is usually established as +a decision problem — "does position `i` of the output carry a one?" — and this +is the form in which `RAM_P_eq_P` delivers it. -/ +theorem bitwise_mem_FP_of_mem_P {len : List Bool → ℕ} {b : List Bool → ℕ → Bool} + (hlen : (fun x => List.replicate (len x) true) ∈ FP) + {L : Language} (hL : L ∈ P) + (hLspec : ∀ x i, pair x (List.replicate i true) ∈ L ↔ b x i = true) : + (fun x => (List.range (len x)).map (b x)) ∈ FP := by + obtain ⟨g, hgFP, hg⟩ := exists_decisionFn_of_mem_P hL + refine bitwise_mem_FP hlen hgFP ?_ + intro x i + have : g (pair x (List.replicate i true)) = b x i := by + have h1 := (hg (pair x (List.replicate i true))).symm.trans (hLspec x i) + cases hb : b x i <;> cases hgv : g (pair x (List.replicate i true)) <;> + simp [hb, hgv] at h1 ⊢ + rw [this] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/BoundNotConstructible.lean b/Complexitylib/Classes/PCP/Internal/BoundNotConstructible.lean new file mode 100644 index 00000000..e39d0a9e --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/BoundNotConstructible.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Defs +public import Complexitylib.Classes.PCP.Internal.LengthMod + +/-! +# The randomness bound has to be constructible + +`Complexitylib.Classes.PCP` defines `PCP r q` for an arbitrary pair of functions +`r q : ℕ → ℕ`, with no requirement that either be computable. That makes the +union over all `r =O Nat.log 2` far too large to be `NP`, and this module shows +it: for *every* set `A ⊆ ℕ`, the language of inputs whose length lies in `A` +belongs to the union. + +One fixed verifier does it for all `A` at once. It queries nothing, so its +transcript is `pair (pair x ρ) []`, of length `4|x| + 2|ρ| + 6`; accepting when +that is divisible by four means accepting exactly when `|ρ| = 1`. Feeding it one +coin when `|x| ∈ A` and none otherwise makes it accept certainly on `A` and +never off it. The bound `r` used to do that is the indicator of `A`, which is +`O(1)` and so certainly `O(log n)` — but it is as uncomputable as `A` is. + +Since `NP` is countable and there are `2^𝔠` sets `A`, the union cannot equal +`NP`: the `⊆ NP` half of the statement is false as written. The remedy is the +usual one, to require the bounds to be constructible; the `NP ⊆ PCP` half — the +Dinur half — is untouched. + +## Main definitions + +- `Complexity.coinLenVerifier` — the verifier that only counts its coins + +## Main results + +- `Complexity.lengthLang_mem_iUnion_PCP` — every length-determined language, + computable or not, is in the union +-/ + +@[expose] public section + +namespace Complexity + +/-- A verifier that reads nothing and accepts exactly when it was given one +coin. -/ +def coinLenVerifier : PCPVerifier where + positions := fun _ _ => [] + positions_mem := + ⟨fun _ => DataEncode.bitstringEncode ([] : List ℕ), constFn_mem_FP _, fun _ _ => rfl⟩ + verdict := lenMod4 + verdict_mem := lenMod4_mem_P + +@[simp] theorem positions_coinLenVerifier (x r : List Bool) : + coinLenVerifier.positions x r = [] := rfl + +theorem length_delimit (w : List Bool) : (delimit w).length = 2 * w.length + 2 := by + rw [delimit, List.length_append, List.length_flatMap] + simp [Nat.mul_comm] + +theorem length_transcript (x ρ : List Bool) : + (pair (pair x ρ) []).length = 4 * x.length + 2 * ρ.length + 6 := by + rw [pair, List.append_nil, length_delimit, pair, List.length_append, length_delimit] + ring + +/-- **The verifier accepts exactly on one coin.** -/ +theorem accepts_coinLenVerifier_iff (x π ρ : List Bool) : + coinLenVerifier.Accepts x π ρ ↔ (2 * ρ.length + 2) % 4 = 0 := by + rw [PCPVerifier.Accepts, positions_coinLenVerifier] + show pair (pair x ρ) [] ∈ lenMod4 ↔ _ + rw [lenMod4] + show (pair (pair x ρ) []).length % 4 = 0 ↔ _ + rw [length_transcript] + constructor + · intro h; omega + · intro h; omega + +theorem accepts_of_length_one {x π ρ : List Bool} (h : ρ.length = 1) : + coinLenVerifier.Accepts x π ρ := by + rw [accepts_coinLenVerifier_iff, h] + +theorem not_accepts_of_length_zero {x π ρ : List Bool} (h : ρ.length = 0) : + ¬ coinLenVerifier.Accepts x π ρ := by + rw [accepts_coinLenVerifier_iff, h] + decide + +/-! ### Every length-determined language is in the union -/ + +open Classical in +/-- The indicator of `A`, used as a randomness bound. -/ +noncomputable def indicatorBound (A : Set ℕ) : ℕ → ℕ := fun n => if n ∈ A then 1 else 0 + +theorem indicatorBound_le_one (A : Set ℕ) (n : ℕ) : indicatorBound A n ≤ 1 := by + rw [indicatorBound] + split <;> norm_num + +theorem indicatorBound_bigO (A : Set ℕ) : indicatorBound A =O Nat.log 2 := by + rw [BigO] + refine Asymptotics.IsBigO.of_bound 1 ?_ + filter_upwards [Filter.eventually_ge_atTop 2] with n hn + have hlog : 1 ≤ Nat.log 2 n := Nat.log_pos (by norm_num) hn + have h1 : (indicatorBound A n : ℝ) ≤ 1 := by + exact_mod_cast indicatorBound_le_one A n + have h2 : (1 : ℝ) ≤ (Nat.log 2 n : ℝ) := by exact_mod_cast hlog + rw [Real.norm_natCast, Real.norm_natCast, one_mul] + linarith + +/-- **The union of `PCP` classes contains every length-determined language.** +Since `A` is arbitrary it may be uncomputable, so the union is not contained in +`NP`. -/ +theorem lengthLang_mem_iUnion_PCP (A : Set ℕ) : + {x : List Bool | x.length ∈ A} ∈ + ⋃ (r : ℕ → ℕ) (_ : r =O Nat.log 2) (q : ℕ → ℕ) (_ : q =O fun _ => 1), PCP r q := by + classical + refine Set.mem_iUnion.2 ⟨indicatorBound A, Set.mem_iUnion.2 ⟨indicatorBound_bigO A, + Set.mem_iUnion.2 ⟨fun _ => 0, Set.mem_iUnion.2 ⟨?_, ?_⟩⟩⟩⟩ + · rw [BigO] + refine Asymptotics.IsBigO.of_bound 1 ?_ + filter_upwards with n + norm_num + refine ⟨coinLenVerifier, fun x r => by simp, ?_, ?_⟩ + · intro x hx + refine ⟨[], ?_⟩ + have hxA : x.length ∈ A := hx + have hr : indicatorBound A x.length = 1 := by + rw [indicatorBound] + exact if_pos hxA + rw [hr] + have huniv : coinLenVerifier.acceptEvent 1 x [] = Finset.univ := by + refine Finset.eq_univ_iff_forall.2 fun ρ => ?_ + rw [PCPVerifier.acceptEvent, Finset.mem_filter] + exact ⟨Finset.mem_univ _, accepts_of_length_one (by simp)⟩ + rw [huniv, eventProb, Finset.card_univ, card_finArrowBool] + norm_num + · intro x hx π + have hxA : x.length ∉ A := hx + have hr : indicatorBound A x.length = 0 := by + rw [indicatorBound] + exact if_neg hxA + rw [hr] + have hempty : coinLenVerifier.acceptEvent 0 x π = ∅ := by + refine Finset.eq_empty_iff_forall_notMem.2 fun ρ hρ => ?_ + rw [PCPVerifier.acceptEvent, Finset.mem_filter] at hρ + exact not_accepts_of_length_zero (by simp) hρ.2 + rw [hempty, eventProb] + norm_num + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/BoundedQuant.lean b/Complexitylib/Classes/PCP/Internal/BoundedQuant.lean new file mode 100644 index 00000000..8955569d --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/BoundedQuant.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.BitwiseFP +public import Complexitylib.Classes.Containments + +/-! +# Checking polynomially many conditions + +An algorithm that has to verify a condition at every one of polynomially many +places is a loop, and a loop of polynomial length is still polynomial time. This +module states that as closure of `P` under quantification over an index bounded +by a polynomial-time unary length function. + +The proof reuses the bit-by-bit construction: run the condition at each index, +collect the verdicts into a string, and compare it against the all-ones string +of the same length. The comparison is what turns a list of verdicts into a +single one, and it costs nothing beyond the string equality test already in the +toolkit. + +## Main results + +- `Complexity.forall_unary_mem_P` — a bounded conjunction of `P` conditions +- `Complexity.exists_unary_mem_P` — a bounded disjunction of `P` conditions +-/ + +@[expose] public section + +namespace Complexity + +/-- **A bounded conjunction of polynomial-time conditions is polynomial time.** +The index runs over `0, …, len x - 1` and is passed to the condition in unary. -/ +theorem forall_unary_mem_P {L : Language} (hL : L ∈ P) {len : List Bool → ℕ} + (hlen : (fun x => List.replicate (len x) true) ∈ FP) : + {x : List Bool | ∀ i < len x, pair x (List.replicate i true) ∈ L} ∈ P := by + obtain ⟨g, hgFP, hg⟩ := exists_decisionFn_of_mem_P hL + have hmap : (fun x => (List.range (len x)).map + (fun i => g (pair x (List.replicate i true)))) ∈ FP := + bitwise_mem_FP hlen hgFP fun _ _ => rfl + refine mem_P_of_decisionFn (eqFlagFn_mem_FP hmap hlen) fun x => ?_ + simp only [Set.mem_setOf_eq] + set a := (List.range (len x)).map (fun i => g (pair x (List.replicate i true))) with ha + set b := List.replicate (len x) true with hb + have hiff : a = b ↔ ∀ i < len x, pair x (List.replicate i true) ∈ L := by + rw [ha, hb, List.eq_replicate_iff] + constructor + · rintro ⟨-, hall⟩ i hi + refine (hg _).2 (hall _ ?_) + exact List.mem_map.2 ⟨i, List.mem_range.2 hi, rfl⟩ + · intro hall + refine ⟨by simp, ?_⟩ + rintro c hc + obtain ⟨i, hi, rfl⟩ := List.mem_map.1 hc + exact (hg _).1 (hall i (List.mem_range.1 hi)) + rw [← hiff] + constructor + · intro hab + rw [(Cobham.eqFlag_eq_true_iff a b).mpr hab] + exact ⟨true, by simp, rfl⟩ + · rintro ⟨c, hc, rfl⟩ + rcases Cobham.eqFlag_flag a b with h | h + · exact (Cobham.eqFlag_eq_true_iff a b).mp h + · rw [h] at hc + simp at hc + +/-- **A bounded disjunction of polynomial-time conditions is polynomial time.** -/ +theorem exists_unary_mem_P {L : Language} (hL : L ∈ P) {len : List Bool → ℕ} + (hlen : (fun x => List.replicate (len x) true) ∈ FP) : + {x : List Bool | ∃ i < len x, pair x (List.replicate i true) ∈ L} ∈ P := by + have hall := forall_unary_mem_P (P_compl hL) hlen + have heq : {x : List Bool | ∃ i < len x, pair x (List.replicate i true) ∈ L} + = {x : List Bool | ∀ i < len x, pair x (List.replicate i true) ∈ Lᶜ}ᶜ := by + ext x + constructor + · rintro ⟨i, hi, hmem⟩ hall + exact (hall i hi) hmem + · intro h + by_contra hc + exact h fun i hi hmem => hc ⟨i, hi, hmem⟩ + rw [heq] + exact P_compl hall + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CNFCount.lean b/Complexitylib/Classes/PCP/Internal/CNFCount.lean new file mode 100644 index 00000000..715319a3 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CNFCount.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.UnaryDivMod +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble + +/-! +# Counting the clauses of an encoded formula + +A formula's encoding is a stream of two-bit tokens, one of which marks the end +of a clause. Counting those tokens counts the clauses, and an algorithm that has +to loop over the clauses needs that count in unary. + +The scan consumes two bits per step, so it is an iteration rather than a fold: +the state is the count so far paired with the unread suffix. + +## Main definitions + +- `Complexity.sepCount` — how many clause markers a bit string carries +- `Complexity.ccStep` — one two-bit step + +## Main results + +- `Complexity.ccStep_iterate` — the scan counts +- `Complexity.clauseCountFn_mem_FP`, `Complexity.clauseCountFn_eq` — counting is + polynomial time +-/ + +@[expose] public section + +namespace Complexity + +/-- How many clause markers — the token `10` — a bit string carries. -/ +def sepCount : List Bool → ℕ + | true :: false :: r => sepCount r + 1 + | _ :: _ :: r => sepCount r + | _ => 0 + +@[simp] theorem sepCount_nil : sepCount [] = 0 := rfl + +theorem sepCount_cons₂ (b0 b1 : Bool) (r : List Bool) : + sepCount (b0 :: b1 :: r) = if b0 = true ∧ b1 = false then sepCount r + 1 else sepCount r := by + cases b0 <;> cases b1 <;> simp [sepCount] + +theorem selectHead_cons (b : Bool) (t x y : List Bool) : + Cobham.selectHead (b :: t) x y = if b then x else y := by + cases b <;> simp [Cobham.selectHead] + +/-- One step: read the next token, and count it if it marks a clause. The state +is `pair count unread`. -/ +def ccStep (z : List Bool) : List Bool := + pair + (Cobham.selectHead (emptyFlag (Cobham.sndBlock z)) (Cobham.fstBlock z) + (Cobham.selectHead (Cobham.sndBlock z) + (Cobham.selectHead (dropOne (Cobham.sndBlock z)) (Cobham.fstBlock z) + (true :: Cobham.fstBlock z)) + (Cobham.fstBlock z))) + (dropOne (dropOne (Cobham.sndBlock z))) + +theorem ccStep_mem_FP : ccStep ∈ FP := by + have hc : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hs : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hd : (fun z : List Bool => dropOne (Cobham.sndBlock z)) ∈ FP := dropOneFn_mem_FP hs + refine Cobham.pairFn_mem_FP ?_ (dropOneFn_mem_FP hd) + refine Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hs) hc ?_ + exact Cobham.selectHeadFn_mem_FP hs + (Cobham.selectHeadFn_mem_FP hd hc (mem_FP_comp hc (Cobham.cons_mem_FP true))) hc + +@[simp] theorem ccStep_nil (c : List Bool) : ccStep (pair c []) = pair c [] := by + rw [ccStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair, emptyFlag_nil, + selectHead_cons_true] + rfl + +theorem ccStep_cons₂ (c : List Bool) (b0 b1 : Bool) (r : List Bool) : + ccStep (pair c (b0 :: b1 :: r)) + = pair (if b0 = true ∧ b1 = false then true :: c else c) r := by + rw [ccStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair, emptyFlag_cons, + selectHead_cons_false] + cases b0 + · rw [selectHead_cons] + simp [dropOne] + · cases b1 + · rw [selectHead_cons] + simp only [dropOne, List.drop_succ_cons, List.drop_zero, if_pos] + rw [selectHead_cons] + simp + · rw [selectHead_cons] + simp only [dropOne, List.drop_succ_cons, List.drop_zero, if_pos] + rw [selectHead_cons] + simp + +theorem replicate_true_append_cons (n : ℕ) (c : List Bool) : + List.replicate n true ++ true :: c = true :: (List.replicate n true ++ c) := by + induction n with + | zero => simp + | succ n ih => simp only [List.replicate_succ, List.cons_append, ih] + +/-- **The scan counts.** -/ +theorem ccStep_iterate : ∀ (k : ℕ) (c s : List Bool), s.length ≤ 2 * k → Even s.length → + ccStep^[k] (pair c s) = pair (List.replicate (sepCount s) true ++ c) [] := by + intro k + induction k with + | zero => + intro c s hs _ + have : s = [] := List.eq_nil_of_length_eq_zero (by omega) + subst this + simp + | succ k ih => + intro c s hs hev + rw [Function.iterate_succ_apply] + match s with + | [] => rw [ccStep_nil, ih c [] (by simp) (by simp)] + | [b] => exact absurd hev (by simp [Nat.even_add_one]) + | b0 :: b1 :: r => + rw [ccStep_cons₂] + have hr : r.length ≤ 2 * k := by + simp only [List.length_cons] at hs + omega + have hrev : Even r.length := by + simp only [List.length_cons] at hev + rcases hev with ⟨m, hm⟩ + exact ⟨m - 1, by omega⟩ + rw [ih _ r hr hrev, sepCount_cons₂] + by_cases hcase : b0 = true ∧ b1 = false + · rw [if_pos hcase, if_pos hcase, List.replicate_succ, + List.cons_append, ← replicate_true_append_cons] + · rw [if_neg hcase, if_neg hcase] + +/-! ### The scan as one function -/ + +theorem length_selectHead_le (s x y : List Bool) : + (Cobham.selectHead s x y).length ≤ max x.length y.length := by + rw [Cobham.selectHead] + split + · exact le_max_left _ _ + · split + · exact le_max_right _ _ + · simp + +theorem ccStep_one (c s : List Bool) : + ∃ X Y, ccStep (pair c s) = pair X Y + ∧ X.length ≤ c.length + 1 ∧ Y.length ≤ s.length := by + rw [ccStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + refine ⟨_, _, rfl, ?_, ?_⟩ + · refine le_trans (length_selectHead_le _ _ _) ?_ + simp only [max_le_iff] + refine ⟨by omega, ?_⟩ + refine le_trans (length_selectHead_le _ _ _) ?_ + simp only [max_le_iff] + refine ⟨?_, by omega⟩ + refine le_trans (length_selectHead_le _ _ _) ?_ + simp + · rw [dropOne, dropOne, List.length_drop, List.length_drop] + omega + +theorem ccStep_shape : ∀ (k : ℕ) (c s : List Bool), + ∃ c' s', ccStep^[k] (pair c s) = pair c' s' + ∧ c'.length ≤ c.length + k ∧ s'.length ≤ s.length := by + intro k + induction k with + | zero => intro c s; exact ⟨c, s, rfl, by omega, le_refl _⟩ + | succ k ih => + intro c s + rw [Function.iterate_succ_apply] + obtain ⟨X, Y, hXY, hX, hY⟩ := ccStep_one c s + rw [hXY] + obtain ⟨c', s', h1, h2, h3⟩ := ih X Y + exact ⟨c', s', h1, by omega, by omega⟩ + +/-- **The clause count**, in unary. -/ +noncomputable def clauseCountFn (z : List Bool) : List Bool := + Cobham.fstBlock (ccStep^[z.length] (pair [] z)) + +theorem clauseCountFn_mem_FP : clauseCountFn ∈ FP := by + have hinit : (fun z : List Bool => pair [] z) ∈ FP := + mem_FP_pairWithInput (constFn_mem_FP []) + have hwidth : (fun z : List Bool => polyRuler (Polynomial.C 3 * Polynomial.X + + Polynomial.C 2) (id z)) ∈ FP := + polyRulerFn_mem_FP _ id_mem_FP + have hbound : ∀ z : List Bool, ∀ k ≤ z.length, + (ccStep^[k] (pair [] z)).length + ≤ (polyRuler (Polynomial.C 3 * Polynomial.X + Polynomial.C 2) (id z)).length := by + intro z k hk + obtain ⟨c', s', h1, h2, h3⟩ := ccStep_shape k [] z + rw [h1, pair_length, polyRuler_length] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, id] + simp only [List.length_nil, Nat.zero_add] at h2 + omega + have hiter := Cobham.iterate_mem_FP ccStep_mem_FP hinit id_mem_FP hwidth hbound + have := mem_FP_comp hiter Cobham.fstBlock_mem_FP + simpa [Function.comp, clauseCountFn] using this + +theorem clauseCountFn_eq {z : List Bool} (h : Even z.length) : + clauseCountFn z = List.replicate (sepCount z) true := by + rw [clauseCountFn, ccStep_iterate z.length [] z (by omega) h, Cobham.fstBlock_pair] + simp + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean b/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean new file mode 100644 index 00000000..3107dbdc --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CNFTokens +public import Complexitylib.SAT.ThreeCNF +public import Complexitylib.Classes.PCP.Internal.MaxLoop + +/-! +# The largest variable index, by slot + +`CNF.maxVar` folds over clauses and then over literals. An algorithm instead +loops over a flat slot index and takes the largest value it sees. The two are +the same number, and this module says why: each bounds the family of variable +indices and each is attained by it. + +## Main results + +- `Complexity.var_le_maxVar` — every literal's index is at most `maxVar` +- `Complexity.exists_slot_eq_maxVar` — and some literal attains it +- `Complexity.maxOver_slotVar` — the loop computes `maxVar` +-/ + +@[expose] public section + +namespace Complexity + +open SAT + +theorem clause_maxVar_le : ∀ (φ : CNF) {c : Clause}, c ∈ φ → c.maxVar ≤ φ.maxVar := by + intro φ + induction φ with + | nil => intro c hc; simp at hc + | cons c' cs ih => + intro c hc + rw [CNF.maxVar] + rcases List.mem_cons.mp hc with h | h + · rw [h] + exact le_max_left _ _ + · exact le_trans (ih h) (le_max_right _ _) + +/-- Every literal's index is at most the formula's largest. -/ +theorem var_le_maxVar (φ : CNF) {j : ℕ} (hj : j < φ.length) {p : ℕ} + (hp : p < (φ[j]'hj).length) : ((φ[j]'hj)[p]'hp).var ≤ φ.maxVar := + le_trans (Clause.var_le_maxVar (List.getElem_mem hp)) + (clause_maxVar_le φ (List.getElem_mem hj)) + +/-- Some literal of a nonempty clause attains its largest index. -/ +theorem exists_lit_eq_maxVar : ∀ (c : Clause), 0 < c.length → + ∃ p, ∃ hp : p < c.length, ((c[p]'hp).var) = c.maxVar := by + intro c + induction c with + | nil => intro h; simp at h + | cons l ls ih => + intro _ + rcases Nat.eq_zero_or_pos ls.length with hz | hpos + · have hnil : ls = [] := List.eq_nil_of_length_eq_zero hz + subst hnil + exact ⟨0, by simp, by simp⟩ + · obtain ⟨p, hp, hval⟩ := ih hpos + rcases Nat.lt_or_ge (Clause.maxVar ls) l.var with h | h + · refine ⟨0, by simp, ?_⟩ + rw [Clause.maxVar_cons, max_eq_left (le_of_lt h)] + simp + · refine ⟨p + 1, by simp; omega, ?_⟩ + rw [Clause.maxVar_cons, max_eq_right h, ← hval] + simp + +/-- Some clause of a nonempty formula attains its largest index. -/ +theorem exists_clause_eq_maxVar : ∀ (φ : CNF), 0 < φ.length → + ∃ j, ∃ hj : j < φ.length, (φ[j]'hj).maxVar = φ.maxVar := by + intro φ + induction φ with + | nil => intro h; simp at h + | cons c cs ih => + intro _ + rcases Nat.eq_zero_or_pos cs.length with hz | hpos + · have hnil : cs = [] := List.eq_nil_of_length_eq_zero hz + subst hnil + exact ⟨0, by simp, by simp [CNF.maxVar]⟩ + · obtain ⟨j, hj, hval⟩ := ih hpos + rcases Nat.lt_or_ge (CNF.maxVar cs) c.maxVar with h | h + · refine ⟨0, by simp, ?_⟩ + rw [CNF.maxVar, max_eq_left (le_of_lt h)] + simp + · refine ⟨j + 1, by simp; omega, ?_⟩ + rw [CNF.maxVar, max_eq_right h, ← hval] + simp + +/-- **Some literal attains the formula's largest index.** -/ +theorem exists_slot_eq_maxVar (φ : CNF) (h3 : CNF.Is3CNF φ) (h : 0 < φ.length) : + ∃ j, ∃ hj : j < φ.length, ∃ p, ∃ hp : p < (φ[j]'hj).length, + ((φ[j]'hj)[p]'hp).var = φ.maxVar := by + obtain ⟨j, hj, hval⟩ := exists_clause_eq_maxVar φ h + have hlen : (φ[j]'hj).length = 3 := h3 _ (List.getElem_mem hj) + obtain ⟨p, hp, hval'⟩ := exists_lit_eq_maxVar (φ[j]'hj) (by omega) + exact ⟨j, hj, p, hp, by rw [hval', hval]⟩ + +/-! ### The loop computes `maxVar` -/ + +/-- The variable index at a flat slot, read off the encoding. -/ +noncomputable def slotVar (w : List Bool) : List Bool := + litVarFn (pair (pair (divFn [false, false, false] (Cobham.sndBlock w)) + (modFn [false, false, false] (Cobham.sndBlock w))) (Cobham.fstBlock w)) + +theorem slotVar_mem_FP : slotVar ∈ FP := by + have hs : (fun w : List Bool => Cobham.sndBlock w) ∈ FP := Cobham.sndBlock_mem_FP + have hf : (fun w : List Bool => Cobham.fstBlock w) ∈ FP := Cobham.fstBlock_mem_FP + have hd : (fun w : List Bool => divFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + have := mem_FP_comp hs (divFn_mem_FP [false, false, false]) + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + have hm : (fun w : List Bool => modFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + have := mem_FP_comp hs (modFn_mem_FP [false, false, false]) + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply] + have := mem_FP_comp (Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hd hm) hf) litVarFn_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply, slotVar] + +theorem slotVar_eq (φ : CNF) {i j p : ℕ} (hj : j < φ.length) (hp : p < (φ[j]'hj).length) + (hdj : i / 3 = j) (hdp : i % 3 = p) : + (slotVar (pair φ.encode (List.replicate i true))).length = ((φ[j]'hj)[p]'hp).var := by + rw [slotVar, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + divFn_eq (by simp) (List.replicate i true), modFn_eq (by simp) (List.replicate i true)] + simp only [List.length_replicate, + show ([false, false, false] : List Bool).length = 3 from rfl, hdj, hdp] + rw [litVarFn_encode φ hj hp, List.length_replicate] + +/-- **The loop computes `maxVar`.** -/ +theorem maxOver_slotVar (φ : CNF) (h3 : CNF.Is3CNF φ) : + maxOver slotVar φ.encode (3 * φ.length) = φ.maxVar := by + rcases Nat.eq_zero_or_pos φ.length with hz | hpos + · have hnil : φ = [] := List.eq_nil_of_length_eq_zero hz + subst hnil + simp [maxOver] + · refine Nat.le_antisymm ?_ ?_ + · refine maxOver_le _ fun i hi => ?_ + have hj : i / 3 < φ.length := by omega + have hp : i % 3 < (φ[i / 3]'hj).length := by + rw [h3 _ (List.getElem_mem hj)] + omega + rw [slotVar_eq φ hj hp rfl rfl] + exact var_le_maxVar φ _ _ + · obtain ⟨j, hj, p, hp, hval⟩ := exists_slot_eq_maxVar φ h3 hpos + have hp3 : p < 3 := by + rw [h3 _ (List.getElem_mem hj)] at hp + exact hp + have hi : 3 * j + p < 3 * φ.length := by omega + have hdiv : (3 * j + p) / 3 = j := by omega + have hmod : (3 * j + p) % 3 = p := by omega + have hstep := le_maxOver (f := slotVar) (z := φ.encode) (3 * φ.length) (3 * j + p) hi + rw [slotVar_eq φ hj hp hdiv hmod] at hstep + rw [← hval] + exact hstep + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CNFSegment.lean b/Complexitylib/Classes/PCP/Internal/CNFSegment.lean new file mode 100644 index 00000000..3b0f1970 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CNFSegment.lean @@ -0,0 +1,407 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CNFCount +public import Complexitylib.Classes.PCP.Internal.PositionsFP + +/-! +# Cutting out one clause of an encoded formula + +Reading the `j`-th clause of an encoded formula is the same two-bit scan that +counts the clauses, with two additions: a target index to compare against, and a +buffer that collects tokens while the count matches. + +The state is `pair (pair target count) (pair collected unread)`. + +## Main definitions + +- `Complexity.segStep` — one two-bit step of the extraction +- `Complexity.segFrom` — the tokens of one segment + +## Main results + +- `Complexity.segStep_mem_FP` — the extraction is polynomial time +- `Complexity.segAtFn_mem_FP`, `Complexity.segAtFn_eq` — the packaged + extraction +- `Complexity.litSegFn_eq` — the `p`-th literal of the `j`-th clause +- `Complexity.litVarFn_eq`, `Complexity.litSignFn_eq` — its variable and sign +-/ + +@[expose] public section + +namespace Complexity + +/-- The tokens of the segment with index `t`, having already passed `c` +separators, where the separator is the token `s0 s1`. -/ +def segFrom (s0 s1 : Bool) (t c : ℕ) : List Bool → List Bool + | b0 :: b1 :: r => + if b0 = s0 ∧ b1 = s1 then segFrom s0 s1 t (c + 1) r + else if c = t then b0 :: b1 :: segFrom s0 s1 t c r else segFrom s0 s1 t c r + | _ => [] + +@[simp] theorem segFrom_nil (s0 s1 : Bool) (t c : ℕ) : segFrom s0 s1 t c [] = [] := rfl + +theorem segFrom_cons₂ (s0 s1 : Bool) (t c : ℕ) (b0 b1 : Bool) (r : List Bool) : + segFrom s0 s1 t c (b0 :: b1 :: r) + = if b0 = s0 ∧ b1 = s1 then segFrom s0 s1 t (c + 1) r + else if c = t then b0 :: b1 :: segFrom s0 s1 t c r else segFrom s0 s1 t c r := rfl + +/-- The target index carried by the state. -/ +def segTgt (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock z) + +/-- The number of separators already passed. -/ +def segCnt (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock z) + +/-- The tokens collected so far. -/ +def segColl (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.sndBlock z) + +/-- The unread suffix. -/ +def segRest (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.sndBlock z) + +/-- Does the string begin with the bit `b`, as a flag? -/ +def matchBit (b : Bool) (s : List Bool) : List Bool := + if b then Cobham.selectHead s [true] [false] else Cobham.selectHead s [false] [true] + +theorem matchBit_mem_FP (b : Bool) {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => matchBit b (a z)) ∈ FP := by + cases b + · exact Cobham.selectHeadFn_mem_FP ha (constFn_mem_FP [false]) (constFn_mem_FP [true]) + · exact Cobham.selectHeadFn_mem_FP ha (constFn_mem_FP [true]) (constFn_mem_FP [false]) + +theorem matchBit_cons (b c : Bool) (t : List Bool) : + matchBit b (c :: t) = if c = b then [true] else [false] := by + cases b <;> cases c <;> simp [matchBit, selectHead_cons] + +/-- Is this token the separator? -/ +def segIsSep (s0 s1 : Bool) (z : List Bool) : List Bool := + andBit (matchBit s0 (segRest z)) (matchBit s1 (dropOne (segRest z))) + +/-- Are we inside the segment we want? -/ +def segHere (z : List Bool) : List Bool := + Cobham.lenEqFlag (segCnt z) (segTgt z) + +/-- One two-bit step of the extraction. -/ +def segStep (s0 s1 : Bool) (z : List Bool) : List Bool := + Cobham.selectHead (emptyFlag (segRest z)) z + (pair + (pair (segTgt z) + (Cobham.selectHead (segIsSep s0 s1 z) (true :: segCnt z) (segCnt z))) + (pair + (Cobham.selectHead (segIsSep s0 s1 z) (segColl z) + (Cobham.selectHead (segHere z) + (segColl z ++ (segRest z).take 2) (segColl z))) + (dropOne (dropOne (segRest z))))) + +theorem segTgt_mem_FP : segTgt ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +theorem segCnt_mem_FP : segCnt ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + +theorem segColl_mem_FP : segColl ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP + +theorem segRest_mem_FP : segRest ∈ FP := + mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP + +theorem segIsSep_mem_FP (s0 s1 : Bool) : segIsSep s0 s1 ∈ FP := + andBitFn_mem_FP (matchBit_mem_FP s0 segRest_mem_FP) + (matchBit_mem_FP s1 (dropOneFn_mem_FP segRest_mem_FP)) + +theorem segHere_mem_FP : segHere ∈ FP := + andBitFn_mem_FP (lenLeFlagFn_mem_FP segCnt_mem_FP segTgt_mem_FP) + (lenLeFlagFn_mem_FP segTgt_mem_FP segCnt_mem_FP) + +theorem segStep_mem_FP (s0 s1 : Bool) : segStep s0 s1 ∈ FP := by + have htake : (fun z : List Bool => (segRest z).take 2) ∈ FP := by + have := Cobham.takeLenFn_mem_FP (constFn_mem_FP [false, false]) segRest_mem_FP + refine mem_FP_of_eq this fun z => ?_ + rfl + refine Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP segRest_mem_FP) id_mem_FP ?_ + refine Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP segTgt_mem_FP ?_) + (Cobham.pairFn_mem_FP ?_ (dropOneFn_mem_FP (dropOneFn_mem_FP segRest_mem_FP))) + · exact Cobham.selectHeadFn_mem_FP (segIsSep_mem_FP s0 s1) + (mem_FP_comp segCnt_mem_FP (Cobham.cons_mem_FP true)) segCnt_mem_FP + · refine Cobham.selectHeadFn_mem_FP (segIsSep_mem_FP s0 s1) segColl_mem_FP ?_ + exact Cobham.selectHeadFn_mem_FP segHere_mem_FP + (Cobham.appendFn_mem_FP segColl_mem_FP htake) segColl_mem_FP + +/-! ### What the scan collects -/ + +variable (s0 s1 : Bool) + +@[simp] theorem segStep_nil (tgt cnt coll : List Bool) : + segStep s0 s1 (pair (pair tgt cnt) (pair coll [])) = pair (pair tgt cnt) (pair coll []) := by + have hr : segRest (pair (pair tgt cnt) (pair coll [])) = [] := by + rw [segRest, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + rw [segStep, hr, emptyFlag_nil, selectHead_cons_true] + +theorem segStep_cons₂ (tgt cnt coll : List Bool) (b0 b1 : Bool) (r : List Bool) : + segStep s0 s1 (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) + = if b0 = s0 ∧ b1 = s1 then + pair (pair tgt (true :: cnt)) (pair coll r) + else pair (pair tgt cnt) + (pair (if cnt.length = tgt.length then coll ++ [b0, b1] else coll) r) := by + have hr : segRest (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = b0 :: b1 :: r := by + rw [segRest, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + have ht : segTgt (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = tgt := by + rw [segTgt, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + have hc : segCnt (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = cnt := by + rw [segCnt, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hl : segColl (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = coll := by + rw [segColl, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + have hsep : segIsSep s0 s1 (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) + = if b0 = s0 ∧ b1 = s1 then [true] else [false] := by + rw [segIsSep, hr] + simp only [dropOne, List.drop_succ_cons, List.drop_zero] + rw [matchBit_cons, matchBit_cons] + by_cases h0 : b0 = s0 <;> by_cases h1 : b1 = s1 <;> simp [h0, h1, andBit] + have hhere : segHere (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) + = if cnt.length = tgt.length then [true] else [false] := by + rw [segHere, hc, ht] + by_cases h : cnt.length = tgt.length + · rw [if_pos h, Cobham.lenEqFlag_eq_true_iff] + exact h + · rw [if_neg h] + rcases Cobham.lenEqFlag_flag cnt tgt with hf | hf + · rw [Cobham.lenEqFlag_eq_true_iff] at hf + exact absurd hf h + · exact hf + rw [segStep, hr, hsep, hhere, ht, hc, hl, emptyFlag_cons, selectHead_cons_false] + by_cases hcase : b0 = s0 ∧ b1 = s1 + · rw [if_pos hcase, if_pos hcase, selectHead_cons_true, selectHead_cons_true] + simp [dropOne] + · rw [if_neg hcase, if_neg hcase, selectHead_cons_false, selectHead_cons_false] + by_cases hh : cnt.length = tgt.length + · rw [if_pos hh, if_pos hh, selectHead_cons_true] + simp [dropOne] + · rw [if_neg hh, if_neg hh, selectHead_cons_false] + simp [dropOne] + +/-- **The scan collects the segment.** -/ +theorem segStep_iterate : ∀ (k : ℕ) (tgt cnt coll s : List Bool), + s.length ≤ 2 * k → Even s.length → + segColl ((segStep s0 s1)^[k] (pair (pair tgt cnt) (pair coll s))) + = coll ++ segFrom s0 s1 tgt.length cnt.length s := by + intro k + induction k with + | zero => + intro tgt cnt coll s hs _ + have : s = [] := List.eq_nil_of_length_eq_zero (by omega) + subst this + rw [Function.iterate_zero_apply, segColl, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + simp + | succ k ih => + intro tgt cnt coll s hs hev + rw [Function.iterate_succ_apply] + match s with + | [] => rw [segStep_nil, ih tgt cnt coll [] (by simp) (by simp)] + | [b] => exact absurd hev (by simp [Nat.even_add_one]) + | b0 :: b1 :: r => + have hr : r.length ≤ 2 * k := by + simp only [List.length_cons] at hs + omega + have hrev : Even r.length := by + simp only [List.length_cons] at hev + rcases hev with ⟨m, hm⟩ + exact ⟨m - 1, by omega⟩ + rw [segStep_cons₂, segFrom_cons₂] + by_cases hcase : b0 = s0 ∧ b1 = s1 + · rw [if_pos hcase, if_pos hcase, ih tgt (true :: cnt) coll r hr hrev] + simp + · rw [if_neg hcase, if_neg hcase] + by_cases hh : cnt.length = tgt.length + · rw [if_pos hh, if_pos hh, ih tgt cnt _ r hr hrev] + simp + · rw [if_neg hh, if_neg hh, ih tgt cnt coll r hr hrev] + +theorem even_length_segFrom (s0 s1 : Bool) (t : ℕ) : + ∀ (n : ℕ) (s : List Bool) (c : ℕ), s.length ≤ n → Even s.length → + Even (segFrom s0 s1 t c s).length := by + intro n + induction n with + | zero => + intro s c hs _ + have : s = [] := List.eq_nil_of_length_eq_zero (by omega) + subst this + simp + | succ n ih => + intro s c hs hev + match s with + | [] => simp + | [b] => exact absurd hev (by simp [Nat.even_add_one]) + | b0 :: b1 :: r => + rw [segFrom_cons₂] + have hr : r.length ≤ n := by + simp only [List.length_cons] at hs + omega + have hrev : Even r.length := by + simp only [List.length_cons] at hev + rcases hev with ⟨m, hm⟩ + exact ⟨m - 1, by omega⟩ + by_cases hcase : b0 = s0 ∧ b1 = s1 + · rw [if_pos hcase] + exact ih r (c + 1) hr hrev + · rw [if_neg hcase] + by_cases hh : c = t + · rw [if_pos hh] + simp only [List.length_cons] + rcases ih r c hr hrev with ⟨m, hm⟩ + exact ⟨m + 1, by omega⟩ + · rw [if_neg hh] + exact ih r c hr hrev + +/-! ### The scan as one function -/ + +theorem segStep_one (tgt cnt coll s : List Bool) : + ∃ cnt' coll' s', segStep s0 s1 (pair (pair tgt cnt) (pair coll s)) + = pair (pair tgt cnt') (pair coll' s') + ∧ cnt'.length ≤ cnt.length + 1 ∧ coll'.length ≤ coll.length + 2 + ∧ s'.length ≤ s.length := by + have hr : segRest (pair (pair tgt cnt) (pair coll s)) = s := by + rw [segRest, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + have ht : segTgt (pair (pair tgt cnt) (pair coll s)) = tgt := by + rw [segTgt, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + have hc : segCnt (pair (pair tgt cnt) (pair coll s)) = cnt := by + rw [segCnt, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hl : segColl (pair (pair tgt cnt) (pair coll s)) = coll := by + rw [segColl, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + match s with + | [] => + exact ⟨cnt, coll, [], segStep_nil s0 s1 tgt cnt coll, by omega, by omega, le_refl _⟩ + | b :: t => + rw [segStep, hr, emptyFlag_cons, selectHead_cons_false, ht, hc, hl] + refine ⟨_, _, _, rfl, ?_, ?_, ?_⟩ + · refine le_trans (length_selectHead_le _ _ _) ?_ + simp + · refine le_trans (length_selectHead_le _ _ _) ?_ + simp only [max_le_iff] + refine ⟨by omega, ?_⟩ + refine le_trans (length_selectHead_le _ _ _) ?_ + simp only [max_le_iff] + refine ⟨?_, by omega⟩ + rw [List.length_append] + have h2 : ((b :: t).take 2).length ≤ 2 := by + rw [List.length_take] + omega + omega + · rw [dropOne, dropOne, List.length_drop, List.length_drop] + omega + +theorem segStep_shape : ∀ (k : ℕ) (tgt cnt coll s : List Bool), + ∃ cnt' coll' s', (segStep s0 s1)^[k] (pair (pair tgt cnt) (pair coll s)) + = pair (pair tgt cnt') (pair coll' s') + ∧ cnt'.length ≤ cnt.length + k ∧ coll'.length ≤ coll.length + 2 * k + ∧ s'.length ≤ s.length := by + intro k + induction k with + | zero => intro tgt cnt coll s; exact ⟨cnt, coll, s, rfl, by omega, by omega, le_refl _⟩ + | succ k ih => + intro tgt cnt coll s + rw [Function.iterate_succ_apply] + obtain ⟨cnt₁, coll₁, s₁, h1, hc1, hl1, hs1⟩ := segStep_one s0 s1 tgt cnt coll s + rw [h1] + obtain ⟨cnt', coll', s', h2, hc2, hl2, hs2⟩ := ih tgt cnt₁ coll₁ s₁ + exact ⟨cnt', coll', s', h2, by omega, by omega, by omega⟩ + +/-- **The packaged extraction**, on `pair (unary index) encoding`. -/ +noncomputable def segAtFn (s0 s1 : Bool) (z : List Bool) : List Bool := + segColl ((segStep s0 s1)^[(Cobham.sndBlock z).length] + (pair (pair (Cobham.fstBlock z) []) (pair [] (Cobham.sndBlock z)))) + +theorem segAtFn_mem_FP : segAtFn s0 s1 ∈ FP := by + have hf : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hs : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hinit : (fun z : List Bool => + pair (pair (Cobham.fstBlock z) []) (pair [] (Cobham.sndBlock z))) ∈ FP := + Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hf (constFn_mem_FP [])) + (Cobham.pairFn_mem_FP (constFn_mem_FP []) hs) + have hwidth : (fun z : List Bool => polyRuler (Polynomial.C 11 * Polynomial.X + + Polynomial.C 8) (id z)) ∈ FP := polyRulerFn_mem_FP _ id_mem_FP + have hbound : ∀ z : List Bool, ∀ k ≤ (Cobham.sndBlock z).length, + ((segStep s0 s1)^[k] + (pair (pair (Cobham.fstBlock z) []) (pair [] (Cobham.sndBlock z)))).length + ≤ (polyRuler (Polynomial.C 11 * Polynomial.X + Polynomial.C 8) (id z)).length := by + intro z k hk + obtain ⟨cnt', coll', s', h1, hc, hl, hss⟩ := + segStep_shape s0 s1 k (Cobham.fstBlock z) [] [] (Cobham.sndBlock z) + have hfz : (Cobham.fstBlock z).length ≤ z.length := fstBlock_length_le z + have hsz : (Cobham.sndBlock z).length ≤ z.length := sndBlock_length_le z + rw [h1, pair_length, pair_length, pair_length, polyRuler_length] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * + omega + have hiter := Cobham.iterate_mem_FP (segStep_mem_FP s0 s1) hinit hs hwidth hbound + have := mem_FP_comp hiter segColl_mem_FP + simpa [Function.comp, segAtFn] using this + +theorem segAtFn_eq {j : ℕ} {e : List Bool} (h : Even e.length) : + segAtFn s0 s1 (pair (List.replicate j true) e) = segFrom s0 s1 j 0 e := by + rw [segAtFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + segStep_iterate s0 s1 e.length _ _ _ e (by omega) h, List.length_replicate, + List.length_nil] + simp + +/-! ### Down to a literal -/ + +/-- **The `p`-th literal of the `j`-th clause**, on +`pair (pair (unary j) (unary p)) encoding`. -/ +noncomputable def litSegFn (z : List Bool) : List Bool := + segAtFn false true + (pair (Cobham.sndBlock (Cobham.fstBlock z)) + (segAtFn true false (pair (Cobham.fstBlock (Cobham.fstBlock z)) (Cobham.sndBlock z)))) + +theorem litSegFn_mem_FP : litSegFn ∈ FP := by + have hj : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hp : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have he : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hcl : (fun z : List Bool => segAtFn true false + (pair (Cobham.fstBlock (Cobham.fstBlock z)) (Cobham.sndBlock z))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP hj he) (segAtFn_mem_FP true false) + simpa [Function.comp] using this + have := mem_FP_comp (Cobham.pairFn_mem_FP hp hcl) (segAtFn_mem_FP false true) + simpa [Function.comp, litSegFn] using this + +theorem litSegFn_eq {j p : ℕ} {e : List Bool} (h : Even e.length) : + litSegFn (pair (pair (List.replicate j true) (List.replicate p true)) e) + = segFrom false true p 0 (segFrom true false j 0 e) := by + rw [litSegFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, segAtFn_eq true false h, + segAtFn_eq false true (even_length_segFrom true false j e.length e 0 (le_refl _) h)] + +/-- The variable a literal names, in unary. -/ +noncomputable def litVarFn (z : List Bool) : List Bool := halfFn ((litSegFn z).drop 2) + +theorem litVarFn_mem_FP : litVarFn ∈ FP := by + have hdrop : (fun z : List Bool => (litSegFn z).drop 2) ∈ FP := by + have := dropLenFn_mem_FP (constFn_mem_FP [false, false]) litSegFn_mem_FP + refine mem_FP_of_eq this fun z => ?_ + rfl + have := mem_FP_comp hdrop halfFn_mem_FP + simpa [Function.comp, litVarFn] using this + +theorem litVarFn_eq {j p : ℕ} {e : List Bool} (h : Even e.length) : + litVarFn (pair (pair (List.replicate j true) (List.replicate p true)) e) + = List.replicate + (((segFrom false true p 0 (segFrom true false j 0 e)).length - 2) / 2) true := by + rw [litVarFn, litSegFn_eq h, halfFn_eq, List.length_drop] + +/-- The sign a literal carries, as a flag. -/ +noncomputable def litSignFn (z : List Bool) : List Bool := + Cobham.selectHead (litSegFn z) [true] [false] + +theorem litSignFn_mem_FP : litSignFn ∈ FP := + Cobham.selectHeadFn_mem_FP litSegFn_mem_FP (constFn_mem_FP [true]) (constFn_mem_FP [false]) + +theorem litSignFn_eq {j p : ℕ} {e : List Bool} (h : Even e.length) : + litSignFn (pair (pair (List.replicate j true) (List.replicate p true)) e) + = Cobham.selectHead (segFrom false true p 0 (segFrom true false j 0 e)) + [true] [false] := by + rw [litSignFn, litSegFn_eq h] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CNFTokens.lean b/Complexitylib/Classes/PCP/Internal/CNFTokens.lean new file mode 100644 index 00000000..ce178b35 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CNFTokens.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CNFCount +public import Complexitylib.Classes.PCP.Internal.CNFSegment +public import Complexitylib.SAT.Verifier + +/-! +# The scan agrees with the encoding + +The clause counter reads two bits at a time and counts the token `10`. This +module checks that against the encoding it is meant to read: every token +occupies two bits, only the clause separator is `10`, and a formula's encoding +carries one separator per clause. + +Because tokens are two bits wide and the scan steps two bits at a time, a `10` +pattern straddling two tokens is never seen. + +## Main results + +- `Complexity.sepCount_encodeTokens` — the scan counts separators +- `Complexity.sepCount_encode` — a formula's encoding has one per clause +- `Complexity.segFrom_tokenJoin` — the extraction returns one segment +- `Complexity.litSegFn_encode` — the packaged extraction returns one literal +- `Complexity.litVarFn_encode` — and its variable index +-/ + +@[expose] public section + +namespace Complexity + +open SAT + +theorem length_encode_token (t : EncToken) : t.encode.length = 2 := by + cases t with + | bit b => cases b <;> rfl + | litSep => rfl + | clauseSep => rfl + +/-- **The scan counts separators.** -/ +theorem sepCount_encodeTokens : ∀ toks : List EncToken, + sepCount (encodeTokens toks) + = (toks.filter (fun t => t = EncToken.clauseSep)).length := by + intro toks + induction toks with + | nil => rfl + | cons t ts ih => + rw [encodeTokens_cons, List.filter_cons] + cases t + case bit b => + cases b + · show sepCount ([false, false] ++ encodeTokens ts) = _ + rw [show ([false, false] ++ encodeTokens ts) + = false :: false :: encodeTokens ts from rfl, sepCount_cons₂, if_neg (by simp)] + simp [ih] + · show sepCount ([true, true] ++ encodeTokens ts) = _ + rw [show ([true, true] ++ encodeTokens ts) + = true :: true :: encodeTokens ts from rfl, sepCount_cons₂, if_neg (by simp)] + simp [ih] + case litSep => + show sepCount ([false, true] ++ encodeTokens ts) = _ + rw [show ([false, true] ++ encodeTokens ts) + = false :: true :: encodeTokens ts from rfl, sepCount_cons₂, if_neg (by simp)] + simp [ih] + case clauseSep => + show sepCount ([true, false] ++ encodeTokens ts) = _ + rw [show ([true, false] ++ encodeTokens ts) + = true :: false :: encodeTokens ts from rfl, sepCount_cons₂, if_pos (by simp)] + simp [ih] + +theorem clause_tokens_no_sep (c : Clause) : + (Clause.tokens c).filter (fun t => t = EncToken.clauseSep) = [] := by + induction c with + | nil => rfl + | cons l ls ih => + rw [Clause.tokens, List.filter_append, List.filter_append, ih] + have hraw : (Lit.rawTokens l).filter (fun t => t = EncToken.clauseSep) = [] := by + rw [Lit.rawTokens, List.filter_map] + simp [Function.comp] + rw [hraw] + rfl + +/-- **A formula's encoding has one separator per clause.** -/ +theorem sepCount_encode (φ : CNF) : sepCount φ.encode = φ.length := by + rw [← CNF.encodeTokens_tokens, sepCount_encodeTokens] + induction φ with + | nil => rfl + | cons c cs ih => + rw [CNF.tokens, List.filter_append, List.filter_append, List.length_append, + List.length_append, clause_tokens_no_sep, ih] + simp + omega + +/-! ### The extraction returns one clause -/ + +theorem hne_clauseSep : ∀ t : EncToken, t ≠ EncToken.clauseSep → + ∃ c0 c1, t.encode = [c0, c1] ∧ ¬(c0 = true ∧ c1 = false) := by + intro t h + cases t with + | bit b => + cases b + · exact ⟨false, false, rfl, by simp⟩ + · exact ⟨true, true, rfl, by simp⟩ + | litSep => exact ⟨false, true, rfl, by simp⟩ + | clauseSep => exact absurd rfl h + +theorem hne_litSep : ∀ t : EncToken, t ≠ EncToken.litSep → + ∃ c0 c1, t.encode = [c0, c1] ∧ ¬(c0 = false ∧ c1 = true) := by + intro t h + cases t with + | bit b => + cases b + · exact ⟨false, false, rfl, by simp⟩ + · exact ⟨true, true, rfl, by simp⟩ + | litSep => exact absurd rfl h + | clauseSep => exact ⟨true, false, rfl, by simp⟩ + +/-- Reading past a run of non-separator tokens collects them, or not, according +to whether the count matches. -/ +theorem segFrom_encodeTokens_noSep {sep : EncToken} {b0 b1 : Bool} + (hne : ∀ t : EncToken, t ≠ sep → ∃ c0 c1, t.encode = [c0, c1] ∧ ¬(c0 = b0 ∧ c1 = b1)) : + ∀ (toks : List EncToken), (∀ t ∈ toks, t ≠ sep) → ∀ (v : List Bool) (t c : ℕ), + segFrom b0 b1 t c (encodeTokens toks ++ v) + = (if c = t then encodeTokens toks else []) ++ segFrom b0 b1 t c v := by + intro toks + induction toks with + | nil => intro _ v t c; by_cases h : c = t <;> simp [h] + | cons tk ts ih => + intro hall v t c + obtain ⟨c0, c1, henc, hnec⟩ := hne tk (hall tk (by simp)) + rw [encodeTokens_cons, henc, List.append_assoc, + show ([c0, c1] ++ (encodeTokens ts ++ v)) = c0 :: c1 :: (encodeTokens ts ++ v) from rfl, + segFrom_cons₂, if_neg hnec, ih (fun t' ht' => hall t' (by simp [ht'])) v t c] + by_cases h : c = t + · rw [if_pos h, if_pos h, if_pos h] + rfl + · rw [if_neg h, if_neg h, if_neg h] + +theorem segFrom_of_gt (s0 s1 : Bool) : ∀ (n : ℕ) (s : List Bool) (t c : ℕ), + s.length ≤ n → t < c → segFrom s0 s1 t c s = [] := by + intro n + induction n with + | zero => + intro s t c hs _ + have : s = [] := List.eq_nil_of_length_eq_zero (by omega) + subst this + rfl + | succ n ih => + intro s t c hs hlt + match s with + | [] => rfl + | [b] => rfl + | b0 :: b1 :: r => + have hr : r.length ≤ n := by + simp only [List.length_cons] at hs + omega + rw [segFrom_cons₂] + by_cases hcase : b0 = s0 ∧ b1 = s1 + · rw [if_pos hcase] + exact ih r t (c + 1) hr (by omega) + · rw [if_neg hcase, if_neg (by omega : ¬ c = t)] + exact ih r t c hr hlt + +/-- Token segments joined by a separator. -/ +def tokenJoin (sep : EncToken) : List (List EncToken) → List EncToken + | [] => [] + | g :: gs => g ++ [sep] ++ tokenJoin sep gs + +theorem cnf_tokens_eq (φ : CNF) : + CNF.tokens φ = tokenJoin EncToken.clauseSep (φ.map Clause.tokens) := by + induction φ with + | nil => rfl + | cons c cs ih => rw [CNF.tokens, ih, List.map_cons, tokenJoin] + +theorem clause_tokens_eq (c : Clause) : + Clause.tokens c = tokenJoin EncToken.litSep (c.map Lit.rawTokens) := by + induction c with + | nil => rfl + | cons l ls ih => rw [Clause.tokens, ih, List.map_cons, tokenJoin] + +/-- **The extraction returns one segment.** -/ +theorem segFrom_tokenJoin {sep : EncToken} {b0 b1 : Bool} (hsep : sep.encode = [b0, b1]) + (hne : ∀ t : EncToken, t ≠ sep → ∃ c0 c1, t.encode = [c0, c1] ∧ ¬(c0 = b0 ∧ c1 = b1)) : + ∀ (segs : List (List EncToken)), (∀ g ∈ segs, ∀ t ∈ g, t ≠ sep) → + ∀ (t c : ℕ), c ≤ t → ∀ hlt : t - c < segs.length, + segFrom b0 b1 t c (encodeTokens (tokenJoin sep segs)) + = encodeTokens (segs[t - c]'hlt) := by + intro segs + induction segs with + | nil => intro _ t c _ hlt; simp at hlt + | cons g gs ih => + intro hall t c hle hlt + have hnosep : ∀ t' ∈ g, t' ≠ sep := hall g (by simp) + have hsplit : tokenJoin sep (g :: gs) = g ++ ([sep] ++ tokenJoin sep gs) := by + rw [tokenJoin, List.append_assoc] + rw [hsplit, encodeTokens_append] + rw [show segFrom b0 b1 t c (encodeTokens g ++ + encodeTokens ([sep] ++ tokenJoin sep gs)) + = (if c = t then encodeTokens g else []) + ++ segFrom b0 b1 t c (encodeTokens ([sep] ++ tokenJoin sep gs)) from + segFrom_encodeTokens_noSep hne g hnosep _ t c] + have hs : encodeTokens ([sep] ++ tokenJoin sep gs) + = b0 :: b1 :: encodeTokens (tokenJoin sep gs) := by + rw [encodeTokens_append, + show encodeTokens [sep] = sep.encode from by simp, hsep] + rfl + rw [hs, segFrom_cons₂, if_pos (by simp : (b0 = b0 ∧ b1 = b1))] + rcases Nat.eq_or_lt_of_le hle with heq | hlt2 + · rw [if_pos heq, segFrom_of_gt b0 b1 + (encodeTokens (tokenJoin sep gs)).length _ t (c + 1) (le_refl _) (by omega)] + have hzero : t - c = 0 := by omega + simp only [hzero] + simp + · rw [if_neg (by omega : ¬ c = t)] + have hidx : t - c = (t - (c + 1)) + 1 := by omega + have hlt' : t - (c + 1) < gs.length := by + rw [hidx] at hlt + simp only [List.length_cons] at hlt + omega + rw [ih (fun g' hg' => hall g' (by simp [hg'])) t (c + 1) (by omega) hlt'] + simp only [List.nil_append] + congr 1 + simp only [hidx] + simp + +/-! ### Down to a literal of a real formula -/ + +theorem length_encodeTokens : ∀ toks : List EncToken, + (encodeTokens toks).length = 2 * toks.length := by + intro toks + induction toks with + | nil => rfl + | cons t ts ih => + rw [encodeTokens_cons, List.length_append, length_encode_token, ih, + List.length_cons] + ring + +theorem even_length_encode (φ : CNF) : Even φ.encode.length := by + rw [← CNF.encodeTokens_tokens, length_encodeTokens] + exact ⟨(CNF.tokens φ).length, by ring⟩ + +theorem rawTokens_no_litSep (l : Lit) : + ∀ t ∈ Lit.rawTokens l, t ≠ EncToken.litSep := by + intro t ht + rw [Lit.rawTokens, List.mem_map] at ht + obtain ⟨b, -, hb⟩ := ht + rw [← hb] + simp + +/-- **The extraction returns one clause of a real formula.** -/ +theorem segFrom_encode_clause (φ : CNF) {j : ℕ} (hj : j < φ.length) : + segFrom true false j 0 φ.encode = encodeTokens (Clause.tokens (φ[j]'hj)) := by + rw [← CNF.encodeTokens_tokens, cnf_tokens_eq] + have hall : ∀ g ∈ φ.map Clause.tokens, ∀ t ∈ g, t ≠ EncToken.clauseSep := by + intro g hg t ht hcon + rw [List.mem_map] at hg + obtain ⟨cl, -, hcl⟩ := hg + rw [← hcl] at ht + have hmem : t ∈ (Clause.tokens cl).filter (fun t => t = EncToken.clauseSep) := by + rw [List.mem_filter] + exact ⟨ht, by simp [hcon]⟩ + rw [clause_tokens_no_sep cl] at hmem + simp at hmem + have hlt : j - 0 < (φ.map Clause.tokens).length := by + rw [List.length_map] + omega + rw [segFrom_tokenJoin rfl hne_clauseSep _ hall j 0 (Nat.zero_le _) hlt] + congr 1 + simp + +/-- **The extraction returns one literal of a real clause.** -/ +theorem segFrom_encode_lit (cl : Clause) {p : ℕ} (hp : p < cl.length) : + segFrom false true p 0 (encodeTokens (Clause.tokens cl)) + = encodeTokens (Lit.rawTokens (cl[p]'hp)) := by + rw [clause_tokens_eq] + have hall : ∀ g ∈ cl.map Lit.rawTokens, ∀ t ∈ g, t ≠ EncToken.litSep := by + intro g hg t ht + rw [List.mem_map] at hg + obtain ⟨l, -, hl⟩ := hg + rw [← hl] at ht + exact rawTokens_no_litSep l t ht + have hlt : p - 0 < (cl.map Lit.rawTokens).length := by + rw [List.length_map] + omega + rw [segFrom_tokenJoin rfl hne_litSep _ hall p 0 (Nat.zero_le _) hlt] + congr 1 + simp + +/-- **The packaged extraction returns one literal.** -/ +theorem litSegFn_encode (φ : CNF) {j p : ℕ} (hj : j < φ.length) + (hp : p < (φ[j]'hj).length) : + litSegFn (pair (pair (List.replicate j true) (List.replicate p true)) φ.encode) + = encodeTokens (Lit.rawTokens ((φ[j]'hj)[p]'hp)) := by + rw [litSegFn_eq (even_length_encode φ), segFrom_encode_clause φ hj, + segFrom_encode_lit _ hp] + +theorem length_rawTokens (l : Lit) : (Lit.rawTokens l).length = l.var + 1 := by + rw [Lit.rawTokens, List.length_map, Lit.encodeRaw_length] + +/-- **The extracted literal has the length its variable index dictates.** -/ +theorem length_litSegFn_encode (φ : CNF) {j p : ℕ} (hj : j < φ.length) + (hp : p < (φ[j]'hj).length) : + (litSegFn (pair (pair (List.replicate j true) (List.replicate p true)) + φ.encode)).length = 2 * (((φ[j]'hj)[p]'hp).var + 1) := by + rw [litSegFn_encode φ hj hp, length_encodeTokens, length_rawTokens] + +/-- **The extraction reads off the variable index.** -/ +theorem litVarFn_encode (φ : CNF) {j p : ℕ} (hj : j < φ.length) + (hp : p < (φ[j]'hj).length) : + litVarFn (pair (pair (List.replicate j true) (List.replicate p true)) φ.encode) + = List.replicate (((φ[j]'hj)[p]'hp).var) true := by + rw [litVarFn, halfFn_eq, List.length_drop, length_litSegFn_encode φ hj hp] + congr 1 + omega + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean b/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean new file mode 100644 index 00000000..5570cb1b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean @@ -0,0 +1,509 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PositionsFP +public import Complexitylib.Classes.PCP.Internal.SquareVerifier + +/-! +# A verifier for a constraint graph + +The verifier of a constraint graph picks an edge at random, reads the symbols +its two endpoints carry, and checks the constraint. The proof is the assignment, +written as one fixed-width block per vertex, so the queries are the two blocks. + +This module packages the algorithmic content a graph must supply — how many +edges, the endpoints of an edge, and the constraint — and turns it into a +`PCPVerifier`. Nothing here is about the graph's *quality*: completeness and +soundness are hypotheses on the supplied data, discharged elsewhere by Dinur's +amplification. + +## Main definitions + +- `Complexity.AlgCSP` — a constraint graph presented algorithmically + +## Main results + +- `Complexity.AlgCSP.cntU_mem_FP`, `Complexity.AlgCSP.posU_mem_FP` — the query + list is polynomial-time describable +- `Complexity.AlgCSP.verifier` — the verifier itself +- `Complexity.mem_PCP_of_algCSP` — a constraint graph with a gap puts its + language in `PCP` +-/ + +@[expose] public section + +namespace Complexity + +/-- A constraint graph presented the way an algorithm sees it: a count of edges, +the endpoints of each edge, and a decidable constraint. Indices are handled in +unary, which is what a polynomial-time loop can carry. -/ +structure AlgCSP where + /-- How many edges the graph on this input has. -/ + numEdges : List Bool → ℕ + /-- The edge count is polynomial-time computable in unary. -/ + numEdges_mem : (fun x : List Bool => List.replicate (numEdges x) true) ∈ FP + /-- The number of bits a symbol occupies. -/ + width : ℕ + /-- A symbol occupies at least one bit. -/ + width_pos : 0 < width + /-- The endpoints of an edge: `false` for the first, `true` for the second. -/ + vert : Bool → List Bool → ℕ → ℕ + /-- The endpoints are polynomial-time computable in unary. -/ + vert_mem : ∀ b, (fun w : List Bool => List.replicate + (vert b (Cobham.fstBlock w) (Cobham.sndBlock w).length) true) ∈ FP + /-- The constraint, on `pair (pair x (unary e)) (the two symbol blocks)`. -/ + ok : Language + /-- The constraint is polynomial-time decidable. -/ + ok_mem : ok ∈ P + +namespace AlgCSP + +variable (A : AlgCSP) (p : Polynomial ℕ) + +/-- The edge a coin string names. -/ +def edgeIdx (z : List Bool) : ℕ := binValLE (Cobham.sndBlock z) + +/-- That index in unary, as far as the clamp allows. -/ +noncomputable def edgeU (z : List Bool) : List Bool := unaryVal p z + +theorem edgeU_mem_FP : edgeU p ∈ FP := unaryVal_mem_FP p + +theorem edgeU_eq {z : List Bool} + (h : 2 ^ (Cobham.sndBlock z).length ≤ p.eval z.length) : + edgeU p z = List.replicate (edgeIdx z) true := unaryVal_eq h + +/-- Is the named edge a real one? -/ +noncomputable def inRange (z : List Bool) : List Bool := + Cobham.lenLeFlag (List.replicate (A.numEdges (Cobham.fstBlock z)) true) + (true :: edgeU p z) + +theorem inRange_mem_FP : A.inRange p ∈ FP := by + have hn : (fun z : List Bool => + List.replicate (A.numEdges (Cobham.fstBlock z)) true) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP A.numEdges_mem + simpa [Function.comp] using this + exact lenLeFlagFn_mem_FP hn (mem_FP_comp (edgeU_mem_FP p) (Cobham.cons_mem_FP true)) + +theorem inRange_eq_true_iff {z : List Bool} + (h : 2 ^ (Cobham.sndBlock z).length ≤ p.eval z.length) : + A.inRange p z = [true] ↔ edgeIdx z < A.numEdges (Cobham.fstBlock z) := by + rw [inRange, edgeU_eq p h, + Cobham.lenLeFlag_eq_true_iff, List.length_cons, List.length_replicate, + List.length_replicate] + omega + +/-- How many queries the verifier makes: both symbol blocks, or none when the +coin string names no edge. -/ +noncomputable def cntU (z : List Bool) : List Bool := + Cobham.selectHead (A.inRange p z) (List.replicate (2 * A.width) true) [] + +theorem cntU_mem_FP : A.cntU p ∈ FP := + Cobham.selectHeadFn_mem_FP (A.inRange_mem_FP p) + (constFn_mem_FP (List.replicate (2 * A.width) true)) (constFn_mem_FP []) + +/-! ### Where the verifier looks -/ + +/-- The endpoint a query index refers to: the first for the low half of the +queries, the second for the high half. -/ +noncomputable def vertU (b : Bool) (w : List Bool) : List Bool := + List.replicate (A.vert b (Cobham.fstBlock (Cobham.fstBlock w)) + (edgeU p (Cobham.fstBlock w)).length) true + +theorem vertU_mem_FP (b : Bool) : A.vertU p b ∈ FP := by + have hx : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have he : (fun w : List Bool => edgeU p (Cobham.fstBlock w)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP (edgeU_mem_FP p) + have := mem_FP_comp (Cobham.pairFn_mem_FP hx he) (A.vert_mem b) + refine mem_FP_of_eq this fun w => ?_ + rw [vertU, Function.comp_apply, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + +/-- Is this query in the low half? -/ +def lowFlag (w : List Bool) : List Bool := + Cobham.lenLeFlag (List.replicate A.width true) (true :: Cobham.sndBlock w) + +theorem lowFlag_mem_FP : A.lowFlag ∈ FP := + lenLeFlagFn_mem_FP (constFn_mem_FP (List.replicate A.width true)) + (mem_FP_comp Cobham.sndBlock_mem_FP (Cobham.cons_mem_FP true)) + +theorem lowFlag_eq_true_iff (w : List Bool) : + A.lowFlag w = [true] ↔ (Cobham.sndBlock w).length < A.width := by + rw [lowFlag, Cobham.lenLeFlag_eq_true_iff, List.length_cons, List.length_replicate] + omega + +/-- The offset inside the symbol block. -/ +def offU (w : List Bool) : List Bool := + Cobham.selectHead (A.lowFlag w) (Cobham.sndBlock w) ((Cobham.sndBlock w).drop A.width) + +theorem offU_mem_FP : A.offU ∈ FP := by + refine Cobham.selectHeadFn_mem_FP A.lowFlag_mem_FP Cobham.sndBlock_mem_FP ?_ + have := dropLenFn_mem_FP (constFn_mem_FP (List.replicate A.width true)) + Cobham.sndBlock_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [List.length_replicate] + +/-- **The position a query reads**, in unary. -/ +noncomputable def posU (w : List Bool) : List Bool := + List.replicate + ((Cobham.selectHead (A.lowFlag w) (A.vertU p false w) (A.vertU p true w)).length + * A.width) true + ++ List.replicate (A.offU w).length true + +theorem posU_mem_FP : A.posU p ∈ FP := by + have hv : (fun w => Cobham.selectHead (A.lowFlag w) (A.vertU p false w) + (A.vertU p true w)) ∈ FP := + Cobham.selectHeadFn_mem_FP A.lowFlag_mem_FP (A.vertU_mem_FP p false) + (A.vertU_mem_FP p true) + have hmul : (fun w => List.replicate + ((Cobham.selectHead (A.lowFlag w) (A.vertU p false w) (A.vertU p true w)).length + * A.width) true) ∈ FP := by + have hb : (fun _ : List Bool => List.replicate A.width false) ∈ FP := + Cobham.const_replicate_mem_FP A.width + have hm := Cobham.mulLenFn_mem_FP hv hb + have := mem_FP_comp hm unaryLength_mem_FP + refine mem_FP_of_eq this fun w => ?_ + rw [Function.comp_apply, List.length_replicate, List.length_replicate] + have hoff : (fun w => List.replicate (A.offU w).length true) ∈ FP := by + have := mem_FP_comp A.offU_mem_FP unaryLength_mem_FP + simpa [Function.comp] using this + exact Cobham.appendFn_mem_FP hmul hoff + +theorem cntU_eq_replicate (z : List Bool) : + A.cntU p z = List.replicate (A.cntU p z).length true := by + rw [cntU] + rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges (Cobham.fstBlock z)) true) + (true :: edgeU p z) with h | h <;> rw [inRange, h] + · rw [selectHead_cons_true, List.length_replicate] + · rw [selectHead_cons_false] + simp + +theorem posU_eq_replicate (w : List Bool) : + A.posU p w = List.replicate (A.posU p w).length true := by + rw [posU, List.length_append, List.length_replicate, List.length_replicate, + List.replicate_add] + +/-! ### The verifier -/ + +/-- How many queries, as a number. -/ +noncomputable def cnt (z : List Bool) : ℕ := (A.cntU p z).length + +/-- The `i`-th query position, as a number. -/ +noncomputable def pos (z : List Bool) (i : ℕ) : ℕ := + (A.posU p (pair z (List.replicate i true))).length + +/-- The argument the constraint is asked about. -/ +noncomputable def okArg (z : List Bool) : List Bool := + pair (pair (Cobham.fstBlock (Cobham.fstBlock z)) (edgeU p (Cobham.fstBlock z))) + (Cobham.sndBlock z) + +theorem okArg_mem_FP : okArg p ∈ FP := by + have hx : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have he : (fun z : List Bool => edgeU p (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP (edgeU_mem_FP p) + exact Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hx he) Cobham.sndBlock_mem_FP + +/-- The verdict: accept unless the coin string names a real edge whose +constraint fails. -/ +noncomputable def verdictLang : Language := + {z | A.inRange p (Cobham.fstBlock z) = [true] → okArg p z ∈ A.ok} + +theorem verdictLang_mem_P : A.verdictLang p ∈ P := by + obtain ⟨g, hgFP, hg⟩ := exists_decisionFn_of_mem_P A.ok_mem + have hin : (fun z : List Bool => A.inRange p (Cobham.fstBlock z)) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP (A.inRange_mem_FP p) + simpa [Function.comp] using this + have hok : (fun z : List Bool => [g (okArg p z)]) ∈ FP := by + have := mem_FP_comp (okArg_mem_FP p) hgFP + simpa [Function.comp] using this + have hflag : (fun z : List Bool => + Cobham.selectHead (A.inRange p (Cobham.fstBlock z)) [g (okArg p z)] [true]) ∈ FP := + Cobham.selectHeadFn_mem_FP hin hok (constFn_mem_FP [true]) + refine mem_P_of_decisionFn hflag fun z => ?_ + show (A.inRange p (Cobham.fstBlock z) = [true] → okArg p z ∈ A.ok) ↔ _ + rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges + (Cobham.fstBlock (Cobham.fstBlock z))) true) + (true :: edgeU p (Cobham.fstBlock z)) with h | h + · have hv : A.inRange p (Cobham.fstBlock z) = [true] := by rw [inRange]; exact h + rw [hv, selectHead_cons_true] + simp only [List.mem_singleton, exists_eq_left, forall_const] + exact hg _ + · have hv : A.inRange p (Cobham.fstBlock z) = [false] := by rw [inRange]; exact h + rw [hv, selectHead_cons_false] + simp + +theorem cnt_le (z : List Bool) : A.cnt p z ≤ 2 * A.width := by + rw [cnt, cntU] + rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges (Cobham.fstBlock z)) true) + (true :: edgeU p z) with h | h <;> rw [inRange, h] + · rw [selectHead_cons_true, List.length_replicate] + · rw [selectHead_cons_false] + simp + +/-- **The verifier of a constraint graph.** -/ +noncomputable def verifier : PCPVerifier where + positions x ρ := (List.range (A.cnt p (pair x ρ))).map (A.pos p (pair x ρ)) + positions_mem := by + have hcnt : (fun z : List Bool => List.replicate (A.cnt p z) true) ∈ FP := by + refine mem_FP_of_eq (A.cntU_mem_FP p) fun z => ?_ + rw [cnt, ← cntU_eq_replicate] + obtain ⟨g, hg, hgspec⟩ := positions_mem_of_unary hcnt (A.posU_mem_FP p) + (fun z i => by + show A.posU p (pair z (List.replicate i true)) + = List.replicate (A.posU p (pair z (List.replicate i true))).length true + rw [← posU_eq_replicate]) + exact ⟨g, hg, fun x ρ => hgspec (pair x ρ)⟩ + verdict := A.verdictLang p + verdict_mem := A.verdictLang_mem_P p + +@[simp] theorem positions_verifier (x ρ : List Bool) : + (A.verifier p).positions x ρ + = (List.range (A.cnt p (pair x ρ))).map (A.pos p (pair x ρ)) := rfl + +theorem verifier_queryBounded : (A.verifier p).QueryBounded (fun _ => 2 * A.width) := by + intro x ρ + rw [positions_verifier, List.length_map, List.length_range] + exact A.cnt_le p _ + +theorem mem_verdict_verifier (z : List Bool) : + z ∈ (A.verifier p).verdict + ↔ (A.inRange p (Cobham.fstBlock z) = [true] → okArg p z ∈ A.ok) := Iff.rfl + +/-! ### What the verifier reads and decides -/ + +/-- The position query `i` reads, as a function of the edge alone. -/ +def posVal (x : List Bool) (e i : ℕ) : ℕ := + A.vert (decide (¬ i < A.width)) x e * A.width + (if i < A.width then i else i - A.width) + +theorem pos_eq {x ρ : List Bool} (h : 2 ^ ρ.length ≤ p.eval (pair x ρ).length) (i : ℕ) : + A.pos p (pair x ρ) i = A.posVal x (binValLE ρ) i := by + have hz : Cobham.sndBlock (pair x ρ) = ρ := Cobham.sndBlock_pair x ρ + have hE : edgeU p (pair x ρ) = List.replicate (binValLE ρ) true := by + have := edgeU_eq (p := p) (z := pair x ρ) (by rw [hz]; exact h) + rw [this, edgeIdx, hz] + set w := pair (pair x ρ) (List.replicate i true) with hw + have hsnd : Cobham.sndBlock w = List.replicate i true := Cobham.sndBlock_pair _ _ + have hfst : Cobham.fstBlock w = pair x ρ := Cobham.fstBlock_pair _ _ + have hlow : A.lowFlag w = if i < A.width then [true] else [false] := by + rcases Cobham.lenLeFlag_flag (List.replicate A.width true) + (true :: Cobham.sndBlock w) with hf | hf + · rw [lowFlag, hf, if_pos] + rw [← lowFlag, A.lowFlag_eq_true_iff w, hsnd, List.length_replicate] at hf + exact hf + · rw [lowFlag, hf, if_neg] + intro hcon + have := (A.lowFlag_eq_true_iff w).mpr (by rw [hsnd, List.length_replicate]; exact hcon) + rw [lowFlag, hf] at this + simp at this + have hv : ∀ b, (A.vertU p b w).length = A.vert b x (binValLE ρ) := by + intro b + rw [vertU, List.length_replicate, hfst, hE, List.length_replicate, + Cobham.fstBlock_pair] + have hoff : (A.offU w).length = if i < A.width then i else i - A.width := by + rw [offU, hlow, hsnd] + by_cases hi : i < A.width + · rw [if_pos hi, selectHead_cons_true, List.length_replicate, if_pos hi] + · rw [if_neg hi, selectHead_cons_false, List.length_drop, List.length_replicate, + if_neg hi] + show (A.posU p w).length = _ + rw [posU, List.length_append, List.length_replicate, List.length_replicate, hoff, + posVal] + congr 2 + rw [hlow] + by_cases hi : i < A.width + · rw [if_pos hi, selectHead_cons_true, hv] + simp [hi] + · rw [if_neg hi, selectHead_cons_false, hv] + simp [hi] + +/-- Edge `e` is satisfied by the proof `π`. -/ +def Sat (x π : List Bool) (e : ℕ) : Prop := + pair (pair x (List.replicate e true)) + (PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x e))) ∈ A.ok + +theorem cnt_eq_of_inRange {z : List Bool} (h : A.inRange p z = [true]) : + A.cnt p z = 2 * A.width := by + rw [cnt, cntU, h, selectHead_cons_true, List.length_replicate] + +/-- **What the verifier decides.** It accepts unless the coin string names a +real edge that the proof fails to satisfy. -/ +theorem accepts_verifier_iff {x ρ : List Bool} + (h : 2 ^ ρ.length ≤ p.eval (pair x ρ).length) (π : List Bool) : + (A.verifier p).Accepts x π ρ + ↔ (binValLE ρ < A.numEdges x → A.Sat x π (binValLE ρ)) := by + have hz : Cobham.sndBlock (pair x ρ) = ρ := Cobham.sndBlock_pair x ρ + have hE : edgeU p (pair x ρ) = List.replicate (binValLE ρ) true := by + have := edgeU_eq (p := p) (z := pair x ρ) (by rw [hz]; exact h) + rw [this, edgeIdx, hz] + have hin : A.inRange p (pair x ρ) = [true] ↔ binValLE ρ < A.numEdges x := by + rw [A.inRange_eq_true_iff p (by rw [hz]; exact h), edgeIdx, hz, Cobham.fstBlock_pair] + set a := PCPVerifier.answers π ((A.verifier p).positions x ρ) with ha + have hacc : (A.verifier p).Accepts x π ρ + ↔ (A.inRange p (pair x ρ) = [true] → okArg p (pair (pair x ρ) a) ∈ A.ok) := by + rw [PCPVerifier.Accepts, mem_verdict_verifier, Cobham.fstBlock_pair] + have haeq : binValLE ρ < A.numEdges x → + a = PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x (binValLE ρ))) := by + intro hlt + rw [ha, positions_verifier, A.cnt_eq_of_inRange p (hin.mpr hlt)] + congr 1 + exact List.map_congr_left fun i _ => A.pos_eq p h i + rw [hacc, hin] + constructor + · intro hh hlt + have hok := hh hlt + rw [okArg, Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hE] at hok + rw [Sat, ← haeq hlt] + exact hok + · intro hh hlt + have hs := hh hlt + rw [Sat] at hs + rw [okArg, Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hE, + haeq hlt] + exact hs + +/-! ### How often the verifier accepts -/ + +open Classical in +theorem acceptEvent_eq {x : List Bool} {T : ℕ} + (h : 2 ^ T ≤ p.eval (2 * x.length + 2 + T)) (π : List Bool) : + (A.verifier p).acceptEvent T x π + = Finset.univ.filter (fun ρ : Fin T → Bool => + PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ)) := by + ext ρ + have hlen : (BitString.toList ρ).length = T := by simp + have hclamp : 2 ^ (BitString.toList ρ).length + ≤ p.eval (pair x (BitString.toList ρ)).length := by + rw [hlen, pair_length, hlen] + exact h + simp only [PCPVerifier.acceptEvent, Finset.mem_filter, Finset.mem_univ, true_and] + rw [A.accepts_verifier_iff p hclamp, binValLE_toList] + +open Classical in +theorem card_reject {x : List Bool} {T : ℕ} (hN : A.numEdges x ≤ 2 ^ T) (π : List Bool) : + ((Finset.univ.filter (fun ρ : Fin T → Bool => + PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ)))ᶜ).card + = ((Finset.range (A.numEdges x)).filter (fun e => ¬ A.Sat x π e)).card := by + classical + have hcompl : (Finset.univ.filter (fun ρ : Fin T → Bool => + PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ)))ᶜ + = Finset.univ.filter (fun ρ : Fin T → Bool => + ¬ (PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ))) := by + ext ρ + simp [Finset.mem_filter] + rw [hcompl, card_filter_coinIndex T (fun e => ¬ (e < A.numEdges x → A.Sat x π e))] + congr 1 + ext e + simp only [Finset.mem_filter, Finset.mem_range, Classical.not_imp] + constructor + · rintro ⟨_, hlt, hns⟩ + exact ⟨hlt, hns⟩ + · rintro ⟨hlt, hns⟩ + exact ⟨lt_of_lt_of_le hlt hN, hlt, hns⟩ + +open Classical in +/-- **Perfect completeness.** A proof satisfying every edge is always +accepted. -/ +theorem eventProb_eq_one {x : List Bool} {T : ℕ} + (h : 2 ^ T ≤ p.eval (2 * x.length + 2 + T)) (hN : A.numEdges x ≤ 2 ^ T) + {π : List Bool} (hsat : ∀ e < A.numEdges x, A.Sat x π e) : + eventProb ((A.verifier p).acceptEvent T x π) = 1 := by + classical + have hrej : ((Finset.range (A.numEdges x)).filter (fun e => ¬ A.Sat x π e)).card = 0 := by + rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] + intro e he + exact not_not.mpr (hsat e (Finset.mem_range.mp he)) + have hc := A.card_reject hN π + rw [hrej] at hc + have hempty : (Finset.univ.filter (fun ρ : Fin T → Bool => + PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ)))ᶜ = ∅ := + Finset.card_eq_zero.mp hc + have : eventProb ((Finset.univ.filter (fun ρ : Fin T → Bool => + PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ)))ᶜ) = 0 := by + rw [hempty, eventProb_empty] + rw [A.acceptEvent_eq p h π] + rw [eventProb_compl] at this + linarith + +open Classical in +/-- **Soundness.** If no proof satisfies more than a `1 - gap` fraction of the +edges, the verifier accepts with probability at most `1 - gap / 2`. -/ +theorem eventProb_le {x : List Bool} {T : ℕ} {gap : ℚ} + (h : 2 ^ T ≤ p.eval (2 * x.length + 2 + T)) (hN : A.numEdges x ≤ 2 ^ T) + (hT : 2 ^ T ≤ 2 * A.numEdges x) {π : List Bool} + (hs : (((Finset.range (A.numEdges x)).filter (A.Sat x π)).card : ℚ) + ≤ (1 - gap) * A.numEdges x) : + eventProb ((A.verifier p).acceptEvent T x π) ≤ 1 - gap / 2 := by + classical + set N := A.numEdges x with hNdef + set S := ((Finset.range N).filter (A.Sat x π)).card with hS + set R := ((Finset.range N).filter (fun e => ¬ A.Sat x π e)).card with hR + have hsum : S + R = N := by + rw [hS, hR] + have := Finset.card_filter_add_card_filter_not + (s := Finset.range N) (p := A.Sat x π) + simpa using this + have hNpos : 0 < N := by + have h2 : (0 : ℕ) < 2 ^ T := Nat.two_pow_pos T + omega + have hNQ : (0 : ℚ) < (N : ℚ) := by exact_mod_cast hNpos + have hTQ : (0 : ℚ) < (2 : ℚ) ^ T := by positivity + have hRQ : (R : ℚ) = (N : ℚ) - (S : ℚ) := by + have : (S : ℚ) + (R : ℚ) = (N : ℚ) := by exact_mod_cast hsum + linarith + have hRge : gap * (N : ℚ) ≤ (R : ℚ) := by + rw [hRQ] + nlinarith [hs] + have hTle : ((2 : ℚ) ^ T) ≤ 2 * (N : ℚ) := by + have : ((2 ^ T : ℕ) : ℚ) ≤ ((2 * N : ℕ) : ℚ) := by exact_mod_cast hT + push_cast at this + linarith + have hRnn : (0 : ℚ) ≤ (R : ℚ) := by positivity + have hdiv : (R : ℚ) / (2 * (N : ℚ)) ≤ (R : ℚ) / (2 : ℚ) ^ T := + div_le_div_of_nonneg_left hRnn hTQ hTle + have hgap : gap / 2 ≤ (R : ℚ) / (2 * (N : ℚ)) := by + rw [div_le_div_iff₀ (by norm_num) (by linarith)] + nlinarith [hRge] + rw [A.acceptEvent_eq p h π] + set F := Finset.univ.filter (fun ρ : Fin T → Bool => + PCPVerifier.coinIndex ρ < N → A.Sat x π (PCPVerifier.coinIndex ρ)) with hF + have hcompl : eventProb Fᶜ = 1 - eventProb F := eventProb_compl F + have hcard : Fᶜ.card = R := A.card_reject hN π + have hFc : eventProb Fᶜ = (R : ℚ) / 2 ^ T := by + rw [eventProb, hcard] + linarith [hgap, hdiv, hFc, hcompl] + +end AlgCSP + +open scoped Complexity in +open Classical in +/-- **A constraint graph with a gap puts its language in `PCP`.** Completeness +and soundness are hypotheses on the graph: a member has an assignment satisfying +every edge, and a non-member has none satisfying more than a `1 - gap` +fraction. -/ +theorem mem_PCP_of_algCSP (A : AlgCSP) (p : Polynomial ℕ) (t : ℕ → ℕ) + (ht : (fun x : List Bool => List.replicate (t x.length) true) ∈ FP) + (hclamp : ∀ n : ℕ, 2 ^ t n ≤ p.eval (2 * n + 2 + t n)) + (hN : ∀ x : List Bool, A.numEdges x ≤ 2 ^ t x.length) + (hT : ∀ x : List Bool, 2 ^ t x.length ≤ 2 * A.numEdges x) + {L : Language} {gap : ℚ} (hgap0 : 0 < gap) (hgap1 : gap ≤ 1) + (hcomp : ∀ x ∈ L, ∃ π : List Bool, ∀ e < A.numEdges x, A.Sat x π e) + (hsound : ∀ x ∉ L, ∀ π : List Bool, + (((Finset.range (A.numEdges x)).filter (A.Sat x π)).card : ℚ) + ≤ (1 - gap) * A.numEdges x) : + ∃ j : ℕ, L ∈ PCP (fun n => 2 ^ j * t n) (fun _ => 2 ^ j * (2 * A.width)) := by + classical + have hmem : L ∈ PCPWith t (fun _ => 2 * A.width) (1 - gap / 2) := by + refine ⟨A.verifier p, A.verifier_queryBounded p, ?_, ?_⟩ + · intro x hx + obtain ⟨π, hπ⟩ := hcomp x hx + exact ⟨π, A.eventProb_eq_one p (hclamp x.length) (hN x) hπ⟩ + · intro x hx π + exact A.eventProb_le p (hclamp x.length) (hN x) (hT x) (hsound x hx π) + refine mem_PCP_of_PCPWith ?_ ?_ ht hmem + · linarith + · linarith + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Cheeger.lean b/Complexitylib/Classes/PCP/Internal/Cheeger.lean new file mode 100644 index 00000000..9fc6b42e --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Cheeger.lean @@ -0,0 +1,584 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.EdgeExpansion +public import Complexitylib.Classes.PCP.Internal.ExpanderPad + +/-! +# Cheeger's inequality: edge expansion gives a spectral gap + +`EdgeExpansion` proved that a spectral gap forces every set to have many +boundary darts. This module proves the converse — the harder direction of +Cheeger's inequality — in the form the rest of the development consumes: a +`SpectralBound` below one, for the graph with a self-loop added per dart. + +The argument is the classical one, made discrete. + +* The **Dirichlet form** `∑ (f u - f w)²` over darts equals + `2 d (‖f‖² - ⟨f, step f⟩)`. +* **Co-area.** For `ψ ≥ 0` supported on at most half the vertices, + `∑ |ψ u - ψ w| ≥ 2 h d ∑ ψ`: peel off the lowest positive level, apply the + expansion to the support, and induct on the support. +* **Cauchy–Schwarz** turns the co-area bound for `ψ = φ²` into + `h² d ∑ φ² ≤ Dirichlet φ` for nonnegative `φ` of small support. +* **A median split** extends this to every mean-zero `f`, losing nothing. +* **The lazy walk.** Adding `d` loops halves the step operator plus the + identity, which is positive semidefinite, and a Cauchy–Schwarz for + semidefinite forms turns the Rayleigh bound into an operator bound — no + spectral theorem needed. + +## Main definitions + +- `Complexity.RegGraph.EdgeExpansion` — every set of at most half the vertices + has at least `h d |S|` boundary darts +- `Complexity.RegGraph.dirichlet` — the Dirichlet form over darts + +## Main results + +- `Complexity.RegGraph.dirichlet_ge_of_edgeExpansion` — `h² d ‖f‖² ≤ Dirichlet f` + for mean-zero `f` +- `Complexity.RegGraph.spectralBound_padLoops_of_edgeExpansion` — the lazy + graph has bound `1 - h² / 4` +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Darts and their reversal -/ + +/-- The reversal of darts, as a permutation. -/ +def rotPerm : Equiv.Perm (G.V × G.D) := G.rot_involutive.toPerm + +theorem nbr_rot (p : G.V × G.D) : G.nbr (G.rot p).1 (G.rot p).2 = p.1 := by + show (G.rot (G.rot p)).1 = p.1 + rw [G.rot_involutive p] + +/-- **Reversing every dart** swaps the two ends in a sum. -/ +theorem sum_darts_swap (g : G.V → G.V → ℝ) : + ∑ p : G.V × G.D, g p.1 (G.nbr p.1 p.2) = ∑ p : G.V × G.D, g (G.nbr p.1 p.2) p.1 := by + refine Fintype.sum_equiv G.rotPerm _ _ fun p => ?_ + show g p.1 (G.nbr p.1 p.2) = g (G.nbr (G.rot p).1 (G.rot p).2) (G.rot p).1 + rw [nbr_rot] + rfl + +theorem sum_darts_fst (g : G.V → ℝ) : + ∑ p : G.V × G.D, g p.1 = (G.deg : ℝ) * ∑ v : G.V, g v := by + rw [Fintype.sum_prod_type] + simp only [Finset.sum_const, Finset.card_univ, card_eq_deg, nsmul_eq_mul] + rw [← Finset.mul_sum] + +theorem sum_darts_snd (g : G.V → ℝ) : + ∑ p : G.V × G.D, g (G.nbr p.1 p.2) = (G.deg : ℝ) * ∑ v : G.V, g v := by + rw [G.sum_darts_swap (fun _ w => g w)] + exact G.sum_darts_fst g + +theorem sum_mul_step (f g : G.V → ℝ) : + ∑ v : G.V, f v * G.step g v = (∑ p : G.V × G.D, f p.1 * g (G.nbr p.1 p.2)) / (G.deg : ℝ) := by + simp only [step, Fintype.sum_prod_type] + rw [Finset.sum_div] + refine Finset.sum_congr rfl fun v _ => ?_ + rw [← mul_div_assoc, Finset.mul_sum] + +/-! ### Edge expansion and the Dirichlet form -/ + +/-- **Edge expansion**: every set of at most half the vertices has at least +`h · d · |S|` darts leaving it. -/ +def EdgeExpansion (h : ℝ) : Prop := + ∀ S : Finset G.V, 2 * S.card ≤ G.order → + h * (G.deg : ℝ) * (S.card : ℝ) ≤ ((G.dartsBetween S Sᶜ).card : ℝ) + +/-- The Dirichlet form: the sum over darts of the squared difference. -/ +noncomputable def dirichlet (f : G.V → ℝ) : ℝ := + ∑ p : G.V × G.D, (f p.1 - f (G.nbr p.1 p.2)) ^ 2 + +theorem dirichlet_nonneg (f : G.V → ℝ) : 0 ≤ G.dirichlet f := + Finset.sum_nonneg fun _ _ => sq_nonneg _ + +/-- **The Dirichlet form and the step operator.** -/ +theorem dirichlet_eq (f : G.V → ℝ) : + G.dirichlet f = 2 * (G.deg : ℝ) * ((∑ v : G.V, (f v) ^ 2) - ∑ v : G.V, f v * G.step f v) := by + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + rw [sum_mul_step] + simp only [dirichlet] + have hexp : ∀ p : G.V × G.D, (f p.1 - f (G.nbr p.1 p.2)) ^ 2 + = (f p.1) ^ 2 + (f (G.nbr p.1 p.2)) ^ 2 - 2 * (f p.1 * f (G.nbr p.1 p.2)) := fun p => by ring + rw [Finset.sum_congr rfl fun p _ => hexp p, Finset.sum_sub_distrib, Finset.sum_add_distrib, + ← Finset.mul_sum, G.sum_darts_fst (fun v => (f v) ^ 2), G.sum_darts_snd (fun v => (f v) ^ 2)] + field_simp + ring + +/-- The Dirichlet form is invariant under adding a constant. -/ +theorem dirichlet_sub_const (f : G.V → ℝ) (c : ℝ) : + G.dirichlet (fun v => f v - c) = G.dirichlet f := by + simp only [dirichlet] + refine Finset.sum_congr rfl fun p _ => ?_ + ring + +/-! ### Co-area -/ + +/-- The darts crossing out of or into `S`, counted with the boundary in both +directions. -/ +theorem sum_darts_boundary (S : Finset G.V) : + ∑ p : G.V × G.D, (if p.1 ∈ S ∧ G.nbr p.1 p.2 ∉ S then (1 : ℝ) else 0) + + ∑ p : G.V × G.D, (if p.1 ∉ S ∧ G.nbr p.1 p.2 ∈ S then (1 : ℝ) else 0) + = 2 * ((G.dartsBetween S Sᶜ).card : ℝ) := by + classical + have h1 : ∑ p : G.V × G.D, (if p.1 ∈ S ∧ G.nbr p.1 p.2 ∉ S then (1 : ℝ) else 0) + = ((G.dartsBetween S Sᶜ).card : ℝ) := by + rw [dartsBetween, Finset.card_filter] + push_cast + refine Finset.sum_congr rfl fun p _ => ?_ + simp [Finset.mem_compl] + have h2 : ∑ p : G.V × G.D, (if p.1 ∉ S ∧ G.nbr p.1 p.2 ∈ S then (1 : ℝ) else 0) + = ((G.dartsBetween S Sᶜ).card : ℝ) := by + rw [← h1, G.sum_darts_swap (fun u w => if u ∉ S ∧ w ∈ S then (1 : ℝ) else 0)] + refine Finset.sum_congr rfl fun p _ => ?_ + simp only [and_comm] + rw [h1, h2] + ring + +/-- The support of a function. -/ +noncomputable def support (ψ : G.V → ℝ) : Finset G.V := Finset.univ.filter fun v => ψ v ≠ 0 + +theorem mem_support_iff (ψ : G.V → ℝ) (v : G.V) : v ∈ G.support ψ ↔ ψ v ≠ 0 := by + simp [support] + +theorem eq_zero_of_notMem_support (ψ : G.V → ℝ) {v : G.V} (hv : v ∉ G.support ψ) : ψ v = 0 := by + by_contra h + exact hv ((G.mem_support_iff ψ v).2 h) + +/-- **Co-area.** For `ψ ≥ 0` supported on at most half the vertices, +`∑ |ψ u - ψ w| ≥ 2 h d ∑ ψ`. -/ +theorem coarea {h : ℝ} (hexp : G.EdgeExpansion h) : + ∀ (n : ℕ) (ψ : G.V → ℝ), (G.support ψ).card = n → (∀ v, 0 ≤ ψ v) + → 2 * (G.support ψ).card ≤ G.order + → 2 * h * (G.deg : ℝ) * ∑ v : G.V, ψ v + ≤ ∑ p : G.V × G.D, |ψ p.1 - ψ (G.nbr p.1 p.2)| := by + classical + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro ψ hn hpos hhalf + by_cases hemp : G.support ψ = ∅ + · -- everything vanishes + have hzero : ∀ v, ψ v = 0 := fun v => by + by_contra hv + have : v ∈ G.support ψ := by simp [support, hv] + rw [hemp] at this + exact absurd this (Finset.notMem_empty v) + simp [hzero] + · -- peel the lowest positive level + have hne : (G.support ψ).Nonempty := Finset.nonempty_iff_ne_empty.2 hemp + set S := G.support ψ with hS + have hmem : ∀ v, v ∈ S ↔ ψ v ≠ 0 := fun v => by rw [hS]; exact G.mem_support_iff ψ v + have hz : ∀ v, v ∉ S → ψ v = 0 := fun v hv => by + by_contra h + exact hv ((hmem v).2 h) + set μ := (S.image ψ).min' (hne.image ψ) with hμ + have hμmem : μ ∈ S.image ψ := Finset.min'_mem _ _ + obtain ⟨v₀, hv₀S, hv₀⟩ := Finset.mem_image.1 hμmem + have hμpos : 0 < μ := by + rw [← hv₀] + exact lt_of_le_of_ne (hpos v₀) (Ne.symm ((hmem v₀).1 hv₀S)) + have hμle : ∀ v ∈ S, μ ≤ ψ v := fun v hv => + Finset.min'_le _ _ (Finset.mem_image_of_mem ψ hv) + -- the peeled function + set ψ' : G.V → ℝ := fun v => if v ∈ S then ψ v - μ else 0 with hψ' + have hψ'in : ∀ v, v ∈ S → ψ' v = ψ v - μ := fun v hv => by simp [hψ', hv] + have hψ'out : ∀ v, v ∉ S → ψ' v = 0 := fun v hv => by simp [hψ', hv] + have hψ'pos : ∀ v, 0 ≤ ψ' v := fun v => by + by_cases hv : v ∈ S + · rw [hψ'in v hv]; linarith [hμle v hv] + · rw [hψ'out v hv] + have hψ'supp : G.support ψ' ⊆ S.erase v₀ := by + intro v hv + rw [G.mem_support_iff] at hv + rw [Finset.mem_erase] + by_cases hvS : v ∈ S + · refine ⟨fun hvv => ?_, hvS⟩ + rw [hψ'in v hvS, hvv, hv₀, sub_self] at hv + exact hv rfl + · rw [hψ'out v hvS] at hv + exact absurd rfl hv + have hcard' : (G.support ψ').card < n := by + rw [← hn] + calc (G.support ψ').card ≤ (S.erase v₀).card := Finset.card_le_card hψ'supp + _ < S.card := Finset.card_erase_lt_of_mem hv₀S + have hhalf' : 2 * (G.support ψ').card ≤ G.order := by + have := Finset.card_le_card hψ'supp + have h2 := Finset.card_erase_le (s := S) (a := v₀) + omega + have ihψ' := ih _ hcard' ψ' rfl hψ'pos hhalf' + -- relate the two functions + have hsum : ∑ v : G.V, ψ v = ∑ v : G.V, ψ' v + μ * S.card := by + have : ∀ v, ψ v = ψ' v + (if v ∈ S then μ else 0) := fun v => by + by_cases hv : v ∈ S + · rw [hψ'in v hv, if_pos hv]; ring + · rw [hψ'out v hv, if_neg hv, hz v hv]; ring + rw [Finset.sum_congr rfl fun v _ => this v, Finset.sum_add_distrib] + congr 1 + rw [Finset.sum_ite_mem, Finset.univ_inter, Finset.sum_const, nsmul_eq_mul, mul_comm] + have hdart : ∀ p : G.V × G.D, |ψ p.1 - ψ (G.nbr p.1 p.2)| + = |ψ' p.1 - ψ' (G.nbr p.1 p.2)| + + μ * ((if p.1 ∈ S ∧ G.nbr p.1 p.2 ∉ S then (1 : ℝ) else 0) + + (if p.1 ∉ S ∧ G.nbr p.1 p.2 ∈ S then (1 : ℝ) else 0)) := by + intro p + by_cases hu : p.1 ∈ S <;> by_cases hw : G.nbr p.1 p.2 ∈ S + · rw [hψ'in _ hu, hψ'in _ hw, if_neg (by tauto), if_neg (by tauto)] + have : ψ p.1 - μ - (ψ (G.nbr p.1 p.2) - μ) = ψ p.1 - ψ (G.nbr p.1 p.2) := by ring + rw [this] + ring + · rw [hψ'in _ hu, hψ'out _ hw, hz _ hw, if_pos ⟨hu, hw⟩, if_neg (by tauto), sub_zero, + sub_zero, abs_of_nonneg (hpos _), abs_of_nonneg (by linarith [hμle _ hu])] + ring + · rw [hψ'out _ hu, hψ'in _ hw, hz _ hu, if_neg (by tauto), if_pos ⟨hu, hw⟩, zero_sub, + zero_sub, abs_neg, abs_neg, abs_of_nonneg (hpos _), + abs_of_nonneg (by linarith [hμle _ hw])] + ring + · rw [hψ'out _ hu, hψ'out _ hw, hz _ hu, hz _ hw, if_neg (by tauto), if_neg (by tauto)] + simp + rw [Finset.sum_congr rfl fun p _ => hdart p, Finset.sum_add_distrib, ← Finset.mul_sum, + Finset.sum_add_distrib, G.sum_darts_boundary S, hsum] + have hexpS := hexp S hhalf + have hd : (0 : ℝ) ≤ G.deg := by positivity + nlinarith [ihψ', hexpS, hμpos, hd] + +/-! ### The core bound for small support -/ + +theorem support_sq (φ : G.V → ℝ) : G.support (fun v => (φ v) ^ 2) = G.support φ := by + ext v + simp [support, pow_eq_zero_iff] + +/-- **Small support.** For `φ ≥ 0` supported on at most half the vertices, +`h² d ‖φ‖² ≤ Dirichlet φ`. -/ +theorem dirichlet_ge_of_support {h : ℝ} (hexp : G.EdgeExpansion h) (hh : 0 ≤ h) + (φ : G.V → ℝ) (hpos : ∀ v, 0 ≤ φ v) (hhalf : 2 * (G.support φ).card ≤ G.order) : + h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2 ≤ G.dirichlet φ := by + classical + have hd : (0 : ℝ) < G.deg := by exact_mod_cast G.deg_pos + have hco := G.coarea hexp _ (fun v => (φ v) ^ 2) rfl (fun v => sq_nonneg _) + (by rw [support_sq]; exact hhalf) + -- `|a² - b²| = |a - b| (a + b)` for nonnegative `a, b` + have habs : ∀ p : G.V × G.D, |(φ p.1) ^ 2 - (φ (G.nbr p.1 p.2)) ^ 2| + = |φ p.1 - φ (G.nbr p.1 p.2)| * (φ p.1 + φ (G.nbr p.1 p.2)) := by + intro p + rw [sq_sub_sq, abs_mul, abs_of_nonneg (by linarith [hpos p.1, hpos (G.nbr p.1 p.2)])] + ring + rw [Finset.sum_congr rfl fun p _ => habs p] at hco + -- Cauchy–Schwarz + have hcs := Finset.sum_mul_sq_le_sq_mul_sq (Finset.univ : Finset (G.V × G.D)) + (fun p => |φ p.1 - φ (G.nbr p.1 p.2)|) (fun p => φ p.1 + φ (G.nbr p.1 p.2)) + simp only [sq_abs] at hcs + have hsumsq : ∑ p : G.V × G.D, (φ p.1 + φ (G.nbr p.1 p.2)) ^ 2 + ≤ 4 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2 := by + have : ∀ p : G.V × G.D, (φ p.1 + φ (G.nbr p.1 p.2)) ^ 2 + ≤ 2 * ((φ p.1) ^ 2 + (φ (G.nbr p.1 p.2)) ^ 2) := fun p => by + nlinarith [sq_nonneg (φ p.1 - φ (G.nbr p.1 p.2))] + calc ∑ p : G.V × G.D, (φ p.1 + φ (G.nbr p.1 p.2)) ^ 2 + ≤ ∑ p : G.V × G.D, 2 * ((φ p.1) ^ 2 + (φ (G.nbr p.1 p.2)) ^ 2) := + Finset.sum_le_sum fun p _ => this p + _ = 4 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2 := by + rw [← Finset.mul_sum, Finset.sum_add_distrib, G.sum_darts_fst (fun v => (φ v) ^ 2), + G.sum_darts_snd (fun v => (φ v) ^ 2)] + ring + have hS : 0 ≤ ∑ v : G.V, (φ v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + have hD : 0 ≤ G.dirichlet φ := G.dirichlet_nonneg φ + -- `dirichlet φ` is the first factor of Cauchy–Schwarz + have hDeq : ∑ p : G.V × G.D, (φ p.1 - φ (G.nbr p.1 p.2)) ^ 2 = G.dirichlet φ := rfl + rw [hDeq] at hcs + set A := 2 * h * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2 with hA + set B := ∑ p : G.V × G.D, |φ p.1 - φ (G.nbr p.1 p.2)| * (φ p.1 + φ (G.nbr p.1 p.2)) with hB + have hA0 : 0 ≤ A := by rw [hA]; positivity + have hAB : A ^ 2 ≤ B ^ 2 := by + have hB0 : 0 ≤ B := le_trans hA0 hco + nlinarith [hco, hA0, hB0] + have hkey : A ^ 2 ≤ G.dirichlet φ * (4 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2) := + le_trans hAB (le_trans hcs (mul_le_mul_of_nonneg_left hsumsq hD)) + rw [hA] at hkey + rcases hS.eq_or_lt with hS0 | hS0 + · rw [← hS0, mul_zero]; exact hD + · have h4 : 0 < 4 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2 := by positivity + have : (2 * h * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2) ^ 2 + = (h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2) + * (4 * (G.deg : ℝ) * ∑ v : G.V, (φ v) ^ 2) := by + ring + rw [this] at hkey + exact le_of_mul_le_mul_right hkey h4 + +/-! ### The median split -/ + +/-- **A median.** Some value has at most half the vertices strictly above it and at +most half strictly below. -/ +theorem exists_median (f : G.V → ℝ) : + ∃ c : ℝ, 2 * (Finset.univ.filter fun v => c < f v).card ≤ G.order + ∧ 2 * (Finset.univ.filter fun v => f v < c).card ≤ G.order := by + classical + rcases isEmpty_or_nonempty G.V with hV | hV + · exact ⟨0, by simp, by simp⟩ + haveI : Nonempty G.V := hV + set T : Finset ℝ := (Finset.univ.image f).filter + fun t => 2 * (Finset.univ.filter fun v => t < f v).card ≤ G.order with hT + have hTne : T.Nonempty := by + refine ⟨(Finset.univ.image f).max' (Finset.univ_nonempty.image f), ?_⟩ + rw [hT, Finset.mem_filter] + refine ⟨Finset.max'_mem _ _, ?_⟩ + have : (Finset.univ.filter fun v => + (Finset.univ.image f).max' (Finset.univ_nonempty.image f) < f v) = ∅ := by + rw [Finset.filter_eq_empty_iff] + intro v _ hlt + exact absurd (Finset.le_max' _ _ (Finset.mem_image_of_mem f (Finset.mem_univ v))) + (not_le.2 hlt) + rw [this] + simp + set c := T.min' hTne with hc + have hcT : c ∈ T := Finset.min'_mem _ _ + rw [hT, Finset.mem_filter] at hcT + refine ⟨c, hcT.2, ?_⟩ + by_contra hcon + push Not at hcon + -- the largest value below `c` would be a smaller member of `T` + set L := Finset.univ.filter fun v => f v < c with hL + have hLne : L.Nonempty := by + rw [← Finset.card_pos] + omega + set t' := (L.image f).max' (hLne.image f) with ht' + have ht'mem : t' ∈ L.image f := Finset.max'_mem _ _ + obtain ⟨v', hv'L, hv'⟩ := Finset.mem_image.1 ht'mem + have hv'c : f v' < c := by + have := hv'L + rw [hL, Finset.mem_filter] at this + exact this.2 + have ht'c : t' < c := by rw [← hv']; exact hv'c + -- `{f > t'} = {f ≥ c}` + have hset : (Finset.univ.filter fun v => t' < f v) = Finset.univ.filter fun v => ¬ f v < c := by + ext v + simp only [Finset.mem_filter, Finset.mem_univ, true_and, not_lt] + constructor + · intro hlt + by_contra hvc + push Not at hvc + have hvL : v ∈ L := by rw [hL, Finset.mem_filter]; exact ⟨Finset.mem_univ _, hvc⟩ + have := Finset.le_max' (L.image f) (f v) (Finset.mem_image_of_mem f hvL) + rw [← ht'] at this + linarith + · intro hge + linarith + have hcard : (Finset.univ.filter fun v => ¬ f v < c).card + L.card = G.order := by + have := Finset.card_filter_add_card_filter_not (s := (Finset.univ : Finset G.V)) + (fun v => f v < c) + rw [Finset.card_univ] at this + rw [hL, add_comm] + exact this + have ht'T : t' ∈ T := by + rw [hT, Finset.mem_filter] + refine ⟨?_, ?_⟩ + · rw [← hv'] + exact Finset.mem_image_of_mem f (Finset.mem_univ v') + · rw [hset] + omega + have := Finset.min'_le T t' ht'T + rw [← hc] at this + linarith + +theorem support_max_subset (g : G.V → ℝ) : + G.support (fun v => max (g v) 0) ⊆ Finset.univ.filter fun v => 0 < g v := by + intro v hv + rw [mem_support_iff] at hv + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + by_contra hle + push Not at hle + exact hv (max_eq_right hle) + +/-- **Cheeger's inequality, Dirichlet form.** For mean-zero `f`, +`h² d ‖f‖² ≤ Dirichlet f`. -/ +theorem dirichlet_ge_of_edgeExpansion {h : ℝ} (hexp : G.EdgeExpansion h) (hh : 0 ≤ h) + (f : G.V → ℝ) (hf : ∑ v : G.V, f v = 0) : + h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (f v) ^ 2 ≤ G.dirichlet f := by + classical + obtain ⟨c, hc₁, hc₂⟩ := G.exists_median f + set g : G.V → ℝ := fun v => f v - c with hg + set gp : G.V → ℝ := fun v => max (g v) 0 with hgp + set gm : G.V → ℝ := fun v => max (-g v) 0 with hgm + -- supports + have hsp : 2 * (G.support gp).card ≤ G.order := by + have : (G.support gp).card ≤ (Finset.univ.filter fun v => 0 < g v).card := + Finset.card_le_card (G.support_max_subset g) + have heq : (Finset.univ.filter fun v => 0 < g v) = Finset.univ.filter fun v => c < f v := by + ext v; simp [hg] + rw [heq] at this + omega + have hsm : 2 * (G.support gm).card ≤ G.order := by + have : (G.support gm).card ≤ (Finset.univ.filter fun v => 0 < -g v).card := + Finset.card_le_card (G.support_max_subset (fun v => -g v)) + have heq : (Finset.univ.filter fun v => 0 < -g v) = Finset.univ.filter fun v => f v < c := by + ext v; simp [hg] + rw [heq] at this + omega + have hp := G.dirichlet_ge_of_support hexp hh gp (fun v => le_max_right _ _) hsp + have hm := G.dirichlet_ge_of_support hexp hh gm (fun v => le_max_right _ _) hsm + -- squares split + have hsq : ∀ v, (g v) ^ 2 = (gp v) ^ 2 + (gm v) ^ 2 := by + intro v + simp only [hgp, hgm] + rcases le_total (g v) 0 with hle | hle + · rw [max_eq_right hle, max_eq_left (by linarith)]; ring + · rw [max_eq_left hle, max_eq_right (by linarith)]; ring + -- Dirichlet forms split, with slack + have hdir : G.dirichlet gp + G.dirichlet gm ≤ G.dirichlet g := by + simp only [dirichlet] + rw [← Finset.sum_add_distrib] + refine Finset.sum_le_sum fun p _ => ?_ + simp only [hgp, hgm] + rcases le_total (g p.1) 0 with h1 | h1 <;> rcases le_total (g (G.nbr p.1 p.2)) 0 with h2 | h2 + · rw [max_eq_right h1, max_eq_right h2, max_eq_left (by linarith), max_eq_left (by linarith)] + nlinarith + · rw [max_eq_right h1, max_eq_left h2, max_eq_left (by linarith), max_eq_right (by linarith)] + nlinarith [mul_nonpos_iff.2 (Or.inr ⟨h1, h2⟩)] + · rw [max_eq_left h1, max_eq_right h2, max_eq_right (by linarith), max_eq_left (by linarith)] + nlinarith [mul_nonpos_iff.2 (Or.inl ⟨h1, h2⟩)] + · rw [max_eq_left h1, max_eq_left h2, max_eq_right (by linarith), max_eq_right (by linarith)] + nlinarith + -- `‖g‖² ≥ ‖f‖²` + have hnorm : ∑ v : G.V, (f v) ^ 2 ≤ ∑ v : G.V, (g v) ^ 2 := by + have : ∀ v, (g v) ^ 2 = (f v) ^ 2 - 2 * c * f v + c ^ 2 := fun v => by + simp only [hg]; ring + rw [Finset.sum_congr rfl fun v _ => this v, Finset.sum_add_distrib, Finset.sum_sub_distrib, + ← Finset.mul_sum, hf] + have : 0 ≤ ∑ _v : G.V, c ^ 2 := Finset.sum_nonneg fun _ _ => sq_nonneg _ + linarith + have hdirg : G.dirichlet g = G.dirichlet f := G.dirichlet_sub_const f c + have hsplit : ∑ v : G.V, (g v) ^ 2 = ∑ v : G.V, (gp v) ^ 2 + ∑ v : G.V, (gm v) ^ 2 := by + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun v _ => hsq v + have hd : (0 : ℝ) ≤ h ^ 2 * G.deg := by positivity + calc h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (f v) ^ 2 + ≤ h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (g v) ^ 2 := mul_le_mul_of_nonneg_left hnorm hd + _ = h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (gp v) ^ 2 + + h ^ 2 * (G.deg : ℝ) * ∑ v : G.V, (gm v) ^ 2 := by rw [hsplit]; ring + _ ≤ G.dirichlet gp + G.dirichlet gm := add_le_add hp hm + _ ≤ G.dirichlet g := hdir + _ = G.dirichlet f := hdirg + +/-! ### The lazy walk -/ + +/-- The lazy quadratic form, as an inner product of dart sums. -/ +noncomputable def lazyQ (f g : G.V → ℝ) : ℝ := + ∑ p : G.V × G.D, (f p.1 + f (G.nbr p.1 p.2)) * (g p.1 + g (G.nbr p.1 p.2)) + +theorem step_lazy (f : G.V → ℝ) (v : G.V) : + (G.padLoops G.deg).step f v = (G.step f v + f v) / 2 := by + rw [step_padLoops] + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + field_simp + ring + +/-- **The lazy step against a function is the lazy form.** -/ +theorem sum_lazy_mul (f g : G.V → ℝ) : + ∑ v : G.V, (G.padLoops G.deg).step f v * g v = G.lazyQ f g / (4 * (G.deg : ℝ)) := by + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + simp only [step_lazy, lazyQ] + have hexp : ∀ p : G.V × G.D, (f p.1 + f (G.nbr p.1 p.2)) * (g p.1 + g (G.nbr p.1 p.2)) + = f p.1 * g p.1 + f (G.nbr p.1 p.2) * g (G.nbr p.1 p.2) + + (f p.1 * g (G.nbr p.1 p.2) + f (G.nbr p.1 p.2) * g p.1) := fun p => by ring + rw [Finset.sum_congr rfl fun p _ => hexp p, Finset.sum_add_distrib, Finset.sum_add_distrib, + Finset.sum_add_distrib, G.sum_darts_fst (fun v => f v * g v), + G.sum_darts_snd (fun v => f v * g v), G.sum_darts_swap (fun u w => f w * g u)] + have h1 : ∑ v : G.V, (G.step f v + f v) / 2 * g v + = (∑ v : G.V, g v * G.step f v + ∑ v : G.V, f v * g v) / 2 := by + rw [← Finset.sum_add_distrib, Finset.sum_div] + exact Finset.sum_congr rfl fun v _ => by ring + have hswap : ∑ p : G.V × G.D, g p.1 * f (G.nbr p.1 p.2) + = ∑ p : G.V × G.D, f p.1 * g (G.nbr p.1 p.2) := by + rw [G.sum_darts_swap (fun u w => g u * f w)] + exact Finset.sum_congr rfl fun p _ => mul_comm _ _ + rw [h1, sum_mul_step, hswap] + field_simp + ring + +theorem lazyQ_self (f : G.V → ℝ) : + G.lazyQ f f = 4 * (G.deg : ℝ) * ∑ v : G.V, (f v) ^ 2 - G.dirichlet f := by + simp only [lazyQ, dirichlet] + have : ∀ p : G.V × G.D, (f p.1 + f (G.nbr p.1 p.2)) * (f p.1 + f (G.nbr p.1 p.2)) + = 2 * ((f p.1) ^ 2 + (f (G.nbr p.1 p.2)) ^ 2) - (f p.1 - f (G.nbr p.1 p.2)) ^ 2 := + fun p => by ring + rw [Finset.sum_congr rfl fun p _ => this p, Finset.sum_sub_distrib, ← Finset.mul_sum, + Finset.sum_add_distrib, G.sum_darts_fst (fun v => (f v) ^ 2), + G.sum_darts_snd (fun v => (f v) ^ 2)] + ring + +theorem lazyQ_nonneg (f : G.V → ℝ) : 0 ≤ G.lazyQ f f := + Finset.sum_nonneg fun _ _ => mul_self_nonneg _ + +theorem lazyQ_sq_le (f g : G.V → ℝ) : (G.lazyQ f g) ^ 2 ≤ G.lazyQ f f * G.lazyQ g g := by + have := Finset.sum_mul_sq_le_sq_mul_sq (Finset.univ : Finset (G.V × G.D)) + (fun p => f p.1 + f (G.nbr p.1 p.2)) (fun p => g p.1 + g (G.nbr p.1 p.2)) + simp only [lazyQ, sq] at this ⊢ + exact this + +theorem sum_lazy_step (f : G.V → ℝ) : + ∑ v : G.V, (G.padLoops G.deg).step f v = ∑ v : G.V, f v := by + simp only [step_lazy] + rw [← Finset.sum_div, Finset.sum_add_distrib, sum_step] + ring + +/-- **Cheeger's inequality, spectral form.** Edge expansion `h` gives the lazy +graph — `d` self-loops added — the spectral bound `1 - h² / 4`. -/ +theorem spectralBound_padLoops_of_edgeExpansion {h : ℝ} (hexp : G.EdgeExpansion h) (hh : 0 ≤ h) : + (G.padLoops G.deg).SpectralBound (1 - h ^ 2 / 4) := by + intro f hf + have hd : (0 : ℝ) < G.deg := by exact_mod_cast G.deg_pos + set B : G.V → ℝ := (G.padLoops G.deg).step f with hB + have hBmean : ∑ v : G.V, B v = 0 := by rw [hB, sum_lazy_step]; exact hf + -- the Rayleigh bound, on `f` and on `B f` + have hray : ∀ g : G.V → ℝ, ∑ v : G.V, g v = 0 → + G.lazyQ g g ≤ (4 * (G.deg : ℝ) * (1 - h ^ 2 / 4)) * ∑ v : G.V, (g v) ^ 2 := by + intro g hg + rw [lazyQ_self] + have := G.dirichlet_ge_of_edgeExpansion hexp hh g hg + linarith + have hf' := hray f hf + have hB' := hray B hBmean + -- `‖B f‖²` through the lazy form + have hBB : ∑ v : G.V, (B v) ^ 2 = G.lazyQ f B / (4 * (G.deg : ℝ)) := by + rw [← sum_lazy_mul, hB] + exact Finset.sum_congr rfl fun v _ => by ring + have hcs := G.lazyQ_sq_le f B + have hQf := G.lazyQ_nonneg f + have hQB := G.lazyQ_nonneg B + have hSf : 0 ≤ ∑ v : G.V, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + have hSB : 0 ≤ ∑ v : G.V, (B v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + show ∑ v : G.V, (B v) ^ 2 ≤ (1 - h ^ 2 / 4) ^ 2 * ∑ v : G.V, (f v) ^ 2 + set lam := 1 - h ^ 2 / 4 with hlam + have hprod : G.lazyQ f f * G.lazyQ B B + ≤ (4 * (G.deg : ℝ) * lam * ∑ v : G.V, (f v) ^ 2) + * (4 * (G.deg : ℝ) * lam * ∑ v : G.V, (B v) ^ 2) := + mul_le_mul hf' hB' hQB (le_trans hQf hf') + have hQfB : G.lazyQ f B = 4 * (G.deg : ℝ) * ∑ v : G.V, (B v) ^ 2 := by + rw [hBB]; field_simp + rw [hQfB] at hcs + have hkey : (4 * (G.deg : ℝ)) ^ 2 * (∑ v : G.V, (B v) ^ 2) ^ 2 + ≤ (4 * (G.deg : ℝ)) ^ 2 * (lam ^ 2 * ∑ v : G.V, (f v) ^ 2) * ∑ v : G.V, (B v) ^ 2 := by + nlinarith [hcs, hprod] + rcases hSB.eq_or_lt with h0 | h0 + · rw [← h0]; positivity + · have h16 : 0 < (4 * (G.deg : ℝ)) ^ 2 * ∑ v : G.V, (B v) ^ 2 := by positivity + have : (4 * (G.deg : ℝ)) ^ 2 * (∑ v : G.V, (B v) ^ 2) ^ 2 + = ((4 * (G.deg : ℝ)) ^ 2 * ∑ v : G.V, (B v) ^ 2) * ∑ v : G.V, (B v) ^ 2 := by ring + rw [this] at hkey + have : (4 * (G.deg : ℝ)) ^ 2 * (lam ^ 2 * ∑ v : G.V, (f v) ^ 2) * ∑ v : G.V, (B v) ^ 2 + = ((4 * (G.deg : ℝ)) ^ 2 * ∑ v : G.V, (B v) ^ 2) * (lam ^ 2 * ∑ v : G.V, (f v) ^ 2) := by + ring + rw [this] at hkey + exact le_of_mul_le_mul_left hkey h16 + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Clique.lean b/Complexitylib/Classes/PCP/Internal/Clique.lean new file mode 100644 index 00000000..d8a1f709 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Clique.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.WalkPath + +/-! +# The complete graph with self-loops + +The simplest nontrivial `RegGraph`: `n` vertices, degree `n`, with the `i`-th +neighbour of every vertex being `i`. Its rotation map is the swap, so every +vertex is joined to every vertex including itself. + +It is a *perfect* expander: one step of its walk lands on the uniform +distribution, so the walk operator annihilates mean-zero functions and +`SpectralBound 0` holds. This validates the definitions in `RegularGraph` on a +case where the answer is known, and supplies the loops that `WalkPath` needs. + +## Main definitions + +- `RegGraph.cliqueLoops` — the complete graph with all self-loops +- `RegGraph.cliqueLoopsLoops` — its canonical self-loop at each vertex + +## Main results + +- `RegGraph.nbr_cliqueLoops`, `RegGraph.step_cliqueLoops` +- `RegGraph.spectralBound_cliqueLoops` — a spectral bound of `0` +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +/-- The complete graph on `n` vertices with a self-loop at every vertex, +presented by the swap rotation map: the `i`-th neighbour of `v` is `i`. -/ +def cliqueLoops (n : ℕ) (hn : 0 < n) : RegGraph where + V := Fin n + D := Fin n + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨⟨0, hn⟩⟩ + rot p := (p.2, p.1) + rot_involutive _ := rfl + +@[simp] theorem V_cliqueLoops (n : ℕ) (hn : 0 < n) : (cliqueLoops n hn).V = Fin n := rfl + +@[simp] theorem D_cliqueLoops (n : ℕ) (hn : 0 < n) : (cliqueLoops n hn).D = Fin n := rfl + +@[simp] theorem deg_cliqueLoops (n : ℕ) (hn : 0 < n) : (cliqueLoops n hn).deg = n := + Fintype.card_fin n + +@[simp] theorem order_cliqueLoops (n : ℕ) (hn : 0 < n) : (cliqueLoops n hn).order = n := + Fintype.card_fin n + +@[simp] theorem nbr_cliqueLoops {n : ℕ} (hn : 0 < n) (v : (cliqueLoops n hn).V) + (i : (cliqueLoops n hn).D) : (cliqueLoops n hn).nbr v i = i := rfl + +/-- Every vertex of the complete graph with loops has a self-loop, namely its +own index. -/ +def cliqueLoopsLoops (n : ℕ) (hn : 0 < n) : (cliqueLoops n hn).Loops where + loop v := v + rot_loop _ := rfl + +/-- One step of the walk lands on the uniform distribution: the average of `f` +over all vertices, whatever the current vertex. -/ +theorem step_cliqueLoops {n : ℕ} (hn : 0 < n) (f : (cliqueLoops n hn).V → ℝ) + (v : (cliqueLoops n hn).V) : + (cliqueLoops n hn).step f v + = (∑ w : (cliqueLoops n hn).V, f w) / ((cliqueLoops n hn).deg : ℝ) := by + simp only [step] + rfl + +/-- The complete graph with loops is a perfect expander. -/ +theorem spectralBound_cliqueLoops {n : ℕ} (hn : 0 < n) : + (cliqueLoops n hn).SpectralBound 0 := by + intro f hf + have hstep : ∀ v : (cliqueLoops n hn).V, (cliqueLoops n hn).step f v = 0 := by + intro v + rw [step_cliqueLoops hn f v, hf, zero_div] + simp [hstep] + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CloudCount.lean b/Complexitylib/Classes/PCP/Internal/CloudCount.lean new file mode 100644 index 00000000..34bceba1 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CloudCount.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.DegreeReduction +public import Complexitylib.Classes.PCP.Internal.RankCount + +/-! +# A cloud, by counting + +Degree reduction rotates inside a cloud through the cloud's enumeration: the +half-edge it starts from is located by `List.idxOf`, and the one it lands on is +read off by position. Neither operation is available to an algorithm, which can +only count. This module replaces both by counts of half-edge numbers. + +The cloud is enumerated in order of those numbers, so a half-edge's position is +the number of smaller numbers in the cloud, and the half-edge at a position is +the one whose number has that many smaller numbers below it. + +## Main definitions + +- `Complexity.ConstraintGraph.cloudCodes` — the numbers of a cloud's half-edges + +## Main results + +- `Complexity.ConstraintGraph.idxOf_cloudList` — the position is a count +- `Complexity.ConstraintGraph.halfCode_getElem_cloudList` — and the entry at a + position is named by the count that reaches it +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α : Type} (G : ConstraintGraph α) + +/-- The numbers of the half-edges attached to a vertex. -/ +noncomputable def cloudCodes (v : Fin G.numVerts) : Finset ℕ := (G.cloud v).image G.halfCode + +@[simp] theorem mem_cloudCodes {v : Fin G.numVerts} {c : ℕ} : + c ∈ G.cloudCodes v ↔ ∃ p, G.owner p = v ∧ G.halfCode p = c := by + rw [cloudCodes, Finset.mem_image] + constructor + · rintro ⟨p, hp, rfl⟩ + exact ⟨p, (G.mem_cloud).mp hp, rfl⟩ + · rintro ⟨p, hp, rfl⟩ + exact ⟨p, (G.mem_cloud).mpr hp, rfl⟩ + +@[simp] theorem card_cloudCodes (v : Fin G.numVerts) : + (G.cloudCodes v).card = (G.cloud v).card := + Finset.card_image_of_injective _ G.halfCode_injective + +@[simp] theorem length_cloudList (v : Fin G.numVerts) : + (G.cloudList v).length = (G.cloud v).card := Finset.length_sort _ + +/-- Counting the smaller numbers of a cloud is counting its smaller +half-edges. -/ +theorem countBelow_cloudCodes (v : Fin G.numVerts) (c : ℕ) : + countBelow (G.cloudCodes v) c + = ((G.cloud v).filter fun q => G.halfCode q < c).card := by + classical + rw [countBelow, cloudCodes, Finset.filter_image] + exact Finset.card_image_of_injective _ G.halfCode_injective + +/-- **A half-edge's position in its cloud is a count.** -/ +theorem idxOf_cloudList {v : Fin G.numVerts} {p : G.HalfEdge} (hp : G.owner p = v) : + (G.cloudList v).idxOf p = countBelow (G.cloudCodes v) (G.halfCode p) := by + have hmem : p ∈ G.cloudList v := (G.mem_cloudList).mpr ((G.mem_cloud).mpr hp) + have hinj : ∀ x ∈ G.cloudList v, ∀ y ∈ G.cloudList v, G.halfCode x = G.halfCode y → x = y := + fun x _ y _ h => G.halfCode_injective h + have h1 : (G.cloudList v).idxOf p + = (G.cloudList v).countP (fun q => decide (G.halfCode q < G.halfCode p)) := + idxOf_eq_countP (G.pairwise_cloudList v) hinj hmem + rw [h1, countBelow_cloudCodes, List.countP_eq_length_filter] + have hnd : ((G.cloudList v).filter fun q => decide (G.halfCode q < G.halfCode p)).Nodup := + (G.nodup_cloudList v).filter _ + rw [← List.toFinset_card_of_nodup hnd] + congr 1 + ext q + simp only [List.mem_toFinset, List.mem_filter, Finset.mem_filter, mem_cloudList, + decide_eq_true_eq] + +theorem card_cloudCodes_eq_length (v : Fin G.numVerts) : + (G.cloudCodes v).card = (G.cloudList v).length := by + rw [card_cloudCodes, length_cloudList] + +/-- **The half-edge at a position is named by the count that reaches it.** -/ +theorem halfCode_getElem_cloudList (v : Fin G.numVerts) (k : ℕ) + (hk : k < (G.cloudList v).length) : + (G.cloudCodes v).orderEmbOfFin (G.card_cloudCodes_eq_length v) ⟨k, hk⟩ + = G.halfCode ((G.cloudList v)[k]) := by + classical + have hmem : (G.cloudList v)[k] ∈ G.cloudList v := List.getElem_mem hk + have howner : G.owner ((G.cloudList v)[k]) = v := + (G.mem_cloud).mp ((G.mem_cloudList).mp hmem) + have hcode : G.halfCode ((G.cloudList v)[k]) ∈ G.cloudCodes v := + (G.mem_cloudCodes).mpr ⟨_, howner, rfl⟩ + have hidx : (G.cloudList v).idxOf ((G.cloudList v)[k]) = k := + (G.nodup_cloudList v).idxOf_getElem _ hk + refine orderEmbOfFin_eq_of_countBelow (G.card_cloudCodes_eq_length v) _ hcode ?_ + rw [← G.idxOf_cloudList howner, hidx] + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean b/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean new file mode 100644 index 00000000..75f88b58 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean @@ -0,0 +1,316 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.DegreeReduction +public import Complexitylib.Classes.PCP.Internal.EdgeExpansion +public import Complexitylib.Classes.PCP.Internal.FinsetPlurality +public import Mathlib.Algebra.Order.Field.Basic + +/-! +# Charging disagreement inside a cloud + +The soundness half of Dinur's degree reduction, one cloud at a time. + +An assignment of the reduced system labels half-edges, not vertices. It is +decoded back to a vertex assignment by **plurality**: `decode A v` is a label +that at least a `1 / card α` fraction of `v`'s cloud agrees with. The +half-edges of the cloud that *disagree* form a set the cloud's expander must +charge for: by edge expansion, the disagreeing set sends out many cloud-links, +and every one of them joins two half-edges with different labels, so every one +of them is an unsatisfied constraint. + +Everything is phrased at the level of a cloud's *enumeration* `cloudList v`, so +that the expander family — which lives on `Fin n` — applies directly, with +`cloudRot_getElem` as the only bridge back to half-edges. + +## Main definitions + +- `ConstraintGraph.decode` — the plurality label of a cloud +- `ConstraintGraph.devIdx` — the indices of a cloud that disagree with it +- `ConstraintGraph.cloudUnsat` — the unsatisfied cloud-links sitting at a vertex + +## Main results + +- `ConstraintGraph.length_le_card_agree` — plurality: the agreeing part of a + cloud is at least a `1 / card α` fraction of it +- `ConstraintGraph.card_dartsBetween_le_card_cloudUnsat` — every expander + boundary dart of the disagreeing set is an unsatisfied cloud-link +- `ConstraintGraph.cloud_disagreement_bound` — the resulting charge: + `(1 - lam) · degree · |dev| / card α` unsatisfied links at `v` +- `ConstraintGraph.total_cloud_charge` — summed over the vertices, since the + clouds' bills never overlap +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] +variable (G : ConstraintGraph α) (E : ExpanderFamily) + +/-! ### Plurality decoding -/ + +/-- The plurality label of `v`'s cloud: a label at least a `1 / card α` +fraction of the cloud agrees with. -/ +noncomputable def decode (A : G.HalfEdge → α) (v : Fin G.numVerts) : α := + Classical.choose (exists_plurality (Finset.univ : Finset (Fin (G.cloudList v).length)) + fun i => A (G.cloudList v)[i.val]) + +/-- The indices of `v`'s cloud whose labels disagree with the plurality. -/ +noncomputable def devIdx (A : G.HalfEdge → α) (v : Fin G.numVerts) : + Finset (Fin (G.cloudList v).length) := + Finset.univ.filter fun i => A (G.cloudList v)[i.val] ≠ G.decode A v + +theorem mem_devIdx {A : G.HalfEdge → α} {v : Fin G.numVerts} + {i : Fin (G.cloudList v).length} : + i ∈ G.devIdx A v ↔ A (G.cloudList v)[i.val] ≠ G.decode A v := by + simp [devIdx] + +theorem mem_compl_devIdx {A : G.HalfEdge → α} {v : Fin G.numVerts} + {i : Fin (G.cloudList v).length} : + i ∈ (G.devIdx A v)ᶜ ↔ A (G.cloudList v)[i.val] = G.decode A v := by + simp [devIdx] + +/-- **Plurality.** The part of a cloud agreeing with its decoded label is at +least a `1 / card α` fraction of the cloud. -/ +theorem length_le_card_agree (A : G.HalfEdge → α) (v : Fin G.numVerts) : + (G.cloudList v).length ≤ Fintype.card α * ((G.devIdx A v)ᶜ).card := by + have h := Classical.choose_spec + (exists_plurality (Finset.univ : Finset (Fin (G.cloudList v).length)) + fun i => A (G.cloudList v)[i.val]) + simpa [devIdx, decode, Finset.compl_filter, not_not] using h + +/-! ### From cloud indices to half-edges -/ + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- A cloud's filtered subset is the image of the corresponding index set. -/ +theorem cloud_filter_eq_image (v : Fin G.numVerts) (P : G.HalfEdge → Prop) [DecidablePred P] : + (G.cloud v).filter P + = (Finset.univ.filter fun i : Fin (G.cloudList v).length => + P (G.cloudList v)[i.val]).image fun i => (G.cloudList v)[i.val] := by + ext p + simp only [Finset.mem_filter, Finset.mem_image, Finset.mem_univ, true_and] + constructor + · rintro ⟨hp, hP⟩ + have hmem : p ∈ G.cloudList v := (G.mem_cloudList).mpr hp + have hlt : (G.cloudList v).idxOf p < (G.cloudList v).length := + List.idxOf_lt_length_iff.mpr hmem + have hget : (G.cloudList v)[(G.cloudList v).idxOf p] = p := List.getElem_idxOf hlt + exact ⟨⟨(G.cloudList v).idxOf p, hlt⟩, by rw [hget]; exact hP, hget⟩ + · rintro ⟨i, hP, rfl⟩ + exact ⟨(G.mem_cloudList).mp (List.getElem_mem i.isLt), hP⟩ + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- Counting inside a cloud is the same through its enumeration. -/ +theorem card_filter_cloud (v : Fin G.numVerts) (P : G.HalfEdge → Prop) [DecidablePred P] : + (Finset.univ.filter fun i : Fin (G.cloudList v).length => + P (G.cloudList v)[i.val]).card = ((G.cloud v).filter P).card := by + rw [G.cloud_filter_eq_image v P, Finset.card_image_of_injOn] + intro i _ j _ h + exact Fin.ext ((G.nodup_cloudList v).getElem_inj_iff.mp h) + +/-- The half-edges whose label disagrees with their vertex's decoded label. -/ +noncomputable def devSet (A : G.HalfEdge → α) : Finset G.HalfEdge := + Finset.univ.filter fun p => A p ≠ G.decode A (G.owner p) + +theorem mem_devSet {A : G.HalfEdge → α} {p : G.HalfEdge} : + p ∈ G.devSet A ↔ A p ≠ G.decode A (G.owner p) := by + simp [devSet] + +/-- A cloud's disagreeing indices count the same as its disagreeing +half-edges. -/ +theorem card_devIdx_eq (A : G.HalfEdge → α) (v : Fin G.numVerts) : + (G.devIdx A v).card = ((G.devSet A).filter fun p => G.owner p = v).card := by + have hset : (G.cloud v).filter (fun p => A p ≠ G.decode A v) + = (G.devSet A).filter fun p => G.owner p = v := by + ext p + simp only [Finset.mem_filter, mem_cloud, mem_devSet] + constructor + · rintro ⟨hv, hne⟩ + exact ⟨by rw [hv]; exact hne, hv⟩ + · rintro ⟨hne, hv⟩ + exact ⟨hv, by rw [← hv]; exact hne⟩ + rw [devIdx, G.card_filter_cloud v fun p => A p ≠ G.decode A v, hset] + +/-- Summed over the vertices, the cloud charges account for every disagreeing +half-edge exactly once. -/ +theorem sum_card_devIdx (A : G.HalfEdge → α) : + ∑ v : Fin G.numVerts, (G.devIdx A v).card = (G.devSet A).card := by + have h : (G.devSet A).card + = ∑ v : Fin G.numVerts, ((G.devSet A).filter fun p => G.owner p = v).card := + Finset.card_eq_sum_card_fiberwise fun p _ => Finset.mem_univ (G.owner p) + rw [h] + exact Finset.sum_congr rfl fun v _ => G.card_devIdx_eq A v + +/-! ### Unsatisfied cloud-links -/ + +/-- The unsatisfied cloud-links of the reduced system sitting at `v`. -/ +noncomputable def cloudUnsat (A : (G.reduce E).Assignment) (v : Fin G.numVerts) : + Finset (G.reduce E).Dart := + ((G.reduce E).unsatDarts A).filter fun x => G.owner x.1 = v ∧ x.2 ≠ none + +omit [Fintype α] [Nonempty α] in +theorem cloudUnsat_subset (A : (G.reduce E).Assignment) (v : Fin G.numVerts) : + G.cloudUnsat E A v ⊆ (G.reduce E).unsatDarts A := + Finset.filter_subset _ _ + +omit [Fintype α] [Nonempty α] in +/-- The clouds' unsatisfied links are disjoint: a dart's tail determines the +vertex it sits at. -/ +theorem cloudUnsat_disjoint (A : (G.reduce E).Assignment) {u v : Fin G.numVerts} (huv : u ≠ v) : + Disjoint (G.cloudUnsat E A u) (G.cloudUnsat E A v) := by + refine Finset.disjoint_left.mpr fun x hx hx' => ?_ + rw [cloudUnsat, Finset.mem_filter] at hx hx' + exact huv (hx.2.1.symm.trans hx'.2.1) + +/-- Every boundary dart of the disagreeing set is an unsatisfied cloud-link: +its two ends carry different labels, one being the plurality and one not. -/ +theorem card_dartsBetween_le_card_cloudUnsat (A : (G.reduce E).Assignment) + (v : Fin G.numVerts) : + ((E.graph (G.cloudList v).length).dartsBetween (G.devIdx A v) (G.devIdx A v)ᶜ).card + ≤ (G.cloudUnsat E A v).card := by + refine Finset.card_le_card_of_injOn + (fun x => ((G.cloudList v)[x.1.val], some x.2)) ?_ ?_ + · intro x hx + simp only [Finset.mem_coe] at hx ⊢ + rw [RegGraph.dartsBetween, Finset.mem_filter] at hx + obtain ⟨-, hx1, hx2⟩ := hx + have hnbr : (E.graph (G.cloudList v).length).nbr x.1 x.2 + = (E.rot (G.cloudList v).length (x.1, x.2)).1 := rfl + rw [hnbr] at hx2 + have hdev : A (G.cloudList v)[x.1.val] ≠ G.decode A v := (G.mem_devIdx).mp hx1 + have hagree : A (G.cloudList v)[(E.rot (G.cloudList v).length (x.1, x.2)).1.val] + = G.decode A v := (G.mem_compl_devIdx).mp hx2 + have howner : G.owner (G.cloudList v)[x.1.val] = v := + (G.mem_cloud).mp ((G.mem_cloudList).mp (List.getElem_mem x.1.isLt)) + rw [cloudUnsat, Finset.mem_filter] + refine ⟨?_, howner, by simp⟩ + rw [RegCSP.mem_unsatDarts] + show ¬ ((A (G.cloudList v)[x.1.val] + == A ((G.reduce E).graph.nbr (G.cloudList v)[x.1.val] (some x.2))) = true) + have hstep : (G.reduce E).graph.nbr (G.cloudList v)[x.1.val] (some x.2) + = (G.cloudList v)[(E.rot (G.cloudList v).length (x.1, x.2)).1.val] := by + show (G.cloudRot E (G.cloudList v)[x.1.val] x.2).1 = _ + rw [G.cloudRot_getElem E v x.1 x.2] + rw [hstep, hagree] + simpa using hdev + · intro x _ y _ hxy + have h1 : (G.cloudList v)[x.1.val] = (G.cloudList v)[y.1.val] := congrArg Prod.fst hxy + have h2 : x.2 = y.2 := by + have h := congrArg Prod.snd hxy + exact Option.some.inj h + have h3 : x.1 = y.1 := + Fin.ext ((G.nodup_cloudList v).getElem_inj_iff.mp h1) + exact Prod.ext h3 h2 + +/-! ### The charge -/ + +/-- **The cloud charge.** The disagreeing part of `v`'s cloud is billed +`(1 - lam) · degree / card α` unsatisfied cloud-links per disagreeing +half-edge. -/ +theorem cloud_disagreement_bound (A : (G.reduce E).Assignment) (v : Fin G.numVerts) : + (1 - E.lam) * (E.degree : ℝ) * ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ) + ≤ ((G.cloudUnsat E A v).card : ℝ) := by + rcases Nat.eq_zero_or_pos (G.cloudList v).length with hlen | hlen + · have hempty : G.devIdx A v = ∅ := by + apply Finset.eq_empty_of_forall_notMem + intro i + exact absurd i.isLt (by omega) + rw [hempty] + simp + · have hordpos : 0 < (E.graph (G.cloudList v).length).order := by + rw [E.order_graph]; exact hlen + have hexp := (E.graph (G.cloudList v).length).card_dartsBetween_compl_ge + E.lam_nonneg (E.spectral_graph _) hordpos (G.devIdx A v) + rw [E.deg_graph, E.order_graph] at hexp + have hinj := G.card_dartsBetween_le_card_cloudUnsat E A v + have hinjR : (((E.graph (G.cloudList v).length).dartsBetween (G.devIdx A v) + (G.devIdx A v)ᶜ).card : ℝ) ≤ ((G.cloudUnsat E A v).card : ℝ) := by + exact_mod_cast hinj + refine le_trans ?_ (le_trans hexp hinjR) + -- plurality: `|devᶜ| ≥ length / card α` + have hlenq : (0 : ℝ) < ((G.cloudList v).length : ℝ) := by exact_mod_cast hlen + have hcardq : (0 : ℝ) < (Fintype.card α : ℝ) := by + exact_mod_cast (Fintype.card_pos (α := α)) + have hplur : ((G.cloudList v).length : ℝ) + ≤ (Fintype.card α : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ) := by + exact_mod_cast G.length_le_card_agree A v + have hlam : 0 ≤ 1 - E.lam := by linarith [E.lam_lt_one] + have hdeg : (0 : ℝ) ≤ (E.degree : ℝ) := by positivity + have hdev : (0 : ℝ) ≤ ((G.devIdx A v).card : ℝ) := by positivity + have hkey : ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ) + ≤ ((G.devIdx A v).card : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ) + / ((G.cloudList v).length : ℝ) := by + have hnum : ((G.devIdx A v).card : ℝ) * ((G.cloudList v).length : ℝ) + ≤ (((G.devIdx A v).card : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ)) + * (Fintype.card α : ℝ) := by + nlinarith [hplur, hdev] + calc ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ) + = (((G.devIdx A v).card : ℝ) * ((G.cloudList v).length : ℝ)) + / ((Fintype.card α : ℝ) * ((G.cloudList v).length : ℝ)) := by + field_simp + _ ≤ ((((G.devIdx A v).card : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ)) + * (Fintype.card α : ℝ)) + / ((Fintype.card α : ℝ) * ((G.cloudList v).length : ℝ)) := by + gcongr + _ = ((G.devIdx A v).card : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ) + / ((G.cloudList v).length : ℝ) := by + field_simp + calc (1 - E.lam) * (E.degree : ℝ) * ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ) + = (1 - E.lam) * (E.degree : ℝ) + * (((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ)) := by ring + _ ≤ (1 - E.lam) * (E.degree : ℝ) + * (((G.devIdx A v).card : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ) + / ((G.cloudList v).length : ℝ)) := by + have : (0 : ℝ) ≤ (1 - E.lam) * (E.degree : ℝ) := by positivity + exact mul_le_mul_of_nonneg_left hkey this + +/-! ### The total charge -/ + +omit [Fintype α] [Nonempty α] in +/-- The clouds' unsatisfied links are disjoint subsets of all the unsatisfied +darts, so their counts add up to at most the whole. -/ +theorem sum_card_cloudUnsat_le (A : (G.reduce E).Assignment) : + ∑ v : Fin G.numVerts, (G.cloudUnsat E A v).card ≤ (((G.reduce E).unsatDarts A)).card := by + have hdisj : ∀ u ∈ (Finset.univ : Finset (Fin G.numVerts)), + ∀ v ∈ (Finset.univ : Finset (Fin G.numVerts)), u ≠ v → + Disjoint (G.cloudUnsat E A u) (G.cloudUnsat E A v) := + fun u _ v _ h => G.cloudUnsat_disjoint E A h + rw [← Finset.card_biUnion hdisj] + refine Finset.card_le_card ?_ + intro x hx + rw [Finset.mem_biUnion] at hx + obtain ⟨v, -, hxv⟩ := hx + exact G.cloudUnsat_subset E A v hxv + +/-- **The total cloud charge.** Every disagreeing half-edge is billed +`(1 - lam) · degree / card α` unsatisfied cloud-links, and the bills for +different vertices never overlap. -/ +theorem total_cloud_charge (A : (G.reduce E).Assignment) : + (1 - E.lam) * (E.degree : ℝ) * ((G.devSet A).card : ℝ) / (Fintype.card α : ℝ) + ≤ (((G.reduce E).unsatDarts A).card : ℝ) := by + have hsum : ∑ v : Fin G.numVerts, + ((1 - E.lam) * (E.degree : ℝ) * ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ)) + ≤ ∑ v : Fin G.numVerts, ((G.cloudUnsat E A v).card : ℝ) := + Finset.sum_le_sum fun v _ => G.cloud_disagreement_bound E A v + have hleft : ∑ v : Fin G.numVerts, + ((1 - E.lam) * (E.degree : ℝ) * ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ)) + = (1 - E.lam) * (E.degree : ℝ) * ((G.devSet A).card : ℝ) / (Fintype.card α : ℝ) := by + rw [← Finset.sum_div, ← Finset.mul_sum] + congr 2 + rw [← Nat.cast_sum, G.sum_card_devIdx A] + have hright : ∑ v : Fin G.numVerts, ((G.cloudUnsat E A v).card : ℝ) + ≤ (((G.reduce E).unsatDarts A).card : ℝ) := by + rw [← Nat.cast_sum] + exact_mod_cast G.sum_card_cloudUnsat_le E A + rw [← hleft] + exact le_trans hsum hright + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CoinEnum.lean b/Complexitylib/Classes/PCP/Internal/CoinEnum.lean new file mode 100644 index 00000000..381f31e2 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CoinEnum.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.Containments.Internal.SavitchBits +public import Complexitylib.Classes.Containments.Internal.FPBridge +public import Complexitylib.Classes.Containments.Internal.BinArith +public import Complexitylib.Classes.Containments.Internal.WitnessEnum +public import Complexitylib.Classes.PCP.Internal.SubsetNP + +/-! +# Coin strings from their index + +A loop over the coin strings of a verifier receives its index in unary, since +that is the form a polynomial-time loop counter takes. This module turns such an +index into the coin string itself: the fixed-width binary counter of +`SavitchBits` is incremented that many times, starting from all zeros. + +Nothing here is arithmetic on the index. `bumpBits` is the width-preserving +increment already proved polynomial-time for Savitch's theorem, and iterating a +polynomial-time step a polynomial number of times is `iterate_mem_FP`. + +## Main results + +- `Complexity.coinStr` — the counter after that many increments +- `Complexity.coinStr_mem_FP` — in polynomial time, for any index +- `Complexity.toList_coinOfIndex` — it is the coin string `SubsetNP` names +-/ + +@[expose] public section + +namespace Complexity + +/-- A block of zeros as wide as a computed string. -/ +theorem zeroBlockFn_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => List.replicate (a z).length false) ∈ FP := + unFn_mem_FP (g := fun s => List.replicate s.length false) + (Cobham.zeroBlockFn (Cobham.proj 0)) ha + +theorem bumpBits_mem_FP : bumpBits ∈ FP := by + have h := bumpCodeFn_mem_FP id_mem_FP + refine mem_FP_of_eq h fun z => ?_ + simp + +theorem length_bumpBits_iterate (n : ℕ) (w : List Bool) : + (bumpBits^[n] w).length = w.length := by + induction n with + | zero => rfl + | succ n ih => rw [Function.iterate_succ_apply', bumpBits_length, ih] + +/-- The width-`t` counter after `c` increments. Total: past `2 ^ t` it wraps, +which never happens where it is used but keeps the function unconditional. -/ +def coinStr (t c : ℕ) : List Bool := bumpBits^[c] (List.replicate t false) + +theorem coinStr_eq {t c : ℕ} (h : c < 2 ^ t) : coinStr t c = bitsOfLenLE t c := by + rw [coinStr, ← bitsOfLenLE_zero t, bumpBits_iterate _ _ h] + +/-- **The counter value in polynomial time.** With the width and the index both +supplied in unary, the counter is polynomial-time computable — with no bound on +the index, so that the function is total where a loop guard has not yet been +applied. -/ +theorem coinStr_mem_FP {t c : List Bool → ℕ} + (ht : (fun z => List.replicate (t z) true) ∈ FP) + (hc : (fun z => List.replicate (c z) true) ∈ FP) : + (fun z => coinStr (t z) (c z)) ∈ FP := by + have hinit : (fun z => List.replicate (t z) false) ∈ FP := by + have := zeroBlockFn_mem_FP ht + simpa using this + have hbound : ∀ z : List Bool, ∀ n ≤ (List.replicate (c z) true).length, + (bumpBits^[n] (List.replicate (t z) false)).length + ≤ (List.replicate (t z) false).length := fun z n _ => + le_of_eq (length_bumpBits_iterate n _) + have hiter := Cobham.iterate_mem_FP bumpBits_mem_FP hinit hc hinit hbound + refine mem_FP_of_eq hiter fun z => ?_ + rw [List.length_replicate, coinStr] + +/-- **The counter is the coin string.** `SubsetNP` indexes coin strings by their +little-endian binary value, which is exactly what the counter holds. -/ +theorem toList_coinOfIndex (t c : ℕ) (h : c < 2 ^ t) : + BitString.toList (PCPVerifier.coinOfIndex (t := t) ⟨c, h⟩) = bitsOfLenLE t c := by + refine List.ext_getElem (by simp) fun j h1 h2 => ?_ + have hj : j < t := by simpa using h1 + rw [bitsOfLenLE_getElem t c j hj, + BitString.getElem_toList (PCPVerifier.coinOfIndex (t := t) ⟨c, h⟩) ⟨j, hj⟩, + PCPVerifier.coinOfIndex] + have hval := finFunctionFinEquiv_symm_apply_val (⟨c, h⟩ : Fin (2 ^ t)) (⟨j, hj⟩ : Fin t) + have h2 : (finFunctionFinEquiv.symm (⟨c, h⟩ : Fin (2 ^ t)) ⟨j, hj⟩ = 1) + ↔ (c / 2 ^ j % 2 = 1) := by + rw [Fin.ext_iff, hval] + exact Iff.rfl + exact decide_eq_decide.mpr h2 + +/-- The index of the coin string an index names. -/ +theorem coinIndex_coinOfIndex {t : ℕ} (c : Fin (2 ^ t)) : + PCPVerifier.coinIndex (PCPVerifier.coinOfIndex c) = c.val := by + have hd : PCPVerifier.coinDigits (PCPVerifier.coinOfIndex c) + = finFunctionFinEquiv.symm c := by + funext i + rw [PCPVerifier.coinDigits, PCPVerifier.coinOfIndex] + have hlt : (finFunctionFinEquiv.symm c i).val < 2 := (finFunctionFinEquiv.symm c i).isLt + have hv : (finFunctionFinEquiv.symm c i).val = 0 + ∨ (finFunctionFinEquiv.symm c i).val = 1 := by omega + rcases hv with hv | hv + · have h0 : finFunctionFinEquiv.symm c i = 0 := Fin.ext hv + simp [h0] + · have h1 : finFunctionFinEquiv.symm c i = 1 := Fin.ext hv + simp [h1] + rw [PCPVerifier.coinIndex, hd, Equiv.apply_symm_apply] + +/-- **The value of a coin string is its index.** -/ +theorem binValLE_toList {T : ℕ} (ρ : Fin T → Bool) : + binValLE (BitString.toList ρ) = PCPVerifier.coinIndex ρ := by + have hlt : PCPVerifier.coinIndex ρ < 2 ^ T := PCPVerifier.coinIndex_lt ρ + have hρ : BitString.toList ρ = bitsOfLenLE T (PCPVerifier.coinIndex ρ) := by + rw [← PCPVerifier.coinOfIndex_coinIndex ρ hlt, toList_coinOfIndex] + congr 1 + rw [PCPVerifier.coinOfIndex_coinIndex ρ hlt] + rw [hρ, binValLE_bitsOfLenLE _ _ hlt] + +/-- Coin strings and their indices are in bijection. -/ +noncomputable def coinEquiv (T : ℕ) : Fin (2 ^ T) ≃ (Fin T → Bool) where + toFun := PCPVerifier.coinOfIndex + invFun := fun ρ => ⟨PCPVerifier.coinIndex ρ, PCPVerifier.coinIndex_lt ρ⟩ + left_inv := fun c => Fin.ext (coinIndex_coinOfIndex c) + right_inv := fun ρ => PCPVerifier.coinOfIndex_coinIndex ρ (PCPVerifier.coinIndex_lt ρ) + +/-- **Counting coin strings is counting indices.** -/ +theorem card_filter_coinIndex (T : ℕ) (Q : ℕ → Prop) [DecidablePred Q] : + (Finset.univ.filter (fun ρ : Fin T → Bool => Q (PCPVerifier.coinIndex ρ))).card + = ((Finset.range (2 ^ T)).filter Q).card := by + classical + refine Finset.card_bij (fun ρ _ => PCPVerifier.coinIndex ρ) ?_ ?_ ?_ + · intro ρ hρ + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hρ + exact Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (PCPVerifier.coinIndex_lt ρ), hρ⟩ + · intro ρ₁ h₁ ρ₂ h₂ heq + exact PCPVerifier.coinIndex_injective heq + · intro c hc + rw [Finset.mem_filter, Finset.mem_range] at hc + refine ⟨PCPVerifier.coinOfIndex ⟨c, hc.1⟩, ?_, ?_⟩ + · simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [coinIndex_coinOfIndex] + exact hc.2 + · exact coinIndex_coinOfIndex ⟨c, hc.1⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Compose.lean b/Complexitylib/Classes/PCP/Internal/Compose.lean new file mode 100644 index 00000000..98c0fa03 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Compose.lean @@ -0,0 +1,416 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.TesterCore +public import Complexitylib.Classes.PCP.Internal.LocalTest +public import Complexitylib.Classes.PCP.Internal.RegCSP + +/-! +# Dinur's composition: alphabet reduction + +The powering step leaves a constraint graph over an enormous (though constant) +alphabet. Composition brings the alphabet back down to a fixed one, at the cost +of a constant factor in the unsatisfiability value that does *not* depend on the +alphabet being reduced. That independence is what lets the powering step's gain +win. + +The construction: every vertex of the outer graph gets a block of positions +holding the **Hadamard encoding** of its label; every dart gets a proof for the +assembled tester of `TesterCore`, whose input tables are the encodings at its +two ends and whose constraint is the dart's relation, spelled out on encoded +pairs. The tester's reads make a `MultiTest`, and `LocalTest` turns it into a +binary constraint graph over the fixed alphabet `Alpha ReadIdx`. + +Soundness decodes an assignment of the composed graph to one of the outer graph +by nearest codeword at every vertex. Whenever the decoded assignment violates a +dart, that dart's tester rejects on a `1/32` fraction of its random strings — +otherwise the tester's own soundness would produce a satisfying pair whose +encodings are close to both blocks, and closeness to a codeword pins the +decoded labels down. Each rejecting string costs one of the `22` edges it owns. + +## Main definitions + +- `Complexity.ReadIdx` — the tester's `22` reads +- `Complexity.RegCSP.compose` — the composed `MultiTest` +- `Complexity.RegCSP.decodeAssign` — decoding an assignment of the composed + graph + +## Main results + +- `Complexity.RegCSP.le_unsatVal_compose` — the value drops by at most `704` +- `Complexity.RegCSP.satisfiable_compose` — satisfiability is preserved +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +/-! ### The reads -/ + +/-- The tester's reads, by check: linearity of `F` (three), linearity of `G` +(three), consistency (six), the constraint (four), and the two input tables +(three each: the input coordinate and two self-correction reads). -/ +inductive ReadIdx + | f1x | f1y | f1s + | g2x | g2y | g2s + | c3cQ | c3tQ | c3cX | c3xX | c3cY | c3yY + | k4qG | k4tG | k4cF | k4lF + | i5r | i5c | i5b + | i6r | i6c | i6b + deriving DecidableEq, Fintype + +theorem card_readIdx : Fintype.card ReadIdx = 22 := rfl + +instance : Nonempty ReadIdx := ⟨ReadIdx.f1x⟩ + +/-- The reads are numbered by their own enumeration: there are twenty-two of +them, so this is a lookup on a bounded key. -/ +noncomputable instance : NumEnc ReadIdx := NumEnc.ofFintype _ + +/-! ### Signs and bits -/ + +theorem chi_eq_chi_iff (u v : ZMod 2) : chi u = chi v ↔ u = v := by + constructor + · intro h + have h' := signBit_chi u + rw [h, signBit_chi] at h' + exact h'.symm + · intro h + rw [h] + +theorem signBit_signOf_mul {m : ℕ} (F : Cube m → ZMod 2) (u v : Cube m) : + signBit (signOf F u * signOf F v) = F u + F v := by + show signBit (chi (F u) * chi (F v)) = _ + rw [← BooleanAnalysis.Internal.chi_add, signBit_chi] + +theorem signOf_mul_eq_iff {m : ℕ} (F : Cube m → ZMod 2) (u v w : Cube m) : + signOf F u * signOf F v = signOf F w ↔ F u + F v = F w := by + show chi (F u) * chi (F v) = chi (F w) ↔ _ + rw [← BooleanAnalysis.Internal.chi_add, chi_eq_chi_iff] + +/-! ### The checks as a formula on the bits read -/ + +namespace Tester + +variable {B : ℕ} + +/-- The tester's verdict as a formula on the bits it read. -/ +noncomputable def bitFormula (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) + (rd : ReadIdx → ZMod 2) : Prop := + rd .f1x + rd .f1y = rd .f1s + ∧ rd .g2x + rd .g2y = rd .g2s + ∧ rd .c3cQ + rd .c3tQ = (rd .c3cX + rd .c3xX) * (rd .c3cY + rd .c3yY) + ∧ (rd .k4qG + rd .k4tG) + (rd .k4cF + rd .k4lF) + + (QuadConstraint.combine (oneHotSystem S) (leftBlock (blk4 z))).const = 0 + ∧ rd .i5c + rd .i5b = rd .i5r + ∧ rd .i6c + rd .i6b = rd .i6r + +noncomputable instance (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) + (rd : ReadIdx → ZMod 2) : Decidable (bitFormula S z rd) := by + unfold bitFormula + infer_instance + +/-- The bits the tester reads from the four tables. -/ +noncomputable def readsOf (Tt Th : Cube B → ZMod 2) (F : Cube (nOf B) → ZMod 2) + (G : Cube (nOf B * nOf B) → ZMod 2) (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) : + ReadIdx → ZMod 2 + | .f1x => F (leftBlock (blk1 z)) + | .f1y => F (rightBlock (blk1 z)) + | .f1s => F (leftBlock (blk1 z) + rightBlock (blk1 z)) + | .g2x => G (leftBlock (blk2 z)) + | .g2y => G (rightBlock (blk2 z)) + | .g2s => G (leftBlock (blk2 z) + rightBlock (blk2 z)) + | .c3cQ => G (cQ (blk3 z)) + | .c3tQ => G (tensor (qX (blk3 z)) (qY (blk3 z)) + cQ (blk3 z)) + | .c3cX => F (cX (blk3 z)) + | .c3xX => F (qX (blk3 z) + cX (blk3 z)) + | .c3cY => F (cY (blk3 z)) + | .c3yY => F (qY (blk3 z) + cY (blk3 z)) + | .k4qG => G (rightBlock (rightBlock (blk4 z))) + | .k4tG => G ((QuadConstraint.combine (oneHotSystem S) (leftBlock (blk4 z))).quad + + rightBlock (rightBlock (blk4 z))) + | .k4cF => F (leftBlock (rightBlock (blk4 z))) + | .k4lF => F ((QuadConstraint.combine (oneHotSystem S) (leftBlock (blk4 z))).lin + + leftBlock (rightBlock (blk4 z))) + | .i5r => Tt (leftBlock (blk5 z)) + | .i5c => F (rightBlock (blk5 z)) + | .i5b => F (basisVec (inTail B (leftBlock (blk5 z))) + rightBlock (blk5 z)) + | .i6r => Th (leftBlock (blk6 z)) + | .i6c => F (rightBlock (blk6 z)) + | .i6b => F (basisVec (inHead B (leftBlock (blk6 z))) + rightBlock (blk6 z)) + +/-- **The verdict is the formula on the reads.** -/ +theorem allChecks_iff (S : Finset (Cube (kOf B))) (Tt Th : Cube B → ZMod 2) + (F : Cube (nOf B) → ZMod 2) (G : Cube (nOf B * nOf B) → ZMod 2) (z : Cube (ROf B)) : + AllChecks S Tt Th F G z ↔ bitFormula S z (readsOf Tt Th F G S z) := by + unfold AllChecks bitFormula LinCheck TesterAccepts ConstraintAccepts CoordAccepts + simp only [readsOf, signOf_mul_eq_iff, signBit_signOf_mul] + +end Tester + +/-! ### The composition -/ + +namespace RegCSP + +open Tester + +variable {β : Type} {B : ℕ} (enc : β → Cube B) + +/-- A bit table on `Cube B`, as a vector indexed by `Fin (2 ^ B)`. -/ +noncomputable def vecOf (t : Cube B → ZMod 2) : Cube (2 ^ B) := fun m => t ((candIdx B).symm m) + +/-- The tester's input variables for a pair of labels: the two encodings. -/ +noncomputable def inputVec (σ τ : β) : Cube (kOf B) := + Fin.append (vecOf (hadamard (enc σ))) (vecOf (hadamard (enc τ))) + +theorem tailPart_of_leftBlock (σ τ : β) (a : Cube (nOf B)) + (h : leftBlock a = inputVec enc σ τ) : tailPart a = hadamard (enc σ) := by + funext r + have hr : tailPart a r = leftBlock (leftBlock a) (candIdx B r) := rfl + rw [hr, h] + show (Fin.append (vecOf (hadamard (enc σ))) (vecOf (hadamard (enc τ)))) + (Fin.castAdd _ (candIdx B r)) = _ + rw [Fin.append_left] + show hadamard (enc σ) ((candIdx B).symm (candIdx B r)) = _ + rw [Equiv.symm_apply_apply] + +theorem headPart_of_leftBlock (σ τ : β) (a : Cube (nOf B)) + (h : leftBlock a = inputVec enc σ τ) : headPart a = hadamard (enc τ) := by + funext r + have hr : headPart a r = leftBlock a (Fin.natAdd (2 ^ B) (candIdx B r)) := rfl + rw [hr, h] + show (Fin.append (vecOf (hadamard (enc σ))) (vecOf (hadamard (enc τ)))) + (Fin.natAdd _ (candIdx B r)) = _ + rw [Fin.append_right] + show hadamard (enc τ) ((candIdx B).symm (candIdx B r)) = _ + rw [Equiv.symm_apply_apply] + +variable [Fintype β] [DecidableEq β] [Nonempty β] (R : RegCSP β) + [NumEnc R.graph.V] [NumEnc R.graph.D] + +/-- The satisfying set of a dart: the encoded pairs its relation accepts. -/ +noncomputable def satSet (p : R.Dart) : Finset (Cube (kOf B)) := + (Finset.univ.filter fun st : β × β => R.rel p.1 p.2 st.1 st.2 = true).image + fun st => inputVec enc st.1 st.2 + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +theorem mem_satSet_iff (p : R.Dart) (w : Cube (kOf B)) : + w ∈ R.satSet enc p ↔ ∃ σ τ, R.rel p.1 p.2 σ τ = true ∧ inputVec enc σ τ = w := by + simp only [satSet, Finset.mem_image, Finset.mem_filter, Finset.mem_univ, true_and, + Prod.exists] + +/-- The positions of the composed proof: an encoding block per vertex, and a +linear and a quadratic table per dart. -/ +abbrev Pos : Type := + (R.graph.V × Cube B) ⊕ ((R.Dart × Cube (nOf B)) ⊕ (R.Dart × Cube (nOf B * nOf B))) + +/-- **The composed test**: for each dart, the assembled tester on the encodings +at its ends and its own proof tables. -/ +noncomputable def compose : MultiTest (R.Pos (B := B)) R.Dart ReadIdx where + R := ROf B + pos := fun p z i => + match i with + | .f1x => Sum.inr (Sum.inl (p, leftBlock (blk1 z))) + | .f1y => Sum.inr (Sum.inl (p, rightBlock (blk1 z))) + | .f1s => Sum.inr (Sum.inl (p, leftBlock (blk1 z) + rightBlock (blk1 z))) + | .g2x => Sum.inr (Sum.inr (p, leftBlock (blk2 z))) + | .g2y => Sum.inr (Sum.inr (p, rightBlock (blk2 z))) + | .g2s => Sum.inr (Sum.inr (p, leftBlock (blk2 z) + rightBlock (blk2 z))) + | .c3cQ => Sum.inr (Sum.inr (p, cQ (blk3 z))) + | .c3tQ => Sum.inr (Sum.inr (p, tensor (qX (blk3 z)) (qY (blk3 z)) + cQ (blk3 z))) + | .c3cX => Sum.inr (Sum.inl (p, cX (blk3 z))) + | .c3xX => Sum.inr (Sum.inl (p, qX (blk3 z) + cX (blk3 z))) + | .c3cY => Sum.inr (Sum.inl (p, cY (blk3 z))) + | .c3yY => Sum.inr (Sum.inl (p, qY (blk3 z) + cY (blk3 z))) + | .k4qG => Sum.inr (Sum.inr (p, rightBlock (rightBlock (blk4 z)))) + | .k4tG => Sum.inr (Sum.inr (p, + (QuadConstraint.combine (oneHotSystem (R.satSet enc p)) (leftBlock (blk4 z))).quad + + rightBlock (rightBlock (blk4 z)))) + | .k4cF => Sum.inr (Sum.inl (p, leftBlock (rightBlock (blk4 z)))) + | .k4lF => Sum.inr (Sum.inl (p, + (QuadConstraint.combine (oneHotSystem (R.satSet enc p)) (leftBlock (blk4 z))).lin + + leftBlock (rightBlock (blk4 z)))) + | .i5r => Sum.inl (p.1, leftBlock (blk5 z)) + | .i5c => Sum.inr (Sum.inl (p, rightBlock (blk5 z))) + | .i5b => Sum.inr (Sum.inl (p, basisVec (inTail B (leftBlock (blk5 z))) + rightBlock (blk5 z))) + | .i6r => Sum.inl (R.graph.nbr p.1 p.2, leftBlock (blk6 z)) + | .i6c => Sum.inr (Sum.inl (p, rightBlock (blk6 z))) + | .i6b => Sum.inr (Sum.inl (p, basisVec (inHead B (leftBlock (blk6 z))) + rightBlock (blk6 z))) + check := fun p z rd => decide (bitFormula (R.satSet enc p) z rd) + +/-- The encoding block at a dart's tail, as the tester's first input table. -/ +noncomputable def tailTable (T : MultiTest.Table (R.Pos (B := B))) (p : R.Dart) : + Cube B → ZMod 2 := fun r => T (Sum.inl (p.1, r)) +/-- The encoding block at a dart's head, as the tester's second input table. -/ +noncomputable def headTable (T : MultiTest.Table (R.Pos (B := B))) (p : R.Dart) : + Cube B → ZMod 2 := fun r => T (Sum.inl (R.graph.nbr p.1 p.2, r)) +/-- A dart's linear proof table. -/ +noncomputable def linTable (T : MultiTest.Table (R.Pos (B := B))) (p : R.Dart) : + Cube (nOf B) → ZMod 2 := fun x => T (Sum.inr (Sum.inl (p, x))) +/-- A dart's quadratic proof table. -/ +noncomputable def quadTable (T : MultiTest.Table (R.Pos (B := B))) (p : R.Dart) : + Cube (nOf B * nOf B) → ZMod 2 := fun y => T (Sum.inr (Sum.inr (p, y))) + +omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in +/-- **The composed test runs the tester.** -/ +theorem accepts_compose_iff (T : MultiTest.Table (R.Pos (B := B))) (p : R.Dart) + (z : Cube (ROf B)) : + (R.compose enc).accepts T p z = true + ↔ AllChecks (R.satSet enc p) (R.tailTable T p) (R.headTable T p) (R.linTable T p) + (R.quadTable T p) z := by + rw [allChecks_iff] + show decide (bitFormula (R.satSet enc p) z fun i => T ((R.compose enc).pos p z i)) = true ↔ _ + rw [decide_eq_true_iff] + have hreads : (fun i => T ((R.compose enc).pos p z i)) + = readsOf (R.tailTable T p) (R.headTable T p) (R.linTable T p) (R.quadTable T p) + (R.satSet enc p) z := by + funext i + cases i <;> rfl + rw [hreads] + +/-! ### Soundness -/ + +/-- Decoding an assignment of the composed graph: nearest codeword at each +vertex. -/ +noncomputable def decodeAssign (A : (R.compose enc).toGraph.Assignment) : R.Assignment := + fun v => decodeLabel enc fun r => (R.compose enc).tableOf A (Sum.inl (v, r)) + +omit [DecidableEq β] in +/-- **A violated dart rejects a `1/32` fraction of its random strings.** -/ +theorem card_rejects_ge (henc : Function.Injective enc) + (A : (R.compose enc).toGraph.Assignment) (p : R.Dart) + (hp : ¬ R.Satisfies (R.decodeAssign enc A) p) : + 2 ^ ROf B ≤ 32 * ((R.compose enc).rejects ((R.compose enc).tableOf A) p).card := by + classical + by_contra hlt + push Not at hlt + set T := (R.compose enc).tableOf A with hT + have hprob : 1 - 1 / 32 < Pr[AllChecks (R.satSet enc p) (R.tailTable T p) (R.headTable T p) + (R.linTable T p) (R.quadTable T p)] := by + have hacc : Pr[fun z : Cube (ROf B) => (R.compose enc).accepts T p z = true] + = 1 - (((R.compose enc).rejects T p).card : ℝ) / 2 ^ ROf B := + (R.compose enc).prob_accepts_eq T p + have heq : (fun z : Cube (ROf B) => (R.compose enc).accepts T p z = true) + = AllChecks (R.satSet enc p) (R.tailTable T p) (R.headTable T p) + (R.linTable T p) (R.quadTable T p) := by + funext z + exact propext (R.accepts_compose_iff enc T p z) + rw [heq] at hacc + rw [hacc] + have hlt' : (32 : ℝ) * ((R.compose enc).rejects T p).card < 2 ^ ROf B := by + exact_mod_cast hlt + have hpos : (0 : ℝ) < 2 ^ ROf B := by positivity + rw [sub_lt_sub_iff_left, div_lt_iff₀ hpos] + linarith + obtain ⟨a, hsys, hdt, hdh⟩ := Tester.sound _ _ _ _ _ hprob + have hmem := mem_of_sat_oneHotSystem _ a hsys + rw [mem_satSet_iff] at hmem + obtain ⟨σ, τ, hrel, heq⟩ := hmem + have htail := tailPart_of_leftBlock enc σ τ a heq.symm + have hhead := headPart_of_leftBlock enc σ τ a heq.symm + rw [htail] at hdt + rw [hhead] at hdh + have hdt' : bitDist (R.tailTable T p) (hadamard (enc σ)) < 1 / 4 := by linarith + have hdh' : bitDist (R.headTable T p) (hadamard (enc τ)) < 1 / 4 := by linarith + have hσ : R.decodeAssign enc A p.1 = σ := decodeLabel_eq enc henc _ σ hdt' + have hτ : R.decodeAssign enc A (R.graph.nbr p.1 p.2) = τ := decodeLabel_eq enc henc _ τ hdh' + apply hp + show R.rel p.1 p.2 (R.decodeAssign enc A p.1) (R.decodeAssign enc A (R.graph.nbr p.1 p.2)) = true + rw [hσ, hτ] + exact hrel + +omit [DecidableEq β] in +/-- **Soundness of composition**, per assignment: the composed graph's violated +fraction is at least the decoded assignment's, divided by `704 = 32 · 22`. -/ +theorem unsatFrac_compose_ge (henc : Function.Injective enc) + (A : (R.compose enc).toGraph.Assignment) : + R.unsatFrac (R.decodeAssign enc A) / 704 ≤ (R.compose enc).toGraph.unsatFrac A := by + classical + refine le_trans ?_ ((R.compose enc).unsatFrac_toGraph_ge A) + rw [card_readIdx] + set T := (R.compose enc).tableOf A + have hsum : ((R.unsatDarts (R.decodeAssign enc A)).card : ℚ) * 2 ^ ROf B + ≤ 32 * ∑ p : R.Dart, (((R.compose enc).rejects T p).card : ℚ) := by + have h1 : ∑ p ∈ R.unsatDarts (R.decodeAssign enc A), ((2 : ℚ) ^ ROf B) + ≤ ∑ p ∈ R.unsatDarts (R.decodeAssign enc A), + 32 * (((R.compose enc).rejects T p).card : ℚ) := by + refine Finset.sum_le_sum fun p hp => ?_ + rw [mem_unsatDarts] at hp + exact_mod_cast R.card_rejects_ge enc henc A p hp + have h2 : ∑ p ∈ R.unsatDarts (R.decodeAssign enc A), + 32 * (((R.compose enc).rejects T p).card : ℚ) + ≤ ∑ p : R.Dart, 32 * (((R.compose enc).rejects T p).card : ℚ) := + Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + fun p _ _ => by positivity + rw [Finset.sum_const, nsmul_eq_mul, ← Finset.mul_sum] at h1 + rw [← Finset.mul_sum, ← Finset.mul_sum] at h2 + linarith + have hE : (Fintype.card R.Dart : ℚ) = ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by + rw [R.card_dart] + rw [RegCSP.unsatFrac, hE] + have hpos : (0 : ℚ) < 2 ^ ROf B := by positivity + rcases Nat.eq_zero_or_pos (R.graph.order * R.graph.deg) with h0 | h0 + · rw [h0] + simp + · have hE' : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by exact_mod_cast h0 + rw [div_div, div_le_div_iff₀ (by positivity) (by positivity)] + have key := mul_le_mul_of_nonneg_right hsum + (by positivity : (0 : ℚ) ≤ 22 * ((R.graph.order * R.graph.deg : ℕ) : ℚ)) + have key' : ((R.unsatDarts (R.decodeAssign enc A)).card : ℚ) * 2 ^ (R.compose enc).R + * (22 * ((R.graph.order * R.graph.deg : ℕ) : ℚ)) + ≤ (32 * ∑ p : R.Dart, (((R.compose enc).rejects T p).card : ℚ)) + * (22 * ((R.graph.order * R.graph.deg : ℕ) : ℚ)) := key + push_cast at key' ⊢ + linarith [key'] + +omit [DecidableEq β] in +/-- **Soundness of composition.** -/ +theorem le_unsatVal_compose (henc : Function.Injective enc) : + R.unsatVal / 704 ≤ (R.compose enc).toGraph.unsatVal := by + refine ConstraintGraph.le_unsatVal fun A => ?_ + refine le_trans ?_ (R.unsatFrac_compose_ge enc henc A) + have := R.unsatVal_le (R.decodeAssign enc A) + linarith + +/-! ### Completeness -/ + +/-- The honest proof of a satisfying assignment: encodings at the vertices, and +for each dart the Hadamard tables of the one-hot extension of its encoded pair. +-/ +noncomputable def honestTable (σ : R.Assignment) : MultiTest.Table (R.Pos (B := B)) + | Sum.inl (v, r) => hadamard (enc (σ v)) r + | Sum.inr (Sum.inl (p, x)) => + hadamard (oneHotExtend (inputVec enc (σ p.1) (σ (R.graph.nbr p.1 p.2)))) x + | Sum.inr (Sum.inr (p, y)) => + hadamard (tensorAssign (oneHotExtend (inputVec enc (σ p.1) (σ (R.graph.nbr p.1 p.2))))) y + +omit [DecidableEq β] [Nonempty β] in +/-- **Completeness of composition.** -/ +theorem satisfiable_compose (h : R.Satisfiable) : (R.compose enc).toGraph.Satisfiable := by + obtain ⟨σ, hσ⟩ := h + refine (R.compose enc).satisfiable_toGraph (R.honestTable enc σ) fun p z => ?_ + rw [accepts_compose_iff] + set a := oneHotExtend (inputVec enc (σ p.1) (σ (R.graph.nbr p.1 p.2))) with ha + have hleft : leftBlock a = inputVec enc (σ p.1) (σ (R.graph.nbr p.1 p.2)) := + leftBlock_oneHotExtend _ + have htail : R.tailTable (R.honestTable enc σ) p = tailPart a := by + rw [tailPart_of_leftBlock enc _ _ a hleft] + rfl + have hhead : R.headTable (R.honestTable enc σ) p = headPart a := by + rw [headPart_of_leftBlock enc _ _ a hleft] + rfl + have hlin : R.linTable (R.honestTable enc σ) p = hadamard a := rfl + have hquad : R.quadTable (R.honestTable enc σ) p = hadamard (tensorAssign a) := rfl + rw [htail, hhead, hlin, hquad] + refine Tester.complete _ a (sat_oneHotSystem_extend _ _ ?_) z + rw [mem_satSet_iff] + exact ⟨σ p.1, σ (R.graph.nbr p.1 p.2), hσ p, rfl⟩ + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean b/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean new file mode 100644 index 00000000..a7592d2a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean @@ -0,0 +1,473 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.VerifierLang + +/-! +# Checking that a witness is consistent + +A witness records an answer for every query slot. It comes from an actual proof +only if slots reading the same proof position carry the same answer, and that is +what this module checks: four nested loops over a pair of coin strings and a +pair of query indices. + +The check never looks at a position as a number. `posAt` returns each query +position as its own serialization, so slots reading the same position are +recognised by comparing strings — and a slot past the end of a query list is +recognised by that string being empty. + +## Main definitions + +- `Complexity.consLang` — the consistency check, as a language of `pair x w` + +## Main results + +- `Complexity.consLang_mem_P` — the check is polynomial time +-/ + +@[expose] public section + +namespace Complexity + +section Consistency + +variable (V : PCPVerifier) (f : List Bool → List Bool) (r : ℕ → ℕ) (Q : ℕ) + +/-! ### Reading the nested loop input + +The innermost input is `pair (pair (pair (pair (pair x w) ρ) ρ') i) i'`, with +the four loop indices in unary. -/ + +/-- Strip the last two indices. -/ +def conY2 (y : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock y) + +/-- Strip the last three indices. -/ +def conY1 (y : List Bool) : List Bool := Cobham.fstBlock (conY2 y) + +/-- The original `pair x w`. -/ +def conY0 (y : List Bool) : List Bool := Cobham.fstBlock (conY1 y) + +/-- The input. -/ +def conX (y : List Bool) : List Bool := Cobham.fstBlock (conY0 y) + +/-- The witness. -/ +def conW (y : List Bool) : List Bool := Cobham.sndBlock (conY0 y) + +/-- The first coin index. -/ +def conC1 (y : List Bool) : ℕ := (Cobham.sndBlock (conY1 y)).length + +/-- The second coin index. -/ +def conC2 (y : List Bool) : ℕ := (Cobham.sndBlock (conY2 y)).length + +/-- The first query index. -/ +def conC3 (y : List Bool) : ℕ := (Cobham.sndBlock (Cobham.fstBlock y)).length + +/-- The second query index. -/ +def conC4 (y : List Bool) : ℕ := (Cobham.sndBlock y).length + +theorem conY2_mem_FP : conY2 ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +theorem conY1_mem_FP : conY1 ∈ FP := + mem_FP_comp conY2_mem_FP Cobham.fstBlock_mem_FP + +theorem conY0_mem_FP : conY0 ∈ FP := + mem_FP_comp conY1_mem_FP Cobham.fstBlock_mem_FP + +theorem conX_mem_FP : conX ∈ FP := + mem_FP_comp conY0_mem_FP Cobham.fstBlock_mem_FP + +theorem conW_mem_FP : conW ∈ FP := + mem_FP_comp conY0_mem_FP Cobham.sndBlock_mem_FP + +theorem unary_conC1_mem_FP : (fun y => List.replicate (conC1 y) true) ∈ FP := by + have := mem_FP_comp (mem_FP_comp conY1_mem_FP Cobham.sndBlock_mem_FP) unaryLength_mem_FP + simpa [Function.comp, conC1] using this + +theorem unary_conC2_mem_FP : (fun y => List.replicate (conC2 y) true) ∈ FP := by + have := mem_FP_comp (mem_FP_comp conY2_mem_FP Cobham.sndBlock_mem_FP) unaryLength_mem_FP + simpa [Function.comp, conC2] using this + +theorem unary_conC3_mem_FP : (fun y => List.replicate (conC3 y) true) ∈ FP := by + have := mem_FP_comp + (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) unaryLength_mem_FP + simpa [Function.comp, conC3] using this + +theorem unary_conC4_mem_FP : (fun y => List.replicate (conC4 y) true) ∈ FP := by + have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP + simpa [Function.comp, conC4] using this + +/-! ### The check -/ + +/-- The first coin string. -/ +noncomputable def conRho (y : List Bool) : List Bool := + coinStr (r (conX y).length) (conC1 y) + +/-- The second coin string. -/ +noncomputable def conRho' (y : List Bool) : List Bool := + coinStr (r (conX y).length) (conC2 y) + +/-- The position the first slot queries, as a string. -/ +noncomputable def conP (y : List Bool) : List Bool := + posAt (f (pair (conX y) (conRho r y))) (conC3 y) + +/-- The position the second slot queries, as a string. -/ +noncomputable def conP' (y : List Bool) : List Bool := + posAt (f (pair (conX y) (conRho' r y))) (conC4 y) + +/-- The answer recorded in the first slot. -/ +def conB (y : List Bool) : List Bool := + wBlock (conW y) (conC1 y * Q + conC3 y) 1 + +/-- The answer recorded in the second slot. -/ +def conB' (y : List Bool) : List Bool := + wBlock (conW y) (conC2 y * Q + conC4 y) 1 + +/-- The verdict of one iteration: when both slots are real and query the same +position, their answers must agree. -/ +noncomputable def conChk (y : List Bool) : List Bool := + Cobham.selectHead + (andBit (Cobham.eqFlag (conP f r y) (conP' f r y)) + (notBit (emptyFlag (conP f r y)))) + (Cobham.eqFlag (conB Q y) (conB' Q y)) [true] + +/-! ### Polynomial time -/ + +variable (hf : f ∈ FP) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + +include hr in +theorem conRho_mem_FP : conRho r ∈ FP := by + have ht : (fun y : List Bool => List.replicate (r (conX y).length) true) ∈ FP := by + have := mem_FP_comp conX_mem_FP hr + simpa [Function.comp] using this + exact coinStr_mem_FP ht unary_conC1_mem_FP + +include hr in +theorem conRho'_mem_FP : conRho' r ∈ FP := by + have ht : (fun y : List Bool => List.replicate (r (conX y).length) true) ∈ FP := by + have := mem_FP_comp conX_mem_FP hr + simpa [Function.comp] using this + exact coinStr_mem_FP ht unary_conC2_mem_FP + +include hf hr in +theorem conP_mem_FP : conP f r ∈ FP := by + have hb : (fun y => f (pair (conX y) (conRho r y))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP conX_mem_FP (conRho_mem_FP r hr)) hf + simpa [Function.comp] using this + have := posAt_mem_FP unary_conC3_mem_FP hb + refine mem_FP_of_eq this fun y => ?_ + rw [conP, List.length_replicate] + +include hf hr in +theorem conP'_mem_FP : conP' f r ∈ FP := by + have hb : (fun y => f (pair (conX y) (conRho' r y))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP conX_mem_FP (conRho'_mem_FP r hr)) hf + simpa [Function.comp] using this + have := posAt_mem_FP unary_conC4_mem_FP hb + refine mem_FP_of_eq this fun y => ?_ + rw [conP', List.length_replicate] + +/-- The offset of a slot in the witness, in unary. -/ +theorem offset_mem_FP {c d : List Bool → ℕ} + (hc : (fun y => List.replicate (c y) true) ∈ FP) + (hd : (fun y => List.replicate (d y) true) ∈ FP) : + (fun y => List.replicate (c y * Q + d y) false) ∈ FP := by + have hQ : (fun _ : List Bool => List.replicate Q false) ∈ FP := + Cobham.const_replicate_mem_FP Q + have hmul : (fun y => List.replicate ((c y) * Q) false) ∈ FP := by + have := Cobham.mulLenFn_mem_FP hc hQ + refine mem_FP_of_eq this fun y => ?_ + rw [List.length_replicate, List.length_replicate] + have hzero : (fun y => List.replicate (d y) false) ∈ FP := by + have := zeroBlockFn_mem_FP hd + refine mem_FP_of_eq this fun y => ?_ + rw [List.length_replicate] + have := Cobham.appendFn_mem_FP hmul hzero + refine mem_FP_of_eq this fun y => ?_ + rw [← List.replicate_add] + +theorem conB_mem_FP : conB Q ∈ FP := by + have hs := offset_mem_FP Q unary_conC1_mem_FP unary_conC3_mem_FP + have hl : (fun _ : List Bool => [false]) ∈ FP := constFn_mem_FP [false] + have := wBlock_mem_FP conW_mem_FP hs hl + refine mem_FP_of_eq this fun y => ?_ + rw [conB, List.length_replicate] + rfl + +theorem conB'_mem_FP : conB' Q ∈ FP := by + have hs := offset_mem_FP Q unary_conC2_mem_FP unary_conC4_mem_FP + have hl : (fun _ : List Bool => [false]) ∈ FP := constFn_mem_FP [false] + have := wBlock_mem_FP conW_mem_FP hs hl + refine mem_FP_of_eq this fun y => ?_ + rw [conB', List.length_replicate] + rfl + +include hf hr in +theorem conChk_mem_FP : conChk f r Q ∈ FP := by + refine Cobham.selectHeadFn_mem_FP ?_ ?_ (constFn_mem_FP [true]) + · exact andBitFn_mem_FP (eqFlagFn_mem_FP (conP_mem_FP f r hf hr) (conP'_mem_FP f r hf hr)) + (notBitFn_mem_FP (emptyFlagFn_mem_FP (conP_mem_FP f r hf hr))) + · exact eqFlagFn_mem_FP (conB_mem_FP Q) (conB'_mem_FP Q) + +/-- One iteration of the consistency check. -/ +noncomputable def consInner : Language := {y | ∃ b ∈ conChk f r Q y, b = true} + +include hf hr in +theorem consInner_mem_P : consInner f r Q ∈ P := + mem_P_of_decisionFn (conChk_mem_FP f r Q hf hr) fun _ => Iff.rfl + +/-- The two inner loops, over the pair of query indices. -/ +noncomputable def consL3 : Language := + {y | ∀ i' < Q, pair y (List.replicate i' true) ∈ consInner f r Q} + +/-- The outer of the two query-index loops. -/ +noncomputable def consL2 : Language := + {y | ∀ i < Q, pair y (List.replicate i true) ∈ consL3 f r Q} + +/-- The outer loop over the second coin string. -/ +noncomputable def consL1 : Language := + {y | ∀ c' < 2 ^ r (Cobham.fstBlock (Cobham.fstBlock y)).length, + pair y (List.replicate c' true) ∈ consL2 f r Q} + +/-- **The consistency check**, as a language of `pair x w`. -/ +noncomputable def consLang : Language := + {z | ∀ c < 2 ^ r (Cobham.fstBlock z).length, + pair z (List.replicate c true) ∈ consL1 f r Q} + +open scoped Complexity in +include hf hr in +theorem consLang_mem_P (hrlog : r =O fun n => Nat.log 2 n) : consLang f r Q ∈ P := by + have hQ : (fun _ : List Bool => List.replicate Q true) ∈ FP := + constFn_mem_FP (List.replicate Q true) + have hQ' : (fun z : List Bool => List.replicate Q true) ∈ FP := hQ + have h3 : consL3 f r Q ∈ P := + forall_unary_mem_P (consInner_mem_P f r Q hf hr) hQ + have h2 : consL2 f r Q ∈ P := forall_unary_mem_P h3 hQ' + have hexp : (fun z : List Bool => + List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) + simpa [Function.comp] using this + have hexp2 : (fun y : List Bool => + List.replicate (2 ^ r (Cobham.fstBlock (Cobham.fstBlock y)).length) true) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP hexp + simpa [Function.comp] using this + have h1 : consL1 f r Q ∈ P := forall_unary_mem_P h2 hexp2 + exact forall_unary_mem_P h1 hexp + +/-! ### What one iteration says -/ + +theorem exists_eqFlag_iff (a b : List Bool) : + (∃ z ∈ Cobham.eqFlag a b, z = true) ↔ a = b := by + rcases Cobham.eqFlag_flag a b with h | h + · rw [h] + simp only [List.mem_singleton, exists_eq_left] + exact ⟨fun _ => (Cobham.eqFlag_eq_true_iff a b).mp h, fun _ => trivial⟩ + · rw [h] + simp only [List.mem_singleton, exists_eq_left, false_iff, Bool.false_eq_true] + intro hab + rw [(Cobham.eqFlag_eq_true_iff a b).mpr hab] at h + simp at h + +theorem mem_consInner_iff (y : List Bool) : + y ∈ consInner f r Q + ↔ (conP f r y = conP' f r y ∧ conP f r y ≠ [] → conB Q y = conB' Q y) := by + rw [consInner, Set.mem_setOf_eq, conChk] + by_cases hcase : conP f r y = conP' f r y ∧ conP f r y ≠ [] + · obtain ⟨heq, hne⟩ := hcase + have h1 : Cobham.eqFlag (conP f r y) (conP' f r y) = [true] := + (Cobham.eqFlag_eq_true_iff _ _).mpr heq + have h2 : emptyFlag (conP f r y) = [false] := by + cases hp : conP f r y with + | nil => exact absurd hp hne + | cons b t => rw [emptyFlag_cons] + rw [h1, h2] + simp only [notBit, andBit, caseBit₀_cons, cond_false, cond_true] + rw [selectHead_cons_true, exists_eqFlag_iff] + exact ⟨fun h _ => h, fun h => h ⟨heq, hne⟩⟩ + · have hflag : andBit (Cobham.eqFlag (conP f r y) (conP' f r y)) + (notBit (emptyFlag (conP f r y))) = [false] := by + by_cases heq : conP f r y = conP' f r y + · have hne : conP f r y = [] := by + by_contra hne + exact hcase ⟨heq, hne⟩ + rw [hne, emptyFlag_nil] + simp only [notBit, andBit, caseBit₀_cons] + rcases Cobham.eqFlag_flag ([] : List Bool) (conP' f r y) with h | h <;> + rw [h] <;> simp + · have h1 : Cobham.eqFlag (conP f r y) (conP' f r y) = [false] := by + rcases Cobham.eqFlag_flag (conP f r y) (conP' f r y) with h | h + · exact absurd ((Cobham.eqFlag_eq_true_iff _ _).mp h) heq + · exact h + rw [h1] + simp [andBit] + rw [hflag, selectHead_cons_false] + simp only [List.mem_singleton, exists_eq_left] + exact ⟨fun _ h => absurd h hcase, fun _ => trivial⟩ + + +/-- The packed input of one iteration. -/ +def conArg (x w : List Bool) (c c' i i' : ℕ) : List Bool := + pair (pair (pair (pair (pair x w) (List.replicate c true)) (List.replicate c' true)) + (List.replicate i true)) (List.replicate i' true) + +@[simp] theorem conX_arg (x w : List Bool) (c c' i i' : ℕ) : + conX (conArg x w c c' i i') = x := by + rw [conArg, conX, conY0, conY1, conY2] + simp only [Cobham.fstBlock_pair] + +@[simp] theorem conW_arg (x w : List Bool) (c c' i i' : ℕ) : + conW (conArg x w c c' i i') = w := by + rw [conArg, conW, conY0, conY1, conY2] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + +@[simp] theorem conC1_arg (x w : List Bool) (c c' i i' : ℕ) : + conC1 (conArg x w c c' i i') = c := by + rw [conArg, conC1, conY1, conY2] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate] + +@[simp] theorem conC2_arg (x w : List Bool) (c c' i i' : ℕ) : + conC2 (conArg x w c c' i i') = c' := by + rw [conArg, conC2, conY2] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate] + +@[simp] theorem conC3_arg (x w : List Bool) (c c' i i' : ℕ) : + conC3 (conArg x w c c' i i') = i := by + rw [conArg, conC3] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate] + +@[simp] theorem conC4_arg (x w : List Bool) (c c' i i' : ℕ) : + conC4 (conArg x w c c' i i') = i' := by + rw [conArg, conC4] + simp only [Cobham.sndBlock_pair, List.length_replicate] + +/-! ### The pieces on a packed argument -/ + +variable (hfspec : ∀ x rr : List Bool, + f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) + +theorem conRho_arg {x w : List Bool} {c c' i i' : ℕ} (hc : c < 2 ^ r x.length) : + conRho r (conArg x w c c' i i') + = BitString.toList (PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩) := by + rw [conRho, conX_arg, conC1_arg, coinStr_eq hc, toList_coinOfIndex] + +theorem conRho'_arg {x w : List Bool} {c c' i i' : ℕ} (hc' : c' < 2 ^ r x.length) : + conRho' r (conArg x w c c' i i') + = BitString.toList (PCPVerifier.coinOfIndex (t := r x.length) ⟨c', hc'⟩) := by + rw [conRho', conX_arg, conC2_arg, coinStr_eq hc', toList_coinOfIndex] + +include hfspec in +theorem conP_arg {x w : List Bool} {c c' i i' : ℕ} (hc : c < 2 ^ r x.length) : + conP f r (conArg x w c c' i i') + = posAt (DataEncode.bitstringEncode + (V.positions x (BitString.toList + (PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩)))) i := by + rw [conP, conX_arg, conC3_arg, conRho_arg r hc, hfspec] + +include hfspec in +theorem conP'_arg {x w : List Bool} {c c' i i' : ℕ} (hc' : c' < 2 ^ r x.length) : + conP' f r (conArg x w c c' i i') + = posAt (DataEncode.bitstringEncode + (V.positions x (BitString.toList + (PCPVerifier.coinOfIndex (t := r x.length) ⟨c', hc'⟩)))) i' := by + rw [conP', conX_arg, conC4_arg, conRho'_arg r hc', hfspec] + +theorem conB_arg {x w : List Bool} {c c' i i' : ℕ} (hk : c * Q + i < w.length) : + conB Q (conArg x w c c' i i') = [w.getD (c * Q + i) false] := by + rw [conB, conW_arg, conC1_arg, conC3_arg, wBlock_one hk] + +theorem conB'_arg {x w : List Bool} {c c' i i' : ℕ} (hk : c' * Q + i' < w.length) : + conB' Q (conArg x w c c' i i') = [w.getD (c' * Q + i') false] := by + rw [conB', conW_arg, conC2_arg, conC4_arg, wBlock_one hk] + +/-! ### Unfolding the loops -/ + +theorem mem_consLang_iff_forall (x w : List Bool) : + pair x w ∈ consLang f r Q + ↔ ∀ c < 2 ^ r x.length, ∀ c' < 2 ^ r x.length, ∀ i < Q, ∀ i' < Q, + conArg x w c c' i i' ∈ consInner f r Q := by + rw [consLang, Set.mem_setOf_eq, Cobham.fstBlock_pair] + refine forall_congr' fun c => forall_congr' fun _ => ?_ + rw [consL1, Set.mem_setOf_eq, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + refine forall_congr' fun c' => forall_congr' fun _ => ?_ + rw [consL2, Set.mem_setOf_eq] + refine forall_congr' fun i => forall_congr' fun _ => ?_ + rw [consL3, Set.mem_setOf_eq] + rfl + +/-! ### The check is consistency -/ + +include hfspec in +/-- **The consistency check says exactly what it should.** -/ +theorem mem_consLang_iff {x w : List Bool} + (hw : w.length = 2 ^ r x.length * Q) + (hQ : ∀ rr : List Bool, (V.positions x rr).length ≤ Q) : + pair x w ∈ consLang f r Q + ↔ V.Consistent (r x.length) x (V.tableOf (r x.length) Q x w) := by + have hfit : ∀ c i : ℕ, c < 2 ^ r x.length → i < Q → c * Q + i < w.length := by + intro c i hc hi + rw [hw] + calc c * Q + i < c * Q + Q := by omega + _ = (c + 1) * Q := by ring + _ ≤ 2 ^ r x.length * Q := Nat.mul_le_mul_right _ hc + rw [mem_consLang_iff_forall] + constructor + · intro hR ρ ρ' i i' p hp hp' + have hc : PCPVerifier.coinIndex ρ < 2 ^ r x.length := PCPVerifier.coinIndex_lt ρ + have hc' : PCPVerifier.coinIndex ρ' < 2 ^ r x.length := PCPVerifier.coinIndex_lt ρ' + have hi : i < (V.positions x (BitString.toList ρ)).length := by + by_contra hcon + rw [List.getElem?_eq_none (by omega)] at hp + exact absurd hp (by simp) + have hi' : i' < (V.positions x (BitString.toList ρ')).length := by + by_contra hcon + rw [List.getElem?_eq_none (by omega)] at hp' + exact absurd hp' (by simp) + have hiQ : i < Q := lt_of_lt_of_le hi (hQ _) + have hiQ' : i' < Q := lt_of_lt_of_le hi' (hQ _) + have hpi : (V.positions x (BitString.toList ρ))[i]'hi = p := by + rw [List.getElem?_eq_getElem hi] at hp + exact Option.some.inj hp + have hpi' : (V.positions x (BitString.toList ρ'))[i']'hi' = p := by + rw [List.getElem?_eq_getElem hi'] at hp' + exact Option.some.inj hp' + have hstep := hR _ hc _ hc' i hiQ i' hiQ' + rw [mem_consInner_iff, conP_arg V f r hfspec hc, conP'_arg V f r hfspec hc', + PCPVerifier.coinOfIndex_coinIndex ρ hc, + PCPVerifier.coinOfIndex_coinIndex ρ' hc'] at hstep + have hbits := hstep ⟨by rw [posAt_eq_of_lt hi, posAt_eq_of_lt hi', hpi, hpi'], + posAt_ne_nil hi⟩ + rw [conB_arg Q (hfit _ _ hc hiQ), conB'_arg Q (hfit _ _ hc' hiQ')] at hbits + rw [getElem?_tableOf V _ _ _ _ _ hi, getElem?_tableOf V _ _ _ _ _ hi'] + have : w.getD (PCPVerifier.coinIndex ρ * Q + i) false + = w.getD (PCPVerifier.coinIndex ρ' * Q + i') false := by + simpa using hbits + rw [this] + · intro hC c hc c' hc' i hi i' hi' + rw [mem_consInner_iff, conP_arg V f r hfspec hc, conP'_arg V f r hfspec hc', + conB_arg Q (hfit _ _ hc hi), conB'_arg Q (hfit _ _ hc' hi')] + rintro ⟨heq, hne⟩ + set ρ := PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩ with hρ + set ρ' := PCPVerifier.coinOfIndex (t := r x.length) ⟨c', hc'⟩ with hρ' + have hin : i < (V.positions x (BitString.toList ρ)).length := by + by_contra hcon + exact hne (posAt_eq_nil (by omega)) + have hin' : i' < (V.positions x (BitString.toList ρ')).length := by + by_contra hcon + rw [posAt_eq_nil (l := V.positions x (BitString.toList ρ')) (by omega)] at heq + exact hne heq + have hpe : (V.positions x (BitString.toList ρ))[i]'hin + = (V.positions x (BitString.toList ρ'))[i']'hin' := + (posAt_eq_iff hin hin').mp heq + have hcons := hC ρ ρ' i i' ((V.positions x (BitString.toList ρ))[i]'hin) + (by rw [List.getElem?_eq_getElem hin]) (by rw [List.getElem?_eq_getElem hin', hpe]) + rw [getElem?_tableOf V _ _ _ _ _ hin, getElem?_tableOf V _ _ _ _ _ hin', + coinIndex_coinOfIndex, coinIndex_coinOfIndex] at hcons + simpa using Option.some.inj hcons + +end Consistency + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean b/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean new file mode 100644 index 00000000..12a2f03f --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Finset.Lattice.Fold +public import Mathlib.Data.Rat.Lemmas +public import Mathlib.Tactic.Positivity +public import Mathlib.Tactic.FieldSimp + +/-! +# Constraint graphs and their unsatisfiability value + +The combinatorial core of Dinur's proof of the PCP theorem. A *constraint +graph* over an alphabet `α` is a finite multigraph whose edges each carry a +binary constraint on the labels of their endpoints; an *assignment* labels the +vertices, and the *unsatisfiability value* `unsatVal` is the least fraction of +edges any assignment leaves unsatisfied. + +Dinur's amplification step is a transformation of constraint graphs that +preserves satisfiability (`unsatVal = 0`) while doubling `unsatVal` otherwise, +so all of that argument is phrased in terms of the definitions here. + +## Design + +- Vertices are `Fin numVerts` and edges are *indexed* by `Fin numEdges`, so + parallel edges and self-loops are allowed. Both are essential: powering a + constraint graph produces many parallel walk-edges, and the degree-reduction + and expanderization steps add edges to a graph that may already have them. +- Edges are directed (`tail`/`head`) and constraints are `Bool`-valued + functions of the two endpoint labels, which keeps everything decidable and + computable. Undirected graphs are modelled by including both orientations, + which the analysis of random walks will require explicitly rather than + implicitly. +- `unsatFrac` divides by `numEdges`, so an edgeless graph gets value `0` by + Lean's `x / 0 = 0` convention. Every lemma below is stated so that this is + the mathematically correct answer. + +## Main definitions + +- `ConstraintGraph`, `ConstraintGraph.Assignment`, `ConstraintGraph.Satisfies` +- `ConstraintGraph.unsatFrac` — the fraction of edges an assignment fails +- `ConstraintGraph.unsatVal` — the minimum of `unsatFrac` over all assignments +- `ConstraintGraph.Satisfiable` + +## Main results + +- `unsatFrac_eq_zero_iff` — an assignment wastes no edges exactly when it + satisfies them all +- `exists_assignment_unsatFrac_eq_unsatVal` — the minimum is attained +- `unsatVal_eq_zero_iff_satisfiable` — the gap-`0` case is satisfiability +- `unsatVal_nonneg`, `unsatVal_le_one` +-/ + +@[expose] public section + +namespace Complexity + +/-- A constraint graph over the alphabet `α`: a finite multigraph on the +vertices `Fin numVerts`, with edges indexed by `Fin numEdges`, each edge +carrying a binary constraint on the labels of its endpoints. -/ +structure ConstraintGraph (α : Type) where + /-- The number of vertices; the vertices are `Fin numVerts`. -/ + numVerts : ℕ + /-- The number of edges; the edges are indexed by `Fin numEdges`, so parallel + edges and self-loops are allowed. -/ + numEdges : ℕ + /-- The source of an edge. -/ + tail : Fin numEdges → Fin numVerts + /-- The target of an edge. -/ + head : Fin numEdges → Fin numVerts + /-- The constraint carried by an edge, as a predicate on the labels of its + tail and its head, in that order. -/ + rel : Fin numEdges → α → α → Bool + +namespace ConstraintGraph + +variable {α : Type} {G : ConstraintGraph α} + +/-- An assignment labels every vertex with a symbol of the alphabet. -/ +abbrev Assignment (G : ConstraintGraph α) : Type := Fin G.numVerts → α + +/-- Whether the assignment `a` satisfies the edge `e`, as a `Bool`. -/ +def satisfies (G : ConstraintGraph α) (a : G.Assignment) (e : Fin G.numEdges) : Bool := + G.rel e (a (G.tail e)) (a (G.head e)) + +/-- The assignment `a` satisfies the edge `e`. -/ +def Satisfies (G : ConstraintGraph α) (a : G.Assignment) (e : Fin G.numEdges) : Prop := + G.satisfies a e = true + +instance (G : ConstraintGraph α) (a : G.Assignment) (e : Fin G.numEdges) : + Decidable (G.Satisfies a e) := + inferInstanceAs (Decidable (G.satisfies a e = true)) + +theorem satisfies_iff {a : G.Assignment} {e : Fin G.numEdges} : + G.Satisfies a e ↔ G.rel e (a (G.tail e)) (a (G.head e)) = true := Iff.rfl + +/-- The edges left unsatisfied by `a`. -/ +def unsatEdges (G : ConstraintGraph α) (a : G.Assignment) : Finset (Fin G.numEdges) := + Finset.univ.filter fun e => ¬ G.Satisfies a e + +@[simp] theorem mem_unsatEdges {a : G.Assignment} {e : Fin G.numEdges} : + e ∈ G.unsatEdges a ↔ ¬ G.Satisfies a e := by + simp [unsatEdges] + +/-- The fraction of edges that `a` leaves unsatisfied. An edgeless graph has +value `0`. -/ +def unsatFrac (G : ConstraintGraph α) (a : G.Assignment) : ℚ := + ((G.unsatEdges a).card : ℚ) / (G.numEdges : ℚ) + +theorem unsatFrac_nonneg (a : G.Assignment) : 0 ≤ G.unsatFrac a := by + unfold unsatFrac; positivity + +theorem card_unsatEdges_le (a : G.Assignment) : (G.unsatEdges a).card ≤ G.numEdges := by + simpa using Finset.card_le_univ (G.unsatEdges a) + +theorem unsatFrac_le_one (a : G.Assignment) : G.unsatFrac a ≤ 1 := by + rcases Nat.eq_zero_or_pos G.numEdges with h | h + · simp [unsatFrac, h] + · have hpos : (0 : ℚ) < (G.numEdges : ℚ) := by exact_mod_cast h + rw [unsatFrac, div_le_one hpos] + exact_mod_cast card_unsatEdges_le a + +/-- An assignment wastes no edges exactly when it satisfies every edge. This +holds for the edgeless graph too, where both sides are trivially true. -/ +theorem unsatFrac_eq_zero_iff {a : G.Assignment} : + G.unsatFrac a = 0 ↔ ∀ e, G.Satisfies a e := by + constructor + · intro h e + by_contra he + have hne : (G.unsatEdges a).Nonempty := ⟨e, by simpa using he⟩ + have hcard : 0 < (G.unsatEdges a).card := Finset.card_pos.mpr hne + have hm : 0 < G.numEdges := lt_of_lt_of_le hcard (card_unsatEdges_le a) + have hmq : (0 : ℚ) < (G.numEdges : ℚ) := by exact_mod_cast hm + have hcq : (0 : ℚ) < ((G.unsatEdges a).card : ℚ) := by exact_mod_cast hcard + rw [unsatFrac, div_eq_zero_iff] at h + rcases h with h | h + · exact absurd h (ne_of_gt hcq) + · exact absurd h (ne_of_gt hmq) + · intro h + have : G.unsatEdges a = ∅ := by + ext e; simpa using h e + simp [unsatFrac, this] + +/-- A constraint graph is satisfiable when some assignment satisfies every +edge. -/ +def Satisfiable (G : ConstraintGraph α) : Prop := ∃ a : G.Assignment, ∀ e, G.Satisfies a e + +section Value + +variable [Fintype α] [Nonempty α] + +/-- The unsatisfiability value: the least fraction of edges any assignment +leaves unsatisfied. -/ +noncomputable def unsatVal (G : ConstraintGraph α) : ℚ := + (Finset.univ : Finset G.Assignment).inf' Finset.univ_nonempty G.unsatFrac + +theorem unsatVal_le (a : G.Assignment) : G.unsatVal ≤ G.unsatFrac a := + Finset.inf'_le _ (Finset.mem_univ a) + +theorem le_unsatVal {c : ℚ} (h : ∀ a : G.Assignment, c ≤ G.unsatFrac a) : c ≤ G.unsatVal := + Finset.le_inf' _ _ fun a _ => h a + +/-- The minimum defining `unsatVal` is attained. -/ +theorem exists_assignment_unsatFrac_eq_unsatVal (G : ConstraintGraph α) : + ∃ a : G.Assignment, G.unsatFrac a = G.unsatVal := by + obtain ⟨a, -, ha⟩ := Finset.exists_mem_eq_inf' (Finset.univ_nonempty) G.unsatFrac + exact ⟨a, ha.symm⟩ + +theorem unsatVal_nonneg (G : ConstraintGraph α) : 0 ≤ G.unsatVal := + le_unsatVal fun a => unsatFrac_nonneg a + +theorem unsatVal_le_one (G : ConstraintGraph α) : G.unsatVal ≤ 1 := by + obtain ⟨a, ha⟩ := G.exists_assignment_unsatFrac_eq_unsatVal + exact ha ▸ unsatFrac_le_one a + +/-- The zero-gap case is exactly satisfiability. -/ +theorem unsatVal_eq_zero_iff_satisfiable (G : ConstraintGraph α) : + G.unsatVal = 0 ↔ G.Satisfiable := by + constructor + · intro h + obtain ⟨a, ha⟩ := G.exists_assignment_unsatFrac_eq_unsatVal + exact ⟨a, unsatFrac_eq_zero_iff.mp (ha.trans h)⟩ + · rintro ⟨a, ha⟩ + have h0 : G.unsatFrac a = 0 := unsatFrac_eq_zero_iff.mpr ha + exact le_antisymm (h0 ▸ unsatVal_le a) G.unsatVal_nonneg + +omit [Fintype α] in +/-- An unsatisfiable graph has an edge, since otherwise any labelling works. -/ +theorem numEdges_pos_of_not_satisfiable (h : ¬ G.Satisfiable) : 0 < G.numEdges := by + rcases Nat.eq_zero_or_pos G.numEdges with h0 | h0 + · exact absurd ⟨(fun _ => Classical.arbitrary α : G.Assignment), fun e => absurd e.isLt + (by simp [h0])⟩ h + · exact h0 + +omit [Fintype α] in +/-- On an unsatisfiable graph every assignment fails at least one edge, so its +value is at least one edge's worth. -/ +theorem inv_numEdges_le_unsatFrac (h : ¬ G.Satisfiable) (a : G.Assignment) : + 1 / (G.numEdges : ℚ) ≤ G.unsatFrac a := by + have hpos : 0 < G.numEdges := numEdges_pos_of_not_satisfiable h + have hmq : (0 : ℚ) < (G.numEdges : ℚ) := by exact_mod_cast hpos + have hne : (G.unsatEdges a).Nonempty := by + by_contra hcon + rw [Finset.not_nonempty_iff_eq_empty] at hcon + refine h ⟨a, fun e => ?_⟩ + by_contra he + simpa [hcon] using (mem_unsatEdges (a := a) (e := e)).mpr he + have hcard : (1 : ℚ) ≤ ((G.unsatEdges a).card : ℚ) := by + exact_mod_cast Finset.card_pos.mpr hne + rw [unsatFrac] + gcongr + +theorem inv_numEdges_le_unsatVal (h : ¬ G.Satisfiable) : + 1 / (G.numEdges : ℚ) ≤ G.unsatVal := + le_unsatVal fun a => inv_numEdges_le_unsatFrac h a + +theorem unsatVal_pos_of_not_satisfiable (h : ¬ G.Satisfiable) : 0 < G.unsatVal := by + refine lt_of_lt_of_le ?_ (inv_numEdges_le_unsatVal h) + have : (0 : ℚ) < (G.numEdges : ℚ) := by + exact_mod_cast numEdges_pos_of_not_satisfiable h + positivity + +/-- A positive value certifies unsatisfiability. -/ +theorem not_satisfiable_of_unsatVal_pos {G : ConstraintGraph α} (h : 0 < G.unsatVal) : + ¬ G.Satisfiable := fun hs => absurd ((unsatVal_eq_zero_iff_satisfiable G).mpr hs) (ne_of_gt h) + +end Value + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean b/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean new file mode 100644 index 00000000..73c8175b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.BooleanAnalysis.FourierExpansion +public import Mathlib.Logic.Equiv.Fin.Basic + +/-! +# Blocks of a cube, and marginals + +An assignment tester makes several reads, each with its own randomness. The +Fourier layer supplies probability over *one* cube point (`Pr`) and over a pair +(`Pr₂`), but not over `k` independent points, and building a `k`-fold product +measure would be a detour. + +The alternative taken here is to bundle: the tester's whole random string is a +single point of a larger cube, and each read uses its own block. What makes this +work is that the uniform measure on the big cube restricts to the uniform measure +on each block — proved below — so the existing one-variable lemmas apply to each +read, and the existing union bound combines them. + +## Main definitions + +- `Complexity.leftBlock`, `Complexity.rightBlock` — the two halves of a point + +## Main results + +- `Complexity.prob_leftBlock`, `Complexity.prob_rightBlock` — a block is + uniformly distributed +- `Complexity.prob_forall_ge` — the union bound combining many reads +- `Complexity.prob_leftBlock_rightBlock` — marginals compose, so any fixed + number of blocks can be bundled +- `Complexity.prob₂_eq_prob_blocks` — a probability over a pair is a + probability over one bundled point +- `Complexity.prob_le_of_imp_of_good` — transferring an observed acceptance + probability along a likely good event +- `Complexity.prob_blocks`, `Complexity.prob_blocks_ge` — conditioning on an + earlier block, so a read point may depend on earlier randomness +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +variable {a b : ℕ} + +/-- The first block of a point of the combined cube. -/ +def leftBlock (z : Cube (a + b)) : Cube a := fun i => z (Fin.castAdd b i) + +/-- The second block of a point of the combined cube. -/ +def rightBlock (z : Cube (a + b)) : Cube b := fun j => z (Fin.natAdd a j) + +theorem leftBlock_append (x : Cube a) (y : Cube b) : + leftBlock (Fin.append x y) = x := by + funext i + show Fin.append x y (Fin.castAdd b i) = x i + rw [Fin.append_left] + +theorem rightBlock_append (x : Cube a) (y : Cube b) : + rightBlock (Fin.append x y) = y := by + funext j + show Fin.append x y (Fin.natAdd a j) = y j + rw [Fin.append_right] + +/-- Splitting a point of the combined cube into its blocks is a bijection. -/ +noncomputable def cubeBlockEquiv (a b : ℕ) : Cube a × Cube b ≃ Cube (a + b) := + Fin.appendEquiv a b + +theorem leftBlock_blockEquiv (p : Cube a × Cube b) : + leftBlock (cubeBlockEquiv a b p) = p.1 := leftBlock_append p.1 p.2 + +theorem rightBlock_blockEquiv (p : Cube a × Cube b) : + rightBlock (cubeBlockEquiv a b p) = p.2 := rightBlock_append p.1 p.2 + +/-- **The first block is uniform.** A predicate depending only on the first +block has the same probability over the combined cube as over its own. -/ +theorem prob_leftBlock (P : Cube a → Prop) : + Pr[fun z : Cube (a + b) => P (leftBlock z)] = Pr[P] := by + classical + rw [BooleanAnalysis.prob, BooleanAnalysis.prob, expect_unfold, expect_unfold] + have hsum : ∑ z : Cube (a + b), indicator (fun z => P (leftBlock z)) z + = ∑ p : Cube a × Cube b, indicator P p.1 := by + refine Fintype.sum_equiv (cubeBlockEquiv a b).symm _ _ fun z => ?_ + show indicator (fun z => P (leftBlock z)) z + = indicator P ((cubeBlockEquiv a b).symm z).1 + have hz : leftBlock z = ((cubeBlockEquiv a b).symm z).1 := by + rw [← leftBlock_blockEquiv ((cubeBlockEquiv a b).symm z), Equiv.apply_symm_apply] + simp only [indicator, hz] + rw [hsum, Fintype.sum_prod_type] + have hinner : ∀ x : Cube a, ∑ _y : Cube b, indicator P x + = (2 : ℝ) ^ b * indicator P x := by + intro x + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + have hcard : Fintype.card (Cube b) = 2 ^ b := by + show Fintype.card (Fin b → ZMod 2) = 2 ^ b + rw [Fintype.card_fun, ZMod.card, Fintype.card_fin] + rw [hcard] + norm_num + rw [Finset.sum_congr rfl fun x _ => hinner x, ← Finset.mul_sum] + have hpa : (2 : ℝ) ^ a ≠ 0 := by positivity + have hpb : (2 : ℝ) ^ b ≠ 0 := by positivity + rw [pow_add] + field_simp + +/-- **The second block is uniform** too. -/ +theorem prob_rightBlock (P : Cube b → Prop) : + Pr[fun z : Cube (a + b) => P (rightBlock z)] = Pr[P] := by + classical + rw [BooleanAnalysis.prob, BooleanAnalysis.prob, expect_unfold, expect_unfold] + have hsum : ∑ z : Cube (a + b), indicator (fun z => P (rightBlock z)) z + = ∑ p : Cube a × Cube b, indicator P p.2 := by + refine Fintype.sum_equiv (cubeBlockEquiv a b).symm _ _ fun z => ?_ + show indicator (fun z => P (rightBlock z)) z + = indicator P ((cubeBlockEquiv a b).symm z).2 + have hz : rightBlock z = ((cubeBlockEquiv a b).symm z).2 := by + rw [← rightBlock_blockEquiv ((cubeBlockEquiv a b).symm z), Equiv.apply_symm_apply] + simp only [indicator, hz] + rw [hsum, Fintype.sum_prod_type_right] + have hinner : ∀ y : Cube b, ∑ _x : Cube a, indicator P y + = (2 : ℝ) ^ a * indicator P y := by + intro y + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + have hcard : Fintype.card (Cube a) = 2 ^ a := by + show Fintype.card (Fin a → ZMod 2) = 2 ^ a + rw [Fintype.card_fun, ZMod.card, Fintype.card_fin] + rw [hcard] + norm_num + rw [Finset.sum_congr rfl fun y _ => hinner y, ← Finset.mul_sum] + have hpa : (2 : ℝ) ^ a ≠ 0 := by positivity + have hpb : (2 : ℝ) ^ b ≠ 0 := by positivity + rw [pow_add] + field_simp + +/-! ### A union bound over many reads -/ + +theorem prob_of_forall {m : ℕ} {P : Cube m → Prop} (h : ∀ x, P x) : Pr[P] = 1 := by + classical + have hc := BooleanAnalysis.Internal.prob_compl P + have hzero : Pr[fun x => ¬ P x] = 0 := by + rw [BooleanAnalysis.prob, expect_unfold] + have hterm : ∀ x : Cube m, indicator (fun x => ¬ P x) x = 0 := by + intro x + simp [indicator, h x] + rw [Finset.sum_congr rfl fun x _ => hterm x] + simp + linarith + +/-- **Union bound over `k` events.** If each of `k` events holds except with +probability `ε`, all hold except with probability `k · ε`. With the tester's +randomness bundled into one point, each read's correctness is an event on that +point, so this is the bound that combines them. -/ +theorem prob_forall_ge {m : ℕ} : ∀ (k : ℕ) (P : Fin k → Cube m → Prop) (ε : ℝ), + (∀ i, 1 - ε ≤ Pr[P i]) → 1 - k * ε ≤ Pr[fun z => ∀ i, P i z] := by + intro k + induction k with + | zero => + intro P ε _ + have hall : Pr[fun z : Cube m => ∀ i : Fin 0, P i z] = 1 := + prob_of_forall fun z i => absurd i.isLt (by omega) + rw [hall] + norm_num + | succ k ih => + intro P ε hP + have hrest := ih (fun i => P i.succ) ε fun i => hP i.succ + have hcompl0 : Pr[fun z => ¬ P 0 z] ≤ ε := by + have h1 := BooleanAnalysis.Internal.prob_compl (P 0) + have h2 := hP 0 + linarith + have hcomplr : Pr[fun z => ¬ (∀ i : Fin k, P i.succ z)] ≤ k * ε := by + have h1 := BooleanAnalysis.Internal.prob_compl + (fun z => ∀ i : Fin k, P i.succ z) + linarith + have hunion := BooleanAnalysis.Internal.prob_union_bound + (P := fun z => ∀ i : Fin (k + 1), P i z) + (Q := fun z => ¬ P 0 z) + (R := fun z => ¬ (∀ i : Fin k, P i.succ z)) + (fun z hz => by + by_contra hcon + push Not at hcon + exact hz fun i => Fin.cases hcon.1 (fun j => hcon.2 j) i) + have hc := BooleanAnalysis.Internal.prob_compl (fun z => ∀ i : Fin (k + 1), P i z) + push_cast + linarith + +/-! ### Composed blocks -/ + +/-- Marginals compose: a block of a block is still uniform. Iterating this gives +a bundled random string with any fixed number of independent blocks, which is all +a tester with constantly many reads needs. -/ +theorem prob_leftBlock_rightBlock {a b c : ℕ} (P : Cube b → Prop) : + Pr[fun z : Cube (a + (b + c)) => P (leftBlock (rightBlock z))] = Pr[P] := by + have h1 : Pr[fun z : Cube (a + (b + c)) => P (leftBlock (rightBlock z))] + = Pr[fun w : Cube (b + c) => P (leftBlock w)] := + prob_rightBlock (fun w : Cube (b + c) => P (leftBlock w)) + rw [h1] + exact prob_leftBlock P + +theorem prob_rightBlock_rightBlock {a b c : ℕ} (P : Cube c → Prop) : + Pr[fun z : Cube (a + (b + c)) => P (rightBlock (rightBlock z))] = Pr[P] := by + have h1 : Pr[fun z : Cube (a + (b + c)) => P (rightBlock (rightBlock z))] + = Pr[fun w : Cube (b + c) => P (rightBlock w)] := + prob_rightBlock (fun w : Cube (b + c) => P (rightBlock w)) + rw [h1] + exact prob_rightBlock P + +/-! ### Pairs are two blocks -/ + +/-- **`Pr₂` is a bundled `Pr`.** The Fourier layer's probability over a pair of +independent points is the probability over a single point of the doubled cube, +read as two blocks. + +This is the bridge that lets the pair-based statements (the consistency check) +and the block-based statements (the self-corrected reads) be combined: after +rewriting, both are probabilities over one cube, so a union bound applies. -/ +theorem prob₂_eq_prob_blocks {n : ℕ} (P : Cube n → Cube n → Prop) : + Pr₂[P] = Pr[fun z : Cube (n + n) => P (leftBlock z) (rightBlock z)] := by + classical + have hL : Pr₂[P] + = 1 / 2 ^ n * ∑ x : Cube n, (1 / 2 ^ n * ∑ y : Cube n, indicator (P x) y) := by + rw [BooleanAnalysis.prob₂, expect_unfold] + exact congrArg _ (Finset.sum_congr rfl fun x _ => expect_unfold _) + have hR : Pr[fun z : Cube (n + n) => P (leftBlock z) (rightBlock z)] + = 1 / 2 ^ (n + n) * ∑ p : Cube n × Cube n, indicator (P p.1) p.2 := by + rw [BooleanAnalysis.prob, expect_unfold] + refine congrArg _ (Fintype.sum_equiv (cubeBlockEquiv n n).symm _ _ fun z => ?_) + show indicator (fun z => P (leftBlock z) (rightBlock z)) z + = indicator (P ((cubeBlockEquiv n n).symm z).1) ((cubeBlockEquiv n n).symm z).2 + have h1 : leftBlock z = ((cubeBlockEquiv n n).symm z).1 := by + rw [← leftBlock_blockEquiv ((cubeBlockEquiv n n).symm z), Equiv.apply_symm_apply] + have h2 : rightBlock z = ((cubeBlockEquiv n n).symm z).2 := by + rw [← rightBlock_blockEquiv ((cubeBlockEquiv n n).symm z), Equiv.apply_symm_apply] + simp only [indicator, h1, h2] + rw [hL, hR, Fintype.sum_prod_type, ← Finset.mul_sum, pow_add] + have h2n : (2 : ℝ) ^ n ≠ 0 := by positivity + field_simp + +/-- A pair drawn from the first block of a bundled string is a uniform pair, +so a `Pr₂` statement can be read as a statement about the bundled randomness +that the tester's other reads also draw from. -/ +theorem prob_pair_block {n c : ℕ} (P : Cube n → Cube n → Prop) : + Pr[fun z : Cube ((n + n) + c) => + P (leftBlock (leftBlock z)) (rightBlock (leftBlock z))] = Pr₂[P] := by + have h := prob_leftBlock (b := c) (fun w : Cube (n + n) => P (leftBlock w) (rightBlock w)) + rw [h, prob₂_eq_prob_blocks] + +/-- **Transfer along a likely good event.** If `E` implies `F` whenever `A` +holds, then `E` is no likelier than `F` plus the chance that `A` fails. + +This is how a tester's observed acceptance is converted into a statement about +the decoded tables: `E` is "the tester accepts", `A` is "every self-corrected +read returned the true value", and `F` is the check as made on the decoded +codewords. -/ +theorem prob_le_of_imp_of_good {m : ℕ} {E F A : Cube m → Prop} + (h : ∀ z, E z → A z → F z) : Pr[E] ≤ Pr[F] + (1 - Pr[A]) := by + classical + have hub : Pr[fun z => ¬ ¬ E z] ≤ Pr[F] + Pr[fun z => ¬ A z] := + BooleanAnalysis.Internal.prob_union_bound (P := fun z => ¬ E z) fun z hz => by + have hE : E z := not_not.mp hz + by_cases hA : A z + · exact Or.inl (h z hE hA) + · exact Or.inr hA + have hfun : (fun z => ¬ ¬ E z) = E := by funext z; simp + rw [hfun] at hub + have hA := BooleanAnalysis.Internal.prob_compl A + linarith + +/-! ### Conditioning on an earlier block -/ + +/-- **Fubini for blocks.** A predicate reading both blocks has probability equal +to the average, over the first block, of its conditional probability in the +second. + +This is what lets a tester choose *where* to read using early randomness and +still get a uniform correction string: the read point is fixed by `u`, and the +inner probability is the ordinary one-variable statement. -/ +theorem prob_blocks {a b : ℕ} (Q : Cube a → Cube b → Prop) : + Pr[fun z : Cube (a + b) => Q (leftBlock z) (rightBlock z)] + = 𝔼[fun u : Cube a => Pr[Q u]] := by + classical + have hL : Pr[fun z : Cube (a + b) => Q (leftBlock z) (rightBlock z)] + = 1 / 2 ^ (a + b) * ∑ p : Cube a × Cube b, indicator (Q p.1) p.2 := by + rw [BooleanAnalysis.prob, expect_unfold] + refine congrArg _ (Fintype.sum_equiv (cubeBlockEquiv a b).symm _ _ fun z => ?_) + show indicator (fun z => Q (leftBlock z) (rightBlock z)) z + = indicator (Q ((cubeBlockEquiv a b).symm z).1) ((cubeBlockEquiv a b).symm z).2 + have h1 : leftBlock z = ((cubeBlockEquiv a b).symm z).1 := by + rw [← leftBlock_blockEquiv ((cubeBlockEquiv a b).symm z), Equiv.apply_symm_apply] + have h2 : rightBlock z = ((cubeBlockEquiv a b).symm z).2 := by + rw [← rightBlock_blockEquiv ((cubeBlockEquiv a b).symm z), Equiv.apply_symm_apply] + simp only [indicator, h1, h2] + have hR : 𝔼[fun u : Cube a => Pr[Q u]] + = 1 / 2 ^ a * ∑ u : Cube a, (1 / 2 ^ b * ∑ v : Cube b, indicator (Q u) v) := by + rw [expect_unfold] + exact congrArg _ (Finset.sum_congr rfl fun u _ => expect_unfold _) + rw [hL, hR, Fintype.sum_prod_type, ← Finset.mul_sum, pow_add] + have h2a : (2 : ℝ) ^ a ≠ 0 := by positivity + have h2b : (2 : ℝ) ^ b ≠ 0 := by positivity + field_simp + +/-- **A bound that holds for every earlier outcome holds overall.** -/ +theorem prob_blocks_ge {a b : ℕ} (Q : Cube a → Cube b → Prop) (c : ℝ) + (h : ∀ u, c ≤ Pr[Q u]) : + c ≤ Pr[fun z : Cube (a + b) => Q (leftBlock z) (rightBlock z)] := by + classical + rw [prob_blocks, expect_unfold] + have hcard : (Finset.univ : Finset (Cube a)).card = 2 ^ a := by + rw [Finset.card_univ] + show Fintype.card (Fin a → ZMod 2) = 2 ^ a + rw [Fintype.card_fun, ZMod.card, Fintype.card_fin] + have hsum : ∑ _u : Cube a, c ≤ ∑ u : Cube a, Pr[Q u] := + Finset.sum_le_sum fun u _ => h u + rw [Finset.sum_const, hcard, nsmul_eq_mul] at hsum + push_cast at hsum + have hpa : (0 : ℝ) < 2 ^ a := by positivity + rw [one_div, inv_mul_eq_div, le_div_iff₀ hpa, mul_comm] + exact hsum + +/-- **Two likely events are jointly likely.** The union bound in the form the +tester uses: each read fails with its own probability, and the failures add. -/ +theorem prob_and_ge {m : ℕ} {P Q : Cube m → Prop} {p q : ℝ} + (hP : 1 - p ≤ Pr[P]) (hQ : 1 - q ≤ Pr[Q]) : + 1 - (p + q) ≤ Pr[fun z => P z ∧ Q z] := by + classical + have hcP := BooleanAnalysis.Internal.prob_compl P + have hcQ := BooleanAnalysis.Internal.prob_compl Q + have hcPQ := BooleanAnalysis.Internal.prob_compl fun z => P z ∧ Q z + have hunion := BooleanAnalysis.Internal.prob_union_bound + (P := fun z => P z ∧ Q z) (Q := fun z => ¬ P z) (R := fun z => ¬ Q z) + fun z hz => by + by_cases hp : P z + · exact Or.inr fun hq => hz ⟨hp, hq⟩ + · exact Or.inl hp + linarith + +/-- **A likely event happens.** Used to turn a probabilistic guarantee about a +tester's reads into a single random string on which every read is right — the +argument for a check whose conclusion is deterministic. -/ +theorem exists_of_prob_pos {m : ℕ} {P : Cube m → Prop} (h : 0 < Pr[P]) : ∃ z, P z := by + classical + by_contra hcon + push Not at hcon + have hzero : Pr[P] = 0 := by + rw [BooleanAnalysis.prob, expect_unfold] + have hind : ∀ z : Cube m, indicator P z = 0 := fun z => by + simp [indicator, hcon z] + rw [Finset.sum_congr rfl fun z _ => hind z] + simp + linarith + +/-- A probability is a count over the cube. -/ +theorem prob_eq_card_div {m : ℕ} (P : Cube m → Prop) [DecidablePred P] : + Pr[P] = ((Finset.univ.filter P).card : ℝ) / 2 ^ m := by + classical + rw [BooleanAnalysis.prob, expect_unfold] + have h : ∑ z : Cube m, indicator P z = ((Finset.univ.filter P).card : ℝ) := by + rw [Finset.card_filter] + push_cast + exact Finset.sum_congr rfl fun z _ => by + simp only [indicator] + split_ifs <;> rfl + rw [h] + ring + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean b/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean new file mode 100644 index 00000000..53cd88d0 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean @@ -0,0 +1,540 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.WalkDart +public import Complexitylib.Classes.PCP.Internal.Mixing +public import Mathlib.Algebra.BigOperators.Intervals +public import Mathlib.Algebra.Ring.GeomSum + +/-! +# Counting a dart set by tail and by head + +The bookkeeping that turns `WalkDart.sum_two_darts_fixed` — the operator form of +"the walk crosses `F` at step `k` and again at step `l`" — into something +`Mixing.mixing_sq` can estimate. + +Two counts of a dart set are needed. `dartCount F v` counts the `F`-darts +*leaving* `v`, and `headCount F z` counts those *arriving* at `z`. Both sum to +`F.card`, and each is at most the degree. The first is the function whose +`stepIter` the second crossing sees; the second is the measure the first +crossing leaves behind. + +## Main definitions + +- `RegGraph.dartCount`, `RegGraph.headCount` + +## Main results + +- `RegGraph.sum_dartCount`, `RegGraph.sum_headCount` — both count `F` +- `RegGraph.dartCount_le`, `RegGraph.headCount_le` — at most the degree +- `RegGraph.sum_indicator_nbr` — a sum over `F`-darts of a function of the head + is a sum over vertices weighted by `headCount` +- `RegGraph.step_sum`, `RegGraph.stepIter_sum` — the walk operator is linear + over finite sums +- `RegGraph.sum_indicator_dartCount`, `RegGraph.sum_indicator_mul` — indicator + sums collapse to the two counts +- `RegGraph.sum_two_crossings` — two crossings of `F`, in operator form +- `RegGraph.sum_headCount_stepIter_le` — the correlation bound: two crossings + `t` steps apart are independent up to `lam ^ t * deg * |F|` +- `geom_sum_le_inv`, `sum_pairs_geom_le` — summing that over all position pairs + costs only `m / (1 - lam)` +- `RegGraph.sum_pairs_le` — the second moment: all pairs of crossings together +- `card_sq_eq_add_two_mul_pairs` — a squared count is the count plus twice the + ordered pairs +- `card_filter_eq_sum_prod`, `sum_pairs_eq_sum_Ico` — index bookkeeping for the + second moment +-/ + +@[expose] public section + +namespace Complexity + +/-! ### Geometric sums -/ + +/-- A truncated geometric series is bounded by its limit. -/ +theorem geom_sum_le_inv {lam : ℝ} (h0 : 0 ≤ lam) (h1 : lam < 1) (n : ℕ) : + ∑ i ∈ Finset.range n, lam ^ i ≤ 1 / (1 - lam) := by + have hpos : (0 : ℝ) < 1 - lam := by linarith + have hmul : (∑ i ∈ Finset.range n, lam ^ i) * (lam - 1) = lam ^ n - 1 := geom_sum_mul lam n + have hmul' : (∑ i ∈ Finset.range n, lam ^ i) * (1 - lam) = 1 - lam ^ n := by + nlinarith [hmul] + have hpow : (0 : ℝ) ≤ lam ^ n := by positivity + rw [le_div_iff₀ hpos] + linarith [hmul'] + +/-- Summed over all pairs of positions, the separation weights `lam ^ (l-k-1)` +contribute at most `m / (1 - lam)`. -/ +theorem sum_pairs_geom_le {lam : ℝ} (h0 : 0 ≤ lam) (h1 : lam < 1) (m : ℕ) : + ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, lam ^ (l - k - 1) + ≤ (m : ℝ) * (1 / (1 - lam)) := by + have hinner : ∀ k ∈ Finset.range m, + ∑ l ∈ Finset.Ico (k + 1) m, lam ^ (l - k - 1) ≤ 1 / (1 - lam) := by + intro k _ + have hre : ∑ l ∈ Finset.Ico (k + 1) m, lam ^ (l - k - 1) + = ∑ i ∈ Finset.range (m - (k + 1)), lam ^ i := by + rw [Finset.sum_Ico_eq_sum_range] + refine Finset.sum_congr rfl fun i _ => ?_ + congr 1 + omega + rw [hre] + exact geom_sum_le_inv h0 h1 _ + calc ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, lam ^ (l - k - 1) + ≤ ∑ _k ∈ Finset.range m, (1 / (1 - lam)) := Finset.sum_le_sum hinner + _ = (m : ℝ) * (1 / (1 - lam)) := by + rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul] + +/-! ### Squares and ordered pairs -/ + +/-- The square of a count is the count plus twice the ordered pairs. This is how +`∑ N ^ 2` in the second-moment method becomes a sum over *pairs* of crossings, +which is what the correlation bound estimates. -/ +theorem card_sq_eq_add_two_mul_pairs {ι : Type*} [LinearOrder ι] [DecidableEq ι] + (S : Finset ι) : + S.card ^ 2 = S.card + 2 * ((S ×ˢ S).filter fun p => p.1 < p.2).card := by + classical + have hswap : ((S ×ˢ S).filter fun p => p.1 < p.2).card + = ((S ×ˢ S).filter fun p => p.2 < p.1).card := by + refine Finset.card_bij (fun p _ => (p.2, p.1)) ?_ ?_ ?_ + · intro p hp + simp only [Finset.mem_filter, Finset.mem_product] at hp ⊢ + exact ⟨⟨hp.1.2, hp.1.1⟩, hp.2⟩ + · intro p _ p' _ hpp + have h1 : p.2 = p'.2 := congrArg Prod.fst hpp + have h2 : p.1 = p'.1 := congrArg Prod.snd hpp + exact Prod.ext h2 h1 + · intro p hp + simp only [Finset.mem_filter, Finset.mem_product] at hp + refine ⟨(p.2, p.1), ?_, rfl⟩ + simp only [Finset.mem_filter, Finset.mem_product] + exact ⟨⟨hp.1.2, hp.1.1⟩, hp.2⟩ + have hdiag : ((S ×ˢ S).filter fun p => p.1 = p.2).card = S.card := by + refine Finset.card_bij (fun p _ => p.1) ?_ ?_ ?_ + · intro p hp + simp only [Finset.mem_filter, Finset.mem_product] at hp + exact hp.1.1 + · intro p hp p' hp' hpp + simp only [Finset.mem_filter, Finset.mem_product] at hp hp' + refine Prod.ext hpp ?_ + rw [← hp.2, ← hp'.2] + exact hpp + · intro a ha + refine ⟨(a, a), ?_, rfl⟩ + simp [ha] + have hnotlt : ((S ×ˢ S).filter fun p => ¬ p.1 < p.2).card + = ((S ×ˢ S).filter fun p => p.1 = p.2).card + + ((S ×ˢ S).filter fun p => p.2 < p.1).card := by + rw [← Finset.card_union_of_disjoint] + · congr 1 + ext p + simp only [Finset.mem_filter, Finset.mem_union, Finset.mem_product] + constructor + · rintro ⟨hmem, hlt⟩ + rcases lt_trichotomy p.1 p.2 with h | h | h + · exact absurd h hlt + · exact Or.inl ⟨hmem, h⟩ + · exact Or.inr ⟨hmem, h⟩ + · rintro (⟨hmem, heq⟩ | ⟨hmem, hgt⟩) + · exact ⟨hmem, by rw [heq]; exact lt_irrefl _⟩ + · exact ⟨hmem, not_lt_of_gt hgt⟩ + · refine Finset.disjoint_left.mpr fun p hp hp' => ?_ + simp only [Finset.mem_filter] at hp hp' + rw [hp.2] at hp' + exact absurd hp'.2 (lt_irrefl _) + have htotal : (S ×ˢ S).card + = ((S ×ˢ S).filter fun p => p.1 < p.2).card + + ((S ×ˢ S).filter fun p => ¬ p.1 < p.2).card := + (Finset.card_filter_add_card_filter_not _).symm + rw [Finset.card_product] at htotal + rw [sq] + omega + +/-- A count of a conjunction is a sum of products of indicators. -/ +theorem card_filter_eq_sum_prod {ι : Type*} [Fintype ι] (P Q : ι → Prop) + [DecidablePred P] [DecidablePred Q] : + (((Finset.univ.filter fun i => P i ∧ Q i).card : ℕ) : ℝ) + = ∑ i, (if P i then (1 : ℝ) else 0) * (if Q i then (1 : ℝ) else 0) := by + classical + rw [Finset.card_filter] + push_cast + refine Finset.sum_congr rfl fun i _ => ?_ + by_cases hp : P i <;> by_cases hq : Q i <;> simp [hp, hq] + +/-- A sum over ordered pairs below `T`, as an iterated sum. -/ +theorem sum_pairs_eq_sum_Ico {M : Type*} [AddCommMonoid M] (T : ℕ) (f : ℕ × ℕ → M) : + ∑ p ∈ ((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2, f p + = ∑ k ∈ Finset.range T, ∑ l ∈ Finset.Ico (k + 1) T, f (k, l) := by + classical + rw [Finset.sum_filter, Finset.sum_product] + refine Finset.sum_congr rfl fun k _ => ?_ + rw [← Finset.sum_filter] + congr 1 + ext l + simp only [Finset.mem_filter, Finset.mem_range, Finset.mem_Ico] + omega + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Linearity of the walk operator -/ + +theorem step_sum {ι : Type*} (s : Finset ι) (f : ι → G.V → ℝ) (v : G.V) : + G.step (fun w => ∑ i ∈ s, f i w) v = ∑ i ∈ s, G.step (f i) v := by + simp only [step] + rw [← Finset.sum_div] + congr 1 + exact Finset.sum_comm + +theorem stepIter_sum {ι : Type*} (s : Finset ι) (f : ι → G.V → ℝ) (t : ℕ) (v : G.V) : + G.stepIter t (fun w => ∑ i ∈ s, f i w) v = ∑ i ∈ s, G.stepIter t (f i) v := by + induction t generalizing v with + | zero => simp + | succ t ih => + rw [stepIter_succ] + have hfun : G.stepIter t (fun w => ∑ i ∈ s, f i w) + = fun w => ∑ i ∈ s, G.stepIter t (f i) w := by + funext w + exact ih w + rw [hfun, G.step_sum] + exact Finset.sum_congr rfl fun i _ => by rw [← stepIter_succ] + +/-- How many darts of `F` leave `v`. -/ +def dartCount (F : Finset (G.V × G.D)) (v : G.V) : ℕ := + (F.filter fun p => p.1 = v).card + +/-- How many darts of `F` arrive at `z`. -/ +def headCount (F : Finset (G.V × G.D)) (z : G.V) : ℕ := + (F.filter fun p => G.nbr p.1 p.2 = z).card + +theorem sum_dartCount (F : Finset (G.V × G.D)) : + ∑ v : G.V, G.dartCount F v = F.card := + (Finset.card_eq_sum_card_fiberwise fun p _ => Finset.mem_univ p.1).symm + +theorem sum_headCount (F : Finset (G.V × G.D)) : + ∑ z : G.V, G.headCount F z = F.card := + (Finset.card_eq_sum_card_fiberwise fun p _ => Finset.mem_univ (G.nbr p.1 p.2)).symm + +theorem dartCount_le (F : Finset (G.V × G.D)) (v : G.V) : G.dartCount F v ≤ G.deg := by + classical + have hsub : (F.filter fun p => p.1 = v) ⊆ ({v} : Finset G.V) ×ˢ (Finset.univ : Finset G.D) := by + intro p hp + simp only [Finset.mem_filter] at hp + simp only [Finset.mem_product, Finset.mem_singleton, Finset.mem_univ, and_true] + exact hp.2 + calc G.dartCount F v ≤ (({v} : Finset G.V) ×ˢ (Finset.univ : Finset G.D)).card := + Finset.card_le_card hsub + _ = G.deg := by + rw [Finset.card_product, Finset.card_singleton, one_mul, Finset.card_univ] + rfl + +/-- The darts arriving at `z` correspond, under reversal, to the darts leaving +`z`, so there are at most `deg` of them. -/ +theorem headCount_le (F : Finset (G.V × G.D)) (z : G.V) : G.headCount F z ≤ G.deg := by + classical + have hinj : Set.InjOn (fun p : G.V × G.D => (G.rot p).2) + (F.filter fun p => G.nbr p.1 p.2 = z) := by + intro p hp p' hp' hval + simp only [Finset.coe_filter, Set.mem_setOf_eq] at hp hp' + have hp1 : (G.rot p).1 = z := hp.2 + have hp'1 : (G.rot p').1 = z := hp'.2 + have hpair : G.rot p = G.rot p' := Prod.ext (hp1.trans hp'1.symm) hval + have := congrArg G.rot hpair + rwa [G.rot_involutive p, G.rot_involutive p'] at this + calc G.headCount F z + ≤ (Finset.univ : Finset G.D).card := by + rw [headCount] + exact Finset.card_le_card_of_injOn _ (fun p _ => Finset.mem_univ _) hinj + _ = G.deg := by rw [Finset.card_univ]; rfl + +/-- Summing a function of a dart's head over `F` is summing over vertices with +the multiplicity `headCount`. -/ +theorem sum_indicator_nbr (F : Finset (G.V × G.D)) (h : G.V → ℝ) : + ∑ p ∈ F, h (G.nbr p.1 p.2) = ∑ z : G.V, (G.headCount F z : ℝ) * h z := by + classical + rw [← Finset.sum_fiberwise_of_maps_to (fun p (_ : p ∈ F) => Finset.mem_univ (G.nbr p.1 p.2)) + (fun p => h (G.nbr p.1 p.2))] + refine Finset.sum_congr rfl fun z _ => ?_ + have hconst : ∀ p ∈ F.filter fun p => G.nbr p.1 p.2 = z, h (G.nbr p.1 p.2) = h z := by + intro p hp + simp only [Finset.mem_filter] at hp + rw [hp.2] + rw [Finset.sum_congr rfl hconst, Finset.sum_const, nsmul_eq_mul] + rfl + +/-! ### Indicator sums -/ + +/-- Summing the `F`-indicator over the labels at a fixed vertex counts the +`F`-darts there. -/ +theorem sum_indicator_dartCount (F : Finset (G.V × G.D)) (z : G.V) : + ∑ b : G.D, (if (z, b) ∈ F then (1 : ℝ) else 0) = (G.dartCount F z : ℝ) := by + classical + rw [Finset.sum_boole] + congr 1 + rw [dartCount] + refine Finset.card_bij (fun b _ => (z, b)) ?_ ?_ ?_ + · intro b hb + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hb ⊢ + simpa using hb + · intro b _ b' _ hbb + exact (Prod.ext_iff.mp hbb).2 + · rintro ⟨y, b⟩ hp + simp only [Finset.mem_filter] at hp + obtain ⟨hmem, hy⟩ := hp + subst hy + exact ⟨b, by simpa using hmem, rfl⟩ + +/-- Summing an `F`-weighted function of a dart's head over all darts is summing +it over `F`. -/ +theorem sum_indicator_mul (F : Finset (G.V × G.D)) (φ : G.V → ℝ) : + ∑ a : G.D, ∑ y : G.V, (if (y, a) ∈ F then (1 : ℝ) else 0) * φ (G.nbr y a) + = ∑ p ∈ F, φ (G.nbr p.1 p.2) := by + classical + have hswap : ∑ a : G.D, ∑ y : G.V, (if (y, a) ∈ F then (1 : ℝ) else 0) * φ (G.nbr y a) + = ∑ p : G.V × G.D, (if p ∈ F then (1 : ℝ) else 0) * φ (G.nbr p.1 p.2) := by + rw [Fintype.sum_prod_type] + exact Finset.sum_comm + rw [hswap] + have hite : ∀ p : G.V × G.D, (if p ∈ F then (1 : ℝ) else 0) * φ (G.nbr p.1 p.2) + = if p ∈ F then φ (G.nbr p.1 p.2) else 0 := by + intro p + split <;> simp + rw [Finset.sum_congr rfl fun p _ => hite p, ← Finset.sum_filter] + congr 1 + simp + +/-! ### The two-crossing identity -/ + +/-- **Two crossings, in operator form.** Summed over all starts and all label +sequences, the walks that cross `F` at step `k` and again at step `l` are counted +by the walk operator applied to the dart counts: the first crossing leaves the +measure `headCount`, and the second is seen through `l - k - 1` steps of the +walk. `Mixing.mixing_sq` estimates exactly this expression. -/ +theorem sum_two_crossings (F : Finset (G.V × G.D)) {k l m : ℕ} (hkl : k < l) (hl : l < m) : + (∑ x : G.V, ∑ r : Fin m → G.D, + (if (G.walkAt m x r k, r ⟨k, by omega⟩) ∈ F then (1 : ℝ) else 0) + * (if (G.walkAt m x r l, r ⟨l, by omega⟩) ∈ F then (1 : ℝ) else 0)) + = (G.deg : ℝ) ^ (m - 2) + * ∑ z : G.V, (G.headCount F z : ℝ) + * G.stepIter (l - k - 1) (fun w => (G.dartCount F w : ℝ)) z := by + classical + set h : G.V → G.D → ℝ := fun y a => if (y, a) ∈ F then (1 : ℝ) else 0 with hh + have hx : ∀ x : G.V, (∑ r : Fin m → G.D, h (G.walkAt m x r k) (r ⟨k, by omega⟩) + * h (G.walkAt m x r l) (r ⟨l, by omega⟩)) + = (G.deg : ℝ) ^ (m - 2) * ∑ a : G.D, ∑ b : G.D, + G.stepIter k (fun y => h y a + * G.stepIter (l - k - 1) (fun z => h z b) (G.nbr y a)) x := + fun x => G.sum_two_darts_fixed h h k l m hkl hl x + rw [Finset.sum_congr rfl fun x _ => hx x, ← Finset.mul_sum] + congr 1 + have hswap : ∑ x : G.V, ∑ a : G.D, ∑ b : G.D, + G.stepIter k (fun y => h y a + * G.stepIter (l - k - 1) (fun z => h z b) (G.nbr y a)) x + = ∑ a : G.D, ∑ b : G.D, ∑ x : G.V, + G.stepIter k (fun y => h y a + * G.stepIter (l - k - 1) (fun z => h z b) (G.nbr y a)) x := by + rw [Finset.sum_comm] + exact Finset.sum_congr rfl fun a _ => Finset.sum_comm + rw [hswap] + have hcollapse : ∀ a : G.D, ∀ b : G.D, ∑ x : G.V, + G.stepIter k (fun y => h y a + * G.stepIter (l - k - 1) (fun z => h z b) (G.nbr y a)) x + = ∑ y : G.V, h y a * G.stepIter (l - k - 1) (fun z => h z b) (G.nbr y a) := by + intro a b + exact G.sum_stepIter k _ + rw [Finset.sum_congr rfl fun a _ => Finset.sum_congr rfl fun b _ => hcollapse a b] + have hby : ∀ a : G.D, ∑ b : G.D, ∑ y : G.V, + h y a * G.stepIter (l - k - 1) (fun z => h z b) (G.nbr y a) + = ∑ y : G.V, h y a + * G.stepIter (l - k - 1) (fun w => (G.dartCount F w : ℝ)) (G.nbr y a) := by + intro a + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun y _ => ?_ + rw [← Finset.mul_sum] + congr 1 + rw [← G.stepIter_sum Finset.univ (fun b z => h z b) (l - k - 1) (G.nbr y a)] + congr 1 + funext z + exact G.sum_indicator_dartCount F z + rw [Finset.sum_congr rfl fun a _ => hby a] + rw [G.sum_indicator_mul F + (fun w => G.stepIter (l - k - 1) (fun w' => (G.dartCount F w' : ℝ)) w)] + exact G.sum_indicator_nbr F _ + +/-! ### Bounding the correlation -/ + +/-- The variance of a dart count is at most `deg * |F|`, since no vertex carries +more than `deg` darts of `F`. -/ +theorem sum_sq_headCount_le (F : Finset (G.V × G.D)) : + ∑ z : G.V, ((G.headCount F z : ℝ)) ^ 2 ≤ (G.deg : ℝ) * (F.card : ℝ) := by + have hterm : ∀ z : G.V, ((G.headCount F z : ℝ)) ^ 2 + ≤ (G.deg : ℝ) * (G.headCount F z : ℝ) := by + intro z + have h := G.headCount_le F z + have hR : (G.headCount F z : ℝ) ≤ (G.deg : ℝ) := by exact_mod_cast h + have hnn : (0 : ℝ) ≤ (G.headCount F z : ℝ) := by positivity + nlinarith + calc ∑ z : G.V, ((G.headCount F z : ℝ)) ^ 2 + ≤ ∑ z : G.V, (G.deg : ℝ) * (G.headCount F z : ℝ) := Finset.sum_le_sum fun z _ => hterm z + _ = (G.deg : ℝ) * ∑ z : G.V, (G.headCount F z : ℝ) := by rw [Finset.mul_sum] + _ = (G.deg : ℝ) * (F.card : ℝ) := by + congr 1 + rw [← Nat.cast_sum, G.sum_headCount F] + +theorem sum_sq_dartCount_le (F : Finset (G.V × G.D)) : + ∑ v : G.V, ((G.dartCount F v : ℝ)) ^ 2 ≤ (G.deg : ℝ) * (F.card : ℝ) := by + have hterm : ∀ v : G.V, ((G.dartCount F v : ℝ)) ^ 2 + ≤ (G.deg : ℝ) * (G.dartCount F v : ℝ) := by + intro v + have h := G.dartCount_le F v + have hR : (G.dartCount F v : ℝ) ≤ (G.deg : ℝ) := by exact_mod_cast h + have hnn : (0 : ℝ) ≤ (G.dartCount F v : ℝ) := by positivity + nlinarith + calc ∑ v : G.V, ((G.dartCount F v : ℝ)) ^ 2 + ≤ ∑ v : G.V, (G.deg : ℝ) * (G.dartCount F v : ℝ) := Finset.sum_le_sum fun v _ => hterm v + _ = (G.deg : ℝ) * ∑ v : G.V, (G.dartCount F v : ℝ) := by rw [Finset.mul_sum] + _ = (G.deg : ℝ) * (F.card : ℝ) := by + congr 1 + rw [← Nat.cast_sum, G.sum_dartCount F] + +/-- **The correlation bound.** On a graph with spectral bound `lam`, two +crossings of `F` separated by `t` steps are almost independent: the operator +expression exceeds the independent value `|F|² / n` by at most +`lam ^ t * deg * |F|`. -/ +theorem sum_headCount_stepIter_le (F : Finset (G.V × G.D)) {lam : ℝ} + (hlam : 0 ≤ lam) (hspec : G.SpectralBound lam) (hn : 0 < G.order) (t : ℕ) : + ∑ z : G.V, (G.headCount F z : ℝ) + * G.stepIter t (fun w => (G.dartCount F w : ℝ)) z + ≤ (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + + lam ^ t * ((G.deg : ℝ) * (F.card : ℝ)) := by + have hmix := G.mixing_sq hspec hn t (fun z => (G.headCount F z : ℝ)) + (fun w => (G.dartCount F w : ℝ)) + have hsumf : ∑ z : G.V, (G.headCount F z : ℝ) = (F.card : ℝ) := by + rw [← Nat.cast_sum, G.sum_headCount F] + have hsumg : ∑ v : G.V, (G.dartCount F v : ℝ) = (F.card : ℝ) := by + rw [← Nat.cast_sum, G.sum_dartCount F] + rw [hsumf, hsumg] at hmix + set X : ℝ := ∑ z : G.V, (G.headCount F z : ℝ) + * G.stepIter t (fun w => (G.dartCount F w : ℝ)) z with hX + set c : ℝ := (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) with hc + set D : ℝ := lam ^ t * ((G.deg : ℝ) * (F.card : ℝ)) with hD + have hDnn : 0 ≤ D := by + rw [hD] + have : (0 : ℝ) ≤ lam ^ t := by positivity + positivity + have hbound : (X - c) ^ 2 ≤ D ^ 2 := by + refine le_trans hmix ?_ + have hvf : (∑ z : G.V, (G.headCount F z : ℝ) ^ 2) - (F.card : ℝ) ^ 2 / (G.order : ℝ) + ≤ (G.deg : ℝ) * (F.card : ℝ) := by + have h1 := G.sum_sq_headCount_le F + have h2 : (0 : ℝ) ≤ (F.card : ℝ) ^ 2 / (G.order : ℝ) := by positivity + linarith + have hvg : (∑ v : G.V, (G.dartCount F v : ℝ) ^ 2) - (F.card : ℝ) ^ 2 / (G.order : ℝ) + ≤ (G.deg : ℝ) * (F.card : ℝ) := by + have h1 := G.sum_sq_dartCount_le F + have h2 : (0 : ℝ) ≤ (F.card : ℝ) ^ 2 / (G.order : ℝ) := by positivity + linarith + have hvfnn : (0 : ℝ) ≤ (∑ z : G.V, (G.headCount F z : ℝ) ^ 2) + - (F.card : ℝ) ^ 2 / (G.order : ℝ) := by + have := G.sum_sq_center_nonneg (fun z => (G.headCount F z : ℝ)) + rwa [G.sum_sq_center hn, hsumf] at this + have hvgnn : (0 : ℝ) ≤ (∑ v : G.V, (G.dartCount F v : ℝ) ^ 2) + - (F.card : ℝ) ^ 2 / (G.order : ℝ) := by + have := G.sum_sq_center_nonneg (fun w => (G.dartCount F w : ℝ)) + rwa [G.sum_sq_center hn, hsumg] at this + have hpow : (0 : ℝ) ≤ lam ^ (2 * t) := by positivity + have hprod : lam ^ (2 * t) + * ((∑ z : G.V, (G.headCount F z : ℝ) ^ 2) - (F.card : ℝ) ^ 2 / (G.order : ℝ)) + * ((∑ v : G.V, (G.dartCount F v : ℝ) ^ 2) - (F.card : ℝ) ^ 2 / (G.order : ℝ)) + ≤ lam ^ (2 * t) * ((G.deg : ℝ) * (F.card : ℝ)) * ((G.deg : ℝ) * (F.card : ℝ)) := by + have hstep : lam ^ (2 * t) + * ((∑ z : G.V, (G.headCount F z : ℝ) ^ 2) - (F.card : ℝ) ^ 2 / (G.order : ℝ)) + ≤ lam ^ (2 * t) * ((G.deg : ℝ) * (F.card : ℝ)) := + mul_le_mul_of_nonneg_left hvf hpow + have hnn2 : (0 : ℝ) ≤ lam ^ (2 * t) + * ((∑ z : G.V, (G.headCount F z : ℝ) ^ 2) + - (F.card : ℝ) ^ 2 / (G.order : ℝ)) := by positivity + nlinarith [hvgnn, hvg] + refine le_trans hprod ?_ + rw [hD] + have h2t : lam ^ (2 * t) = (lam ^ t) ^ 2 := by + rw [← pow_mul, Nat.mul_comm] + rw [h2t] + ring_nf + exact le_refl _ + have habs : X - c ≤ D := by + nlinarith [hbound, hDnn] + linarith + +/-- **The second moment.** Summed over every pair of positions, the two-crossing +correlations exceed the independent value by at most `m / (1 - lam)` times +`deg * |F|`. The counts are supplied abstractly as `C`, since writing the +concrete one inside a sum would need the position bounds pointwise. -/ +theorem sum_pairs_le (F : Finset (G.V × G.D)) {lam : ℝ} (hlam0 : 0 ≤ lam) + (hlam1 : lam < 1) (hspec : G.SpectralBound lam) (hn : 0 < G.order) (m : ℕ) + (C : ℕ → ℕ → ℝ) + (hC : ∀ k ∈ Finset.range m, ∀ l ∈ Finset.Ico (k + 1) m, + C k l = ∑ z : G.V, (G.headCount F z : ℝ) + * G.stepIter (l - k - 1) (fun w => (G.dartCount F w : ℝ)) z) : + ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, C k l + ≤ (m : ℝ) * (m : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ)) + + (m : ℝ) * (1 / (1 - lam)) * ((G.deg : ℝ) * (F.card : ℝ)) := by + have hbound : ∀ k ∈ Finset.range m, ∀ l ∈ Finset.Ico (k + 1) m, + C k l ≤ (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + + lam ^ (l - k - 1) * ((G.deg : ℝ) * (F.card : ℝ)) := by + intro k hk l hl + rw [hC k hk l hl] + exact G.sum_headCount_stepIter_le F hlam0 hspec hn _ + have hstep1 : ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, C k l + ≤ ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + + lam ^ (l - k - 1) * ((G.deg : ℝ) * (F.card : ℝ))) := + Finset.sum_le_sum fun k hk => Finset.sum_le_sum fun l hl => hbound k hk l hl + have hsplit : ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + + lam ^ (l - k - 1) * ((G.deg : ℝ) * (F.card : ℝ))) + = (∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ)) + + (∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + lam ^ (l - k - 1) * ((G.deg : ℝ) * (F.card : ℝ))) := by + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun k _ => Finset.sum_add_distrib + have hconst : ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + ≤ (m : ℝ) * (m : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ)) := by + have hnn : (0 : ℝ) ≤ (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) := by positivity + have hinner : ∀ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + ≤ (m : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ)) := by + intro k _ + rw [Finset.sum_const, nsmul_eq_mul, Nat.card_Ico] + have hcard : ((m - (k + 1) : ℕ) : ℝ) ≤ (m : ℝ) := by + have : (m - (k + 1) : ℕ) ≤ m := by omega + exact_mod_cast this + exact mul_le_mul_of_nonneg_right hcard hnn + calc ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + (F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ) + ≤ ∑ _k ∈ Finset.range m, (m : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ)) := + Finset.sum_le_sum hinner + _ = (m : ℝ) * (m : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (G.order : ℝ)) := by + rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul] + ring + have hgeom : ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + lam ^ (l - k - 1) * ((G.deg : ℝ) * (F.card : ℝ)) + ≤ (m : ℝ) * (1 / (1 - lam)) * ((G.deg : ℝ) * (F.card : ℝ)) := by + have hfactor : ∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, + lam ^ (l - k - 1) * ((G.deg : ℝ) * (F.card : ℝ)) + = (∑ k ∈ Finset.range m, ∑ l ∈ Finset.Ico (k + 1) m, lam ^ (l - k - 1)) + * ((G.deg : ℝ) * (F.card : ℝ)) := by + rw [Finset.sum_mul] + exact Finset.sum_congr rfl fun k _ => (Finset.sum_mul _ _ _).symm + rw [hfactor] + have hnn : (0 : ℝ) ≤ (G.deg : ℝ) * (F.card : ℝ) := by positivity + exact mul_le_mul_of_nonneg_right (sum_pairs_geom_le hlam0 hlam1 m) hnn + linarith [hstep1, hsplit.le, hsplit.ge, hconst, hgeom] + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/DataScan.lean b/Complexitylib/Classes/PCP/Internal/DataScan.lean new file mode 100644 index 00000000..c5992f25 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/DataScan.lean @@ -0,0 +1,350 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal +public import Complexitylib.Classes.P.Cobham.Internal.Reverse +public import Complexitylib.Classes.P.UnaryLength +public import Complexitylib.Classes.Containments.Internal.BinArith +public import Complexitylib.Encoding.DataEncode +public import Complexitylib.Classes.PCP.Internal.DataScanSpec + +/-! +# Scanning a serialized `Data` value + +`Data.toBits` writes a value as balanced brackets: `false` opens a node, its +children follow in order, and `true` closes it. Reading one child back out of +such a string is a single left-to-right pass keeping a bracket depth and a count +of the children already passed, collecting bits only while inside the child +asked for. + +This module writes that pass in the form `recFoldClamp` accepts, so that +polynomial-time computability comes from the general fold rather than from a +bespoke machine. The fold recurses head-then-tail, so it runs right to left; the +caller therefore hands it the reversed string. + +The state is `pair (unary depth) (pair (unary count) collected)` and the +workspace is the requested index in unary. Every component stays below the +length of the string being scanned, so a linear clamp suffices. + +## Main definitions + +- `Complexity.DataScan.openStep`, `closeStep` — the two fold steps +- `Complexity.DataScan.childOf` — the scan, packaged as one function + +## Main results + +- `Complexity.DataScan.childOf_mem_FP` — the scan is polynomial time +- `Complexity.DataScan.recFoldClamp_eq_pack` — the fold runs the model +- `Complexity.DataScan.child_flatten` — the packaged scan extracts the child +- `Complexity.DataScan.childCount_flatten` — and counts the children +- `Complexity.DataScan.inner_toBits` — the bits between the outer brackets +-/ + +@[expose] public section + +namespace Complexity + +namespace DataScan + +/-! ### Reading the packed fold argument + +`recFoldClamp` hands each step `pair (pair W st) t`, with `W` the workspace, `st` +the state built so far and `t` the unscanned tail. -/ + +/-- The workspace: the index of the child being extracted, in unary. -/ +def wsOf (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock z) + +/-- The state carried by the scan. -/ +def stOf (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock z) + +/-- The bracket depth, in unary. -/ +def depthOf (z : List Bool) : List Bool := Cobham.fstBlock (stOf z) + +/-- The number of children already passed, in unary. -/ +def countOf (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.sndBlock (stOf z)) + +/-- The bits collected so far. -/ +def accOf (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.sndBlock (stOf z)) + +/-- Append the current bit, but only while inside the requested child. -/ +def collect (z : List Bool) (b : Bool) : List Bool := + Cobham.selectHead (Cobham.eqFlag (countOf z) (wsOf z)) (accOf z ++ [b]) (accOf z) + +/-! ### The two steps -/ + +/-- An opening bracket: descend one level. -/ +def openStep (z : List Bool) : List Bool := + pair (true :: depthOf z) (pair (countOf z) (collect z false)) + +/-- A closing bracket: rise one level, and if that returns to the top level, +one more child has been passed. -/ +def closeStep (z : List Bool) : List Bool := + pair (dropOne (depthOf z)) + (pair (Cobham.selectHead (emptyFlag (dropOne (depthOf z))) + (true :: countOf z) (countOf z)) + (collect z true)) + +/-- The state a scan starts from. -/ +def initState : List Bool := pair [] (pair [] []) + +/-! ### Polynomial time -/ + +theorem wsOf_mem_FP : wsOf ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +theorem stOf_mem_FP : stOf ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + +theorem depthOf_mem_FP : depthOf ∈ FP := + mem_FP_comp stOf_mem_FP Cobham.fstBlock_mem_FP + +theorem countOf_mem_FP : countOf ∈ FP := + mem_FP_comp (mem_FP_comp stOf_mem_FP Cobham.sndBlock_mem_FP) Cobham.fstBlock_mem_FP + +theorem accOf_mem_FP : accOf ∈ FP := + mem_FP_comp (mem_FP_comp stOf_mem_FP Cobham.sndBlock_mem_FP) Cobham.sndBlock_mem_FP + +theorem collect_mem_FP (b : Bool) : (fun z => collect z b) ∈ FP := + Cobham.selectHeadFn_mem_FP (eqFlagFn_mem_FP countOf_mem_FP wsOf_mem_FP) + (Cobham.appendFn_mem_FP accOf_mem_FP (constFn_mem_FP [b])) accOf_mem_FP + +theorem openStep_mem_FP : openStep ∈ FP := + Cobham.pairFn_mem_FP (mem_FP_comp depthOf_mem_FP (Cobham.cons_mem_FP true)) + (Cobham.pairFn_mem_FP countOf_mem_FP (collect_mem_FP false)) + +theorem closeStep_mem_FP : closeStep ∈ FP := by + have hdrop : (fun z => dropOne (depthOf z)) ∈ FP := dropOneFn_mem_FP depthOf_mem_FP + refine Cobham.pairFn_mem_FP hdrop (Cobham.pairFn_mem_FP ?_ (collect_mem_FP true)) + exact Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hdrop) + (mem_FP_comp countOf_mem_FP (Cobham.cons_mem_FP true)) countOf_mem_FP + +/-- **The scan.** On `pair (unary i) s` it runs the two steps over `s`, keeping +every intermediate state within `p.eval` bits, and returns the collected bits. -/ +def childOf (p : Polynomial ℕ) (z : List Bool) : List Bool := + Cobham.sndBlock (Cobham.sndBlock + (Cobham.recFoldClamp openStep closeStep (p.eval z.length) initState + (Cobham.fstBlock z) (Cobham.sndBlock z))) + +theorem childOf_mem_FP (p : Polynomial ℕ) : childOf p ∈ FP := by + have hfold := Cobham.recFoldClamp_mem_FP openStep_mem_FP closeStep_mem_FP + (constFn_mem_FP initState) p + exact mem_FP_comp (mem_FP_comp hfold Cobham.sndBlock_mem_FP) Cobham.sndBlock_mem_FP + +/-! ### The fold runs the model + +The state the fold carries is the model's state written out: two unary counters +and the collected bits. Once that is checked step by step, the fold and the +model agree, provided the clamp is wide enough never to truncate. -/ + +/-- The model's state, written out as a bitstring. -/ +def pack (st : ℕ × ℕ × List Bool) : List Bool := + pair (List.replicate st.1 true) (pair (List.replicate st.2.1 true) st.2.2) + +theorem pack_length (st : ℕ × ℕ × List Bool) : + (pack st).length = 2 * st.1 + 2 * st.2.1 + st.2.2.length + 4 := by + rw [pack, pair_length, pair_length, List.length_replicate, List.length_replicate] + omega + +theorem pack_init : pack (0, 0, []) = initState := rfl + +theorem eqFlag_replicate (c i : ℕ) : + Cobham.eqFlag (List.replicate c true) (List.replicate i true) + = if c = i then [true] else [false] := by + by_cases h : c = i + · rw [if_pos h, h] + exact (Cobham.eqFlag_eq_true_iff _ _).mpr rfl + · rw [if_neg h] + rcases Cobham.eqFlag_flag (List.replicate c true) (List.replicate i true) with hf | hf + · rw [Cobham.eqFlag_eq_true_iff] at hf + exact absurd (by simpa using congrArg List.length hf) h + · exact hf + +theorem depthOf_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : + depthOf (pair (pair (List.replicate i true) (pack st)) t) = List.replicate st.1 true := by + rw [depthOf, stOf, Cobham.fstBlock_pair, Cobham.sndBlock_pair, pack, Cobham.fstBlock_pair] + +theorem countOf_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : + countOf (pair (pair (List.replicate i true) (pack st)) t) + = List.replicate st.2.1 true := by + rw [countOf, stOf, Cobham.fstBlock_pair, Cobham.sndBlock_pair, pack, Cobham.sndBlock_pair, + Cobham.fstBlock_pair] + +theorem collect_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) (b : Bool) : + collect (pair (pair (List.replicate i true) (pack st)) t) b + = if st.2.1 = i then st.2.2 ++ [b] else st.2.2 := by + rw [collect, countOf, accOf, wsOf, stOf, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + pack, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, eqFlag_replicate] + by_cases h : st.2.1 = i <;> simp [h] + +theorem openStep_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : + openStep (pair (pair (List.replicate i true) (pack st)) t) + = pack (stepSpec i st false) := by + rw [openStep, depthOf_pack, countOf_pack, collect_pack, stepSpec, pack] + simp [List.replicate_succ] + +theorem closeStep_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : + closeStep (pair (pair (List.replicate i true) (pack st)) t) + = pack (stepSpec i st true) := by + have hdrop : dropOne (List.replicate st.1 true) = List.replicate (st.1 - 1) true := by + cases st.1 with + | zero => rfl + | succ n => rw [List.replicate_succ]; rfl + have hflag : emptyFlag (List.replicate (st.1 - 1) true) + = if st.1 - 1 = 0 then [true] else [false] := by + cases h : st.1 - 1 with + | zero => simp + | succ n => rw [List.replicate_succ, emptyFlag_cons]; simp + rw [closeStep, depthOf_pack, countOf_pack, collect_pack, hdrop, hflag, stepSpec, pack] + by_cases h : st.1 - 1 = 0 <;> simp [h, List.replicate_succ] + +/-! ### The state stays small -/ + +theorem runSpec_bounds (i : ℕ) (s : List Bool) : + ∀ (d c : ℕ) (acc : List Bool), + (runSpec i (d, c, acc) s).1 ≤ d + s.length ∧ + (runSpec i (d, c, acc) s).2.1 ≤ c + s.length ∧ + (runSpec i (d, c, acc) s).2.2.length ≤ acc.length + s.length := by + induction s with + | nil => intro d c acc; simp + | cons b s ih => + intro d c acc + rw [runSpec_cons] + have hstep : stepSpec i (d, c, acc) b + = ((stepSpec i (d, c, acc) b).1, (stepSpec i (d, c, acc) b).2.1, + (stepSpec i (d, c, acc) b).2.2) := rfl + have h1 : (stepSpec i (d, c, acc) b).1 ≤ d + 1 := by + cases b <;> simp [stepSpec] + omega + have h2 : (stepSpec i (d, c, acc) b).2.1 ≤ c + 1 := by + cases b <;> simp [stepSpec] + split <;> omega + have h3 : (stepSpec i (d, c, acc) b).2.2.length ≤ acc.length + 1 := by + have hb2 : (stepSpec i (d, c, acc) b).2.2 = if c = i then acc ++ [b] else acc := by + cases b <;> rfl + rw [hb2] + by_cases hc : c = i <;> simp [hc] + rw [hstep] + obtain ⟨j1, j2, j3⟩ := ih (stepSpec i (d, c, acc) b).1 (stepSpec i (d, c, acc) b).2.1 + (stepSpec i (d, c, acc) b).2.2 + refine ⟨?_, ?_, ?_⟩ + · exact le_trans j1 (by simp [List.length_cons]; omega) + · exact le_trans j2 (by simp [List.length_cons]; omega) + · exact le_trans j3 (by simp [List.length_cons]; omega) + +theorem pack_runSpec_length_le (i : ℕ) (s : List Bool) : + (pack (runSpec i (0, 0, []) s)).length ≤ 5 * s.length + 4 := by + obtain ⟨h1, h2, h3⟩ := runSpec_bounds i s 0 0 [] + rw [pack_length] + simp only [List.length_nil, Nat.zero_add] at h1 h2 h3 + omega + +/-- **The fold runs the model.** Reading the reversed string with the clamped +fold gives exactly the model's state, as long as the clamp is wide enough. -/ +theorem recFoldClamp_eq_pack (i bound : ℕ) (l : List Bool) + (hb : 5 * l.length + 4 ≤ bound) : + Cobham.recFoldClamp openStep closeStep bound initState (List.replicate i true) l + = pack (runSpec i (0, 0, []) l.reverse) := by + induction l with + | nil => + rw [Cobham.recFoldClamp, ← pack_init] + simp only [List.reverse_nil, runSpec_nil] + refine List.take_of_length_le ?_ + have := pack_runSpec_length_le i ([] : List Bool) + simp only [runSpec_nil] at this + simp only [List.length_nil, Nat.mul_zero, Nat.zero_add] at hb + exact le_trans (by simpa using pack_length (0, 0, ([] : List Bool)) ▸ le_refl _) hb + | cons b l ih => + have hb' : 5 * l.length + 4 ≤ bound := by + simp only [List.length_cons] at hb + omega + rw [Cobham.recFoldClamp, ih hb'] + have hstep : (bif b then closeStep else openStep) + (pair (pair (List.replicate i true) (pack (runSpec i (0, 0, []) l.reverse))) l) + = pack (stepSpec i (runSpec i (0, 0, []) l.reverse) b) := by + cases b + · exact openStep_pack _ _ _ + · exact closeStep_pack _ _ _ + rw [hstep] + have hval : pack (stepSpec i (runSpec i (0, 0, []) l.reverse) b) + = pack (runSpec i (0, 0, []) (b :: l).reverse) := by + rw [List.reverse_cons, runSpec_append] + rfl + rw [hval] + refine List.take_of_length_le ?_ + exact le_trans (pack_runSpec_length_le i ((b :: l).reverse)) (by simpa using hb) + +/-! ### The packaged scan -/ + +/-- A clamp wide enough for any scan: the state never exceeds `5 n + 4` bits. -/ +noncomputable def scanPoly : Polynomial ℕ := Polynomial.C 5 * Polynomial.X + Polynomial.C 4 + +@[simp] theorem scanPoly_eval (n : ℕ) : scanPoly.eval n = 5 * n + 4 := by + rw [scanPoly] + simp + +/-- The scan's argument: the index in unary paired with the reversed string, the +order the fold consumes. -/ +def scanArg (i : ℕ) (s : List Bool) : List Bool := pair (List.replicate i true) s.reverse + +theorem scanArg_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => scanArg (a z).length (b z)) ∈ FP := by + have hrep : (fun z => List.replicate (a z).length true) ∈ FP := by + have := mem_FP_comp ha unaryLength_mem_FP + simpa [Function.comp] using this + have hrev : (fun z => (b z).reverse) ∈ FP := by + have := mem_FP_comp hb reverse_mem_FP + simpa [Function.comp] using this + exact Cobham.pairFn_mem_FP hrep hrev + +/-- **The scan extracts the child.** Reading the concatenated serializations of +`xs` returns the `i`-th one, or nothing when there is no such child. -/ +theorem child_flatten (i : ℕ) (xs : List Data) : + childOf scanPoly (scanArg i ((xs.map Data.toBits).flatten)) + = ((xs[i]?).map Data.toBits).getD [] := by + set F := (xs.map Data.toBits).flatten with hF + have hlen : (scanArg i F).length = 2 * i + 2 + F.length := by + rw [scanArg, pair_length, List.length_replicate, List.length_reverse] + rw [childOf, scanArg, Cobham.fstBlock_pair, Cobham.sndBlock_pair, ← scanArg, hlen, + scanPoly_eval, recFoldClamp_eq_pack i _ F.reverse (by simp), + List.reverse_reverse, hF, runSpec_inner, pack, Cobham.sndBlock_pair, + Cobham.sndBlock_pair] + +/-- **How many children there are**, in unary: the same pass, reading off the +counter instead of the collected bits. -/ +def childCount (p : Polynomial ℕ) (z : List Bool) : List Bool := + Cobham.fstBlock (Cobham.sndBlock + (Cobham.recFoldClamp openStep closeStep (p.eval z.length) initState + (Cobham.fstBlock z) (Cobham.sndBlock z))) + +theorem childCount_mem_FP (p : Polynomial ℕ) : childCount p ∈ FP := by + have hfold := Cobham.recFoldClamp_mem_FP openStep_mem_FP closeStep_mem_FP + (constFn_mem_FP initState) p + exact mem_FP_comp (mem_FP_comp hfold Cobham.sndBlock_mem_FP) Cobham.fstBlock_mem_FP + +theorem childCount_flatten (i : ℕ) (xs : List Data) : + childCount scanPoly (scanArg i ((xs.map Data.toBits).flatten)) + = List.replicate xs.length true := by + set F := (xs.map Data.toBits).flatten with hF + have hlen : (scanArg i F).length = 2 * i + 2 + F.length := by + rw [scanArg, pair_length, List.length_replicate, List.length_reverse] + rw [childCount, scanArg, Cobham.fstBlock_pair, Cobham.sndBlock_pair, ← scanArg, hlen, + scanPoly_eval, recFoldClamp_eq_pack i _ F.reverse (by simp), + List.reverse_reverse, hF, runSpec_inner, pack, Cobham.sndBlock_pair, + Cobham.fstBlock_pair] + +/-- The bits strictly between the outer brackets of a serialized list. -/ +theorem inner_toBits (xs : List Data) : + ((Data.l xs).toBits.drop 1).take ((Data.l xs).toBits.length - 2) + = (xs.map Data.toBits).flatten := by + have hb : (Data.l xs).toBits + = false :: ((xs.map Data.toBits).flatten ++ [true]) := Data.toBits_l xs + rw [hb] + simp + +end DataScan + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean b/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean new file mode 100644 index 00000000..76bf5479 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Encoding.DataEncode + +/-! +# What the bracket scan computes + +A model of the left-to-right pass over a serialized `Data` value: a bracket +depth, a count of the top-level children already passed, and the bits collected +while inside the child that was asked for. This file is about the model alone — +that it really does extract the requested child — and says nothing about +computability. + +Two facts drive everything. The depth and the count evolve without looking at +the collected bits, and the collected bits only ever grow at the end +(`runSpec_append_acc`); and a serialized value read at any depth returns to that +depth, having contributed exactly its own serialization when it was the child +being sought (`runSpec_toBits`). + +## Main definitions + +- `Complexity.DataScan.runSpec` — the model of the pass + +## Main results + +- `Complexity.DataScan.runSpec_toBits` — reading one serialized value +- `Complexity.DataScan.runSpec_flatten` — reading a whole run of children +- `Complexity.DataScan.runSpec_inner` — the pass over a serialized list returns + the requested child +-/ + +@[expose] public section + +namespace Complexity + +namespace DataScan + +/-- One step of the pass: `false` opens a bracket, `true` closes one, and the +bit joins the output exactly when the count matches the child sought. -/ +def stepSpec (i : ℕ) (st : ℕ × ℕ × List Bool) (b : Bool) : ℕ × ℕ × List Bool := + let acc' := if st.2.1 = i then st.2.2 ++ [b] else st.2.2 + if b then (st.1 - 1, if st.1 - 1 = 0 then st.2.1 + 1 else st.2.1, acc') + else (st.1 + 1, st.2.1, acc') + +/-- The pass over a whole string. -/ +def runSpec (i : ℕ) (st : ℕ × ℕ × List Bool) (s : List Bool) : ℕ × ℕ × List Bool := + s.foldl (stepSpec i) st + +@[simp] theorem runSpec_nil (i : ℕ) (st : ℕ × ℕ × List Bool) : runSpec i st [] = st := rfl + +theorem runSpec_append (i : ℕ) (st : ℕ × ℕ × List Bool) (s t : List Bool) : + runSpec i st (s ++ t) = runSpec i (runSpec i st s) t := by + rw [runSpec, runSpec, runSpec, List.foldl_append] + +theorem runSpec_cons (i : ℕ) (st : ℕ × ℕ × List Bool) (b : Bool) (s : List Bool) : + runSpec i st (b :: s) = runSpec i (stepSpec i st b) s := rfl + +/-- **The collected bits only grow at the end.** A prefix already present in the +output is carried through untouched, and the depth and count do not see it. -/ +theorem runSpec_append_acc (i : ℕ) (s : List Bool) : + ∀ (d c : ℕ) (pre acc : List Bool), + runSpec i (d, c, pre ++ acc) s + = ((runSpec i (d, c, acc) s).1, (runSpec i (d, c, acc) s).2.1, + pre ++ (runSpec i (d, c, acc) s).2.2) := by + induction s with + | nil => intro d c pre acc; rfl + | cons b s ih => + intro d c pre acc + rw [runSpec_cons, runSpec_cons] + have hstep : stepSpec i (d, c, pre ++ acc) b + = ((stepSpec i (d, c, acc) b).1, (stepSpec i (d, c, acc) b).2.1, + pre ++ (stepSpec i (d, c, acc) b).2.2) := by + by_cases hb : b <;> by_cases hc : c = i <;> + simp [stepSpec, hb, hc, List.append_assoc] + rw [hstep] + exact ih _ _ _ _ + +/-- **Reading one serialized value.** Starting at depth `d` with `c` children +already passed, the pass over `y.toBits` returns to depth `d`; it counts one +more child exactly when it was at the top level, and it contributes `y.toBits` +to the output exactly when `y` is the child sought. -/ +theorem runSpec_toBits (i : ℕ) (y : Data) : + ∀ (d c : ℕ) (acc : List Bool), + runSpec i (d, c, acc) y.toBits + = (d, (if d = 0 then c + 1 else c), if c = i then acc ++ y.toBits else acc) := by + induction y using Data.inductionL with + | nil => + intro d c acc + have hnil : (Data.l ([] : List Data)).toBits = [false, true] := by + rw [Data.toBits_l]; simp + rw [hnil] + by_cases hc : c = i <;> + simp [runSpec_cons, stepSpec, hc] + | cons x xs ihx ihxs => + intro d c acc + have hsplit : (Data.l (x :: xs)).toBits + = false :: (x.toBits ++ ((xs.map Data.toBits).flatten ++ [true])) := by + rw [Data.toBits_l] + simp [List.append_assoc] + have htail : (Data.l xs).toBits = false :: ((xs.map Data.toBits).flatten ++ [true]) := by + rw [Data.toBits_l] + set F := (xs.map Data.toBits).flatten ++ [true] with hF + set acc₁ := if c = i then acc ++ [false] else acc with hacc₁ + -- The behaviour of `F` from depth `d + 1`, read off from the tail's statement. + have hxs := ihxs d c acc + rw [htail, runSpec_cons] at hxs + have hstep0 : stepSpec i (d, c, acc) false = (d + 1, c, acc₁) := by + by_cases hc : c = i <;> simp [stepSpec, hc, hacc₁] + rw [hstep0] at hxs + -- Uniformity: read `F` from the empty output instead. + have huni : ∀ a : List Bool, runSpec i (d + 1, c, a) F + = ((runSpec i (d + 1, c, []) F).1, (runSpec i (d + 1, c, []) F).2.1, + a ++ (runSpec i (d + 1, c, []) F).2.2) := by + intro a + have := runSpec_append_acc i F (d + 1) c a [] + simpa using this + have hR := huni acc₁ + rw [hxs] at hR + set R := (runSpec i (d + 1, c, []) F).2.2 with hRdef + have hD : (runSpec i (d + 1, c, []) F).1 = d := by + have := congrArg Prod.fst hR + simpa using this.symm + have hC : (runSpec i (d + 1, c, []) F).2.1 = (if d = 0 then c + 1 else c) := by + have := congrArg (fun p => p.2.1) hR + simpa using this.symm + have hacc : (if c = i then acc ++ (false :: F) else acc) = acc₁ ++ R := by + have := congrArg (fun p => p.2.2) hR + simpa using this + -- Now the value at hand. + rw [hsplit, runSpec_cons, hstep0, runSpec_append, ihx (d + 1) c acc₁, + if_neg (Nat.succ_ne_zero d)] + set acc₂ := if c = i then acc₁ ++ x.toBits else acc₁ with hacc₂ + rw [huni acc₂, hD, hC] + refine Prod.ext rfl (Prod.ext rfl ?_) + by_cases hc : c = i + · have hR' : R = F := by + simp only [hc, hacc₁] at hacc + simpa using hacc.symm + rw [hacc₂, hacc₁, if_pos hc, if_pos hc, if_pos hc, hR'] + simp [List.append_assoc] + · have hR' : R = [] := by + simp only [if_neg hc, hacc₁] at hacc + simpa using hacc.symm + rw [hacc₂, hacc₁, if_neg hc, if_neg hc, if_neg hc, hR'] + simp + +/-! ### A run of children -/ + +/-- The child a pass looking for index `i` picks out of `xs`, having already +passed `c` children. -/ +def selFrom (xs : List Data) (i c : ℕ) : List Bool := + if c ≤ i then ((xs[i - c]?).map Data.toBits).getD [] else [] + +@[simp] theorem selFrom_nil (i c : ℕ) : selFrom [] i c = [] := by + rw [selFrom] + split <;> simp + +/-- **Reading a run of children.** At the top level the pass counts every child +and contributes exactly the one it was asked for. -/ +theorem runSpec_flatten (i : ℕ) : + ∀ (xs : List Data) (c : ℕ) (acc : List Bool), + runSpec i (0, c, acc) ((xs.map Data.toBits).flatten) + = (0, c + xs.length, acc ++ selFrom xs i c) := by + intro xs + induction xs with + | nil => intro c acc; simp + | cons x xs ih => + intro c acc + rw [List.map_cons, List.flatten_cons, runSpec_append, runSpec_toBits, if_pos rfl, ih] + refine Prod.ext rfl (Prod.ext (by simp [List.length_cons]; omega) ?_) + simp only + by_cases hlt : c < i + · have h : c < i := hlt + have h1 : selFrom (x :: xs) i c = selFrom xs i (c + 1) := by + rw [selFrom, selFrom, if_pos (by omega : c ≤ i), if_pos (by omega)] + have : i - c = (i - (c + 1)) + 1 := by omega + rw [this] + simp + rw [if_neg (by omega), h1] + by_cases heq : c = i + · subst heq + have h1 : selFrom (x :: xs) c c = x.toBits := by + rw [selFrom, if_pos (by omega : c ≤ c)] + simp + have h2 : selFrom xs c (c + 1) = [] := by + rw [selFrom, if_neg (by omega)] + rw [if_pos rfl, h1, h2, List.append_assoc, List.append_nil] + · have h : i < c := by omega + have h1 : selFrom (x :: xs) i c = [] := by rw [selFrom, if_neg (by omega)] + have h2 : selFrom xs i (c + 1) = [] := by rw [selFrom, if_neg (by omega)] + rw [if_neg (by omega), h1, h2] + +/-- **The pass over a serialized list.** Reading the bits strictly between the +outer brackets returns the requested child's own serialization. -/ +theorem runSpec_inner (i : ℕ) (xs : List Data) : + runSpec i (0, 0, []) ((xs.map Data.toBits).flatten) + = (0, xs.length, ((xs[i]?).map Data.toBits).getD []) := by + rw [runSpec_flatten, selFrom, if_pos (Nat.zero_le i)] + simp + +end DataScan + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean b/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean new file mode 100644 index 00000000..e7618c9b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean @@ -0,0 +1,314 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph +public import Complexitylib.Classes.PCP.Internal.NumEnc +public import Complexitylib.Classes.PCP.Internal.Expander +public import Complexitylib.Classes.PCP.Internal.RegCSP + +/-! +# Degree reduction + +The first half of Dinur's preprocessing: an arbitrary constraint graph, whose +vertices may have wildly different degrees, is replaced by a *regular* one over +the same alphabet. + +The vertices of the new graph are the **half-edges** of the old one — an edge +together with one of its endpoints — so there are exactly `2 · numEdges` of +them, however lopsided the original degrees were. Each half-edge has + +* one **edge-link**, to the other half of its own edge, carrying that edge's + original constraint, and +* `E.degree` **cloud-links**, wiring together the half-edges that share an + endpoint, by a member of an `ExpanderFamily`, carrying equality constraints. + +So the result is `(1 + E.degree)`-regular by construction, with no padding, and +its size is a constant multiple of the original's — which is what the +amplification bookkeeping needs. + +## The cloud rotation, without dependent types + +A cloud's expander lives on `Fin (cloud size)`, and cloud sizes differ, so the +naive rotation map forces a transport along `owner p' = owner p` that is not +type-correct to rewrite. The fix is `cloudRotAux`, which takes the cloud's +enumeration `l` as a *parameter*: within it the length is fixed, and +involutivity is an ordinary argument about a `Nodup` list. At the top level the +only rewriting needed is `cloudList (owner p') = cloudList (owner p)`, an +equation between plain lists with no dependent type in sight. + +## Main definitions + +- `ConstraintGraph.owner`, `flipHalf`, `cloud`, `cloudList` — the cloud + structure on half-edges +- `ConstraintGraph.cloudRotAux`, `cloudRot` — the cloud-link rotation +- `ConstraintGraph.reduceGraph`, `reduce` — the regular graph and system + +## Main results + +- `ConstraintGraph.cloudRotAux_involutive`, `cloudRot_involutive` +- `ConstraintGraph.cloudRot_getElem` — a cloud, read through its enumeration, is + a copy of the family's expander +- `ConstraintGraph.order_reduceGraph`, `deg_reduceGraph` — size `2 · numEdges`, + degree `1 + E.degree` +- `ConstraintGraph.satisfiable_reduce_of_satisfiable` — completeness +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α : Type} (G : ConstraintGraph α) + +/-! ### Half-edges and clouds -/ + +/-- A half-edge: an edge together with one of its two endpoints (`false` is the +tail, `true` the head). These are the vertices of the reduced graph. -/ +abbrev HalfEdge (G : ConstraintGraph α) : Type := Fin G.numEdges × Bool + +/-- The vertex a half-edge is attached to. -/ +def owner (p : G.HalfEdge) : Fin G.numVerts := if p.2 then G.head p.1 else G.tail p.1 + +/-- The other half of the same edge. -/ +def flipHalf (p : G.HalfEdge) : G.HalfEdge := (p.1, !p.2) + +theorem flipHalf_involutive : Function.Involutive G.flipHalf := by + intro p + simp [flipHalf] + +/-- The half-edges attached to `v`. -/ +def cloud (v : Fin G.numVerts) : Finset G.HalfEdge := + Finset.univ.filter fun p => G.owner p = v + +@[simp] theorem mem_cloud {v : Fin G.numVerts} {p : G.HalfEdge} : + p ∈ G.cloud v ↔ G.owner p = v := by + simp [cloud] + +/-- The number naming a half-edge. The head of an edge is numbered before its +tail, which is the order `Fintype` enumerates `Bool` in. -/ +def halfCode (p : G.HalfEdge) : ℕ := 2 * p.1.val + (if p.2 then 0 else 1) + +theorem halfCode_injective : Function.Injective G.halfCode := by + rintro ⟨e, b⟩ ⟨e', b'⟩ h + simp only [halfCode] at h + have he : e.val = e'.val := by cases b <;> cases b' <;> simp at h <;> omega + have hb : b = b' := by cases b <;> cases b' <;> simp at h ⊢ <;> omega + rw [Fin.ext he, hb] + +instance halfLE_trans : + IsTrans G.HalfEdge (fun p q => G.halfCode p ≤ G.halfCode q) := ⟨fun _ _ _ => le_trans⟩ + +instance halfLE_antisymm : + Std.Antisymm (fun p q : G.HalfEdge => G.halfCode p ≤ G.halfCode q) := + ⟨fun _ _ h1 h2 => G.halfCode_injective (le_antisymm h1 h2)⟩ + +instance halfLE_total : + Std.Total (fun p q : G.HalfEdge => G.halfCode p ≤ G.halfCode q) := + ⟨fun _ _ => le_total _ _⟩ + +/-- The half-edges of a cloud, listed without repetition, in order of their +numbers — the order an algorithm can find them in. -/ +noncomputable def cloudList (v : Fin G.numVerts) : List G.HalfEdge := + (G.cloud v).sort (fun p q => G.halfCode p ≤ G.halfCode q) + +theorem nodup_cloudList (v : Fin G.numVerts) : (G.cloudList v).Nodup := + Finset.sort_nodup _ _ + +theorem pairwise_cloudList (v : Fin G.numVerts) : + List.Pairwise (fun p q => G.halfCode p ≤ G.halfCode q) (G.cloudList v) := + Finset.pairwise_sort _ _ + +@[simp] theorem mem_cloudList {v : Fin G.numVerts} {p : G.HalfEdge} : + p ∈ G.cloudList v ↔ p ∈ G.cloud v := Finset.mem_sort _ + +theorem mem_cloudList_self (p : G.HalfEdge) : p ∈ G.cloudList (G.owner p) := by simp + +/-! ### The cloud rotation -/ + +variable (E : ExpanderFamily) + +/-- The cloud-link rotation, with the cloud's enumeration passed in explicitly +so that no dependent rewriting is ever needed. -/ +noncomputable def cloudRotAux (l : List G.HalfEdge) (p : G.HalfEdge) (j : Fin E.degree) : + G.HalfEdge × Fin E.degree := + if h : l.idxOf p < l.length then + let q := E.rot l.length (⟨l.idxOf p, h⟩, j) + (l.getD q.1.val p, q.2) + else (p, j) + +/-- Inside one cloud, the rotation is an involution: this is the family's own +involutivity, transported through the enumeration. -/ +theorem cloudRotAux_involutive {l : List G.HalfEdge} (hnd : l.Nodup) {p : G.HalfEdge} + (hp : p ∈ l) (j : Fin E.degree) : + G.cloudRotAux E l (G.cloudRotAux E l p j).1 (G.cloudRotAux E l p j).2 = (p, j) := by + have hlt : l.idxOf p < l.length := List.idxOf_lt_length_iff.mpr hp + set q := E.rot l.length (⟨l.idxOf p, hlt⟩, j) with hq + have hq1 : q.1.val < l.length := q.1.isLt + have hstep : G.cloudRotAux E l p j = (l.getD q.1.val p, q.2) := by + rw [cloudRotAux, dif_pos hlt] + have hget : l.getD q.1.val p = l[q.1.val] := (List.getElem_eq_getD p).symm + have hmem' : l[q.1.val] ∈ l := List.getElem_mem hq1 + have hidx' : l.idxOf l[q.1.val] = q.1.val := hnd.idxOf_getElem _ hq1 + have hlt' : l.idxOf (l.getD q.1.val p) < l.length := by + rw [hget, hidx']; exact hq1 + rw [hstep, cloudRotAux, dif_pos hlt'] + have hval : l.idxOf (l.getD q.1.val p) = q.1.val := by rw [hget, hidx'] + have hfin : (⟨l.idxOf (l.getD q.1.val p), hlt'⟩ : Fin l.length) = q.1 := Fin.ext hval + rw [hfin] + have hinv : E.rot l.length (q.1, q.2) = (⟨l.idxOf p, hlt⟩, j) := by + rw [hq, Prod.mk.eta, E.rot_involutive l.length] + rw [hinv] + have hself : ∀ d : G.HalfEdge, l.getD (l.idxOf p) d = p := by + intro d + rw [← List.getElem_eq_getD (h := hlt), List.getElem_idxOf hlt] + exact Prod.ext (hself _) rfl + +/-- The cloud-link rotation at a half-edge, using its own cloud. -/ +noncomputable def cloudRot (p : G.HalfEdge) (j : Fin E.degree) : G.HalfEdge × Fin E.degree := + G.cloudRotAux E (G.cloudList (G.owner p)) p j + +/-- A cloud-link lands inside the enumeration it started from. -/ +theorem cloudRotAux_mem {l : List G.HalfEdge} {p : G.HalfEdge} (hp : p ∈ l) + (j : Fin E.degree) : (G.cloudRotAux E l p j).1 ∈ l := by + have hlt : l.idxOf p < l.length := List.idxOf_lt_length_iff.mpr hp + have hq1 : (E.rot l.length (⟨l.idxOf p, hlt⟩, j)).1.val < l.length := + (E.rot l.length (⟨l.idxOf p, hlt⟩, j)).1.isLt + rw [cloudRotAux, dif_pos hlt] + dsimp only + rw [← List.getElem_eq_getD (h := hq1)] + exact List.getElem_mem hq1 + +/-- A cloud-link stays inside the cloud. -/ +theorem owner_cloudRot (p : G.HalfEdge) (j : Fin E.degree) : + G.owner (G.cloudRot E p j).1 = G.owner p := by + have h := G.cloudRotAux_mem E (G.mem_cloudList_self p) j + rw [cloudRot] + simpa using h + +/-- **The cloud is a copy of the expander.** Reading the cloud through its +enumeration, a cloud-link is exactly the family's rotation map. This is what +lets the expander estimates of `Disagreement` be applied to a cloud. -/ +theorem cloudRot_getElem (v : Fin G.numVerts) (i : Fin (G.cloudList v).length) + (j : Fin E.degree) : + (G.cloudRot E ((G.cloudList v)[i.val]) j).1 + = (G.cloudList v)[(E.rot (G.cloudList v).length (i, j)).1.val] := by + have hmem : (G.cloudList v)[i.val] ∈ G.cloudList v := List.getElem_mem i.isLt + have howner : G.owner ((G.cloudList v)[i.val]) = v := + (G.mem_cloud).mp ((G.mem_cloudList).mp hmem) + have hidx : (G.cloudList v).idxOf ((G.cloudList v)[i.val]) = i.val := + (G.nodup_cloudList v).idxOf_getElem _ i.isLt + have hlt : (G.cloudList v).idxOf ((G.cloudList v)[i.val]) < (G.cloudList v).length := by + rw [hidx]; exact i.isLt + rw [cloudRot, howner, cloudRotAux, dif_pos hlt] + have hfin : (⟨(G.cloudList v).idxOf ((G.cloudList v)[i.val]), hlt⟩ : + Fin (G.cloudList v).length) = i := Fin.ext hidx + rw [hfin] + dsimp only + exact (List.getElem_eq_getD _).symm + +theorem cloudRot_involutive (p : G.HalfEdge) (j : Fin E.degree) : + G.cloudRot E (G.cloudRot E p j).1 (G.cloudRot E p j).2 = (p, j) := by + have howner : G.owner (G.cloudRot E p j).1 = G.owner p := G.owner_cloudRot E p j + rw [cloudRot, howner] + exact G.cloudRotAux_involutive E (G.nodup_cloudList _) (G.mem_cloudList_self p) j + +/-! ### The reduced graph -/ + +/-- The reduced graph: every half-edge has one edge-link to the other half of +its edge, and `E.degree` cloud-links to the half-edges sharing its endpoint. -/ +noncomputable def reduceGraph (G : ConstraintGraph α) (E : ExpanderFamily) : RegGraph where + V := G.HalfEdge + D := Option (Fin E.degree) + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨none⟩ + rot x := + match x.2 with + | none => (G.flipHalf x.1, none) + | some j => ((G.cloudRot E x.1 j).1, some (G.cloudRot E x.1 j).2) + rot_involutive := by + rintro ⟨p, _ | j⟩ + · show (G.flipHalf (G.flipHalf p), (none : Option (Fin E.degree))) = (p, none) + rw [G.flipHalf_involutive p] + · show ((G.cloudRot E (G.cloudRot E p j).1 (G.cloudRot E p j).2).1, + some (G.cloudRot E (G.cloudRot E p j).1 (G.cloudRot E p j).2).2) = (p, some j) + rw [G.cloudRot_involutive E p j] + +@[simp] theorem V_reduceGraph : (G.reduceGraph E).V = G.HalfEdge := rfl + +@[simp] theorem order_reduceGraph : (G.reduceGraph E).order = 2 * G.numEdges := by + show Fintype.card (Fin G.numEdges × Bool) = 2 * G.numEdges + simp [Nat.mul_comm] + +/-- The reduced graph is `(1 + E.degree)`-regular. -/ +@[simp] theorem deg_reduceGraph : (G.reduceGraph E).deg = 1 + E.degree := by + show Fintype.card (Option (Fin E.degree)) = 1 + E.degree + simp [Nat.add_comm] + +theorem nbr_reduceGraph_none (p : G.HalfEdge) : + (G.reduceGraph E).nbr p none = G.flipHalf p := rfl + +theorem nbr_reduceGraph_some (p : G.HalfEdge) (j : Fin E.degree) : + (G.reduceGraph E).nbr p (some j) = (G.cloudRot E p j).1 := rfl + +/-! ### The reduced constraint system -/ + +variable [DecidableEq α] + +/-- The reduced constraint system: an edge-link carries the original constraint +of its edge, oriented so that the tail's label comes first, and a cloud-link +demands that the two half-edges agree. -/ +noncomputable def reduce (G : ConstraintGraph α) (E : ExpanderFamily) : RegCSP α where + graph := G.reduceGraph E + rel p d a b := + match d with + | none => if p.2 then G.rel p.1 b a else G.rel p.1 a b + | some _ => a == b + +@[simp] theorem graph_reduce : (G.reduce E).graph = G.reduceGraph E := rfl + +/-- The reduced system's vertices are the half-edges, numbered by their edge and +their side. -/ +noncomputable instance : NumEnc (G.reduce E).graph.V := + inferInstanceAs (NumEnc (Fin G.numEdges × Bool)) + +/-- Completeness: labelling every half-edge by its endpoint's label carries a +satisfying assignment of `G` to one of the reduced system. -/ +theorem satisfiable_reduce_of_satisfiable (h : G.Satisfiable) : (G.reduce E).Satisfiable := by + obtain ⟨σ, hσ⟩ := h + refine ⟨fun p => σ (G.owner p), ?_⟩ + rintro ⟨p, _ | j⟩ + · -- an edge-link carries the original constraint + rw [RegCSP.Satisfies, RegCSP.satisfies] + dsimp only + show (if p.2 then G.rel p.1 (σ (G.owner ((G.reduceGraph E).nbr p none))) (σ (G.owner p)) + else G.rel p.1 (σ (G.owner p)) (σ (G.owner ((G.reduceGraph E).nbr p none)))) = true + rw [nbr_reduceGraph_none] + have hedge := hσ p.1 + rw [Satisfies, satisfies] at hedge + by_cases hb : p.2 = true + · have h1 : G.owner p = G.head p.1 := by simp [owner, hb] + have h2 : G.owner (G.flipHalf p) = G.tail p.1 := by simp [owner, flipHalf, hb] + rw [if_pos hb, h1, h2] + exact hedge + · have hb' : p.2 = false := by simpa using hb + have h1 : G.owner p = G.tail p.1 := by simp [owner, hb'] + have h2 : G.owner (G.flipHalf p) = G.head p.1 := by simp [owner, flipHalf, hb'] + rw [if_neg hb, h1, h2] + exact hedge + · -- a cloud-link joins half-edges with the same endpoint + rw [RegCSP.Satisfies, RegCSP.satisfies] + dsimp only + show ((σ (G.owner p) == σ (G.owner ((G.reduceGraph E).nbr p (some j)))) = true) + rw [nbr_reduceGraph_some, G.owner_cloudRot E p j] + simp + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean b/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean new file mode 100644 index 00000000..e9e87519 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean @@ -0,0 +1,295 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CloudDisagreement + +/-! +# Soundness of degree reduction + +Completeness was proved in `DegreeReduction`; this is the other half. An +assignment `A` of the reduced system is decoded to a vertex assignment by +plurality, and the unsatisfied darts of `A` are charged against the edges that +decoding fails: + +* **cloud-links** pay for every half-edge that disagrees with its vertex's + plurality label (`CloudDisagreement.total_cloud_charge`), and +* **edge-links** pay for every original edge that the decoded assignment fails + *and* whose two half-edges both agree — for such an edge the edge-link carries + exactly the failed original constraint. + +An edge escapes the second bill only by having a disagreeing half-edge, and +those are already billed by the first. Trading the two off gives a bound of +`min 1 c` times the original unsatisfied fraction, with +`c = (1 - lam) · degree / card α`. + +## Main definitions + +- `ConstraintGraph.cloudDarts`, `edgeDarts` — the unsatisfied darts split by + which kind of link they are +- `ConstraintGraph.goodEdges` — the failed original edges whose halves agree + +## Main results + +- `ConstraintGraph.card_unsatEdges_le_charge` — an edge failed by decoding is either + billed to an edge-link or has a disagreeing half-edge +- `ConstraintGraph.card_unsatDarts_ge` — the combined charge +- `ConstraintGraph.unsatFrac_reduce_ge`, `ConstraintGraph.le_unsatVal_reduce` — + soundness: the reduced system's unsatisfied fraction, and its value, are at + least `reduceConst` times `G`'s value +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +/-- The constant factor degree reduction costs: the trade-off between the cloud +charge `(1 - lam) · degree / card α` and the edge charge `1`, diluted by the +`(1 + degree)`-fold increase in darts. -/ +noncomputable def reduceConst (E : ExpanderFamily) (α : Type) [Fintype α] : ℝ := + min 1 ((1 - E.lam) * (E.degree : ℝ) / (Fintype.card α : ℝ)) / (2 * (1 + (E.degree : ℝ))) + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] +variable (G : ConstraintGraph α) (E : ExpanderFamily) + +/-! ### Splitting the unsatisfied darts -/ + +/-- The unsatisfied cloud-links. -/ +noncomputable def cloudDarts (A : (G.reduce E).Assignment) : Finset (G.reduce E).Dart := + ((G.reduce E).unsatDarts A).filter fun x => x.2 ≠ none + +/-- The unsatisfied edge-links. -/ +noncomputable def edgeDarts (A : (G.reduce E).Assignment) : Finset (G.reduce E).Dart := + ((G.reduce E).unsatDarts A).filter fun x => x.2 = none + +omit [Fintype α] [Nonempty α] in +theorem card_cloudDarts_add_card_edgeDarts (A : (G.reduce E).Assignment) : + (G.cloudDarts E A).card + (G.edgeDarts E A).card = ((G.reduce E).unsatDarts A).card := by + rw [cloudDarts, edgeDarts, Nat.add_comm] + exact Finset.card_filter_add_card_filter_not (s := (G.reduce E).unsatDarts A) + (p := fun x : (G.reduce E).Dart => x.2 = none) + +omit [Fintype α] [Nonempty α] in +theorem cloudUnsat_subset_cloudDarts (A : (G.reduce E).Assignment) (v : Fin G.numVerts) : + G.cloudUnsat E A v ⊆ G.cloudDarts E A := by + intro x hx + rw [cloudUnsat, Finset.mem_filter] at hx + rw [cloudDarts, Finset.mem_filter] + exact ⟨hx.1, hx.2.2⟩ + +/-- The cloud charge lands entirely among the unsatisfied cloud-links. -/ +theorem cloud_charge_le_card_cloudDarts (A : (G.reduce E).Assignment) : + (1 - E.lam) * (E.degree : ℝ) * ((G.devSet A).card : ℝ) / (Fintype.card α : ℝ) + ≤ ((G.cloudDarts E A).card : ℝ) := by + have hsum : ∑ v : Fin G.numVerts, + ((1 - E.lam) * (E.degree : ℝ) * ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ)) + ≤ ∑ v : Fin G.numVerts, ((G.cloudUnsat E A v).card : ℝ) := + Finset.sum_le_sum fun v _ => G.cloud_disagreement_bound E A v + have hleft : ∑ v : Fin G.numVerts, + ((1 - E.lam) * (E.degree : ℝ) * ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ)) + = (1 - E.lam) * (E.degree : ℝ) * ((G.devSet A).card : ℝ) / (Fintype.card α : ℝ) := by + rw [← Finset.sum_div, ← Finset.mul_sum] + congr 2 + rw [← Nat.cast_sum, G.sum_card_devIdx A] + have hdisj : ∀ u ∈ (Finset.univ : Finset (Fin G.numVerts)), + ∀ v ∈ (Finset.univ : Finset (Fin G.numVerts)), u ≠ v → + Disjoint (G.cloudUnsat E A u) (G.cloudUnsat E A v) := + fun u _ v _ h => G.cloudUnsat_disjoint E A h + have hnat : ∑ v : Fin G.numVerts, (G.cloudUnsat E A v).card ≤ (G.cloudDarts E A).card := by + rw [← Finset.card_biUnion hdisj] + refine Finset.card_le_card ?_ + intro x hx + rw [Finset.mem_biUnion] at hx + obtain ⟨v, -, hxv⟩ := hx + exact G.cloudUnsat_subset_cloudDarts E A v hxv + have hright : ∑ v : Fin G.numVerts, ((G.cloudUnsat E A v).card : ℝ) + ≤ ((G.cloudDarts E A).card : ℝ) := by + rw [← Nat.cast_sum] + exact_mod_cast hnat + rw [← hleft] + exact le_trans hsum hright + +/-! ### The edge-link charge -/ + +/-- The original edges that decoding fails and whose two half-edges both agree +with their vertices' labels. -/ +noncomputable def goodEdges (A : (G.reduce E).Assignment) : Finset (Fin G.numEdges) := + (G.unsatEdges (G.decode A)).filter fun e => + (e, false) ∉ G.devSet A ∧ (e, true) ∉ G.devSet A + +/-- Each such edge contributes an unsatisfied edge-link: the link carries +exactly the original constraint, evaluated at the decoded labels. -/ +theorem card_goodEdges_le (A : (G.reduce E).Assignment) : + (G.goodEdges E A).card ≤ (G.edgeDarts E A).card := by + refine Finset.card_le_card_of_injOn (fun e => ((e, false), none)) ?_ ?_ + · intro e he + simp only [Finset.mem_coe] at he ⊢ + rw [goodEdges, Finset.mem_filter] at he + obtain ⟨hfail, h0, h1⟩ := he + have hA0 : A (e, false) = G.decode A (G.tail e) := by + have h := (G.mem_devSet (A := A) (p := (e, false))).not.mp h0 + simp only [not_not] at h + have howner : G.owner ((e, false) : G.HalfEdge) = G.tail e := by simp [owner] + rw [h, howner] + have hA1 : A (e, true) = G.decode A (G.head e) := by + have h := (G.mem_devSet (A := A) (p := (e, true))).not.mp h1 + simp only [not_not] at h + have howner : G.owner ((e, true) : G.HalfEdge) = G.head e := by simp [owner] + rw [h, howner] + rw [edgeDarts, Finset.mem_filter] + refine ⟨?_, rfl⟩ + rw [RegCSP.mem_unsatDarts] + show ¬ ((if ((e, false) : G.HalfEdge).2 then + G.rel e (A ((G.reduce E).graph.nbr (e, false) none)) (A (e, false)) + else G.rel e (A (e, false)) (A ((G.reduce E).graph.nbr (e, false) none))) = true) + have hnbr : (G.reduce E).graph.nbr ((e, false) : G.HalfEdge) none = (e, true) := by + show G.flipHalf (e, false) = (e, true) + simp [flipHalf] + rw [hnbr] + simp only [if_neg (by simp : ¬ (((e, false) : G.HalfEdge).2 = true))] + rw [hA0, hA1] + rw [mem_unsatEdges] at hfail + rw [Satisfies, satisfies] at hfail + exact hfail + · intro e _ f _ hef + have := congrArg (fun x => x.1.1) hef + simpa using this + +/-- An edge that decoding fails is either billed to an edge-link or has a +disagreeing half-edge. -/ +theorem card_unsatEdges_le_charge (A : (G.reduce E).Assignment) : + (G.unsatEdges (G.decode A)).card ≤ (G.goodEdges E A).card + (G.devSet A).card := by + have hsub : G.unsatEdges (G.decode A) + ⊆ G.goodEdges E A ∪ (G.devSet A).image Prod.fst := by + intro e he + by_cases hgood : (e, false) ∉ G.devSet A ∧ (e, true) ∉ G.devSet A + · exact Finset.mem_union_left _ (by rw [goodEdges, Finset.mem_filter]; exact ⟨he, hgood⟩) + · refine Finset.mem_union_right _ ?_ + rw [Finset.mem_image] + rw [not_and_or, not_not, not_not] at hgood + rcases hgood with h | h + · exact ⟨(e, false), h, rfl⟩ + · exact ⟨(e, true), h, rfl⟩ + calc (G.unsatEdges (G.decode A)).card + ≤ (G.goodEdges E A ∪ (G.devSet A).image Prod.fst).card := Finset.card_le_card hsub + _ ≤ (G.goodEdges E A).card + ((G.devSet A).image Prod.fst).card := Finset.card_union_le _ _ + _ ≤ (G.goodEdges E A).card + (G.devSet A).card := by + exact Nat.add_le_add_left (Finset.card_image_le) _ + +/-! ### Soundness -/ + +/-- **The combined charge.** With `c = (1 - lam) · degree / card α`, the +unsatisfied darts number at least `min 1 c` times the edges that decoding +fails. -/ +theorem card_unsatDarts_ge (A : (G.reduce E).Assignment) : + min 1 ((1 - E.lam) * (E.degree : ℝ) / (Fintype.card α : ℝ)) + * ((G.unsatEdges (G.decode A)).card : ℝ) + ≤ (((G.reduce E).unsatDarts A).card : ℝ) := by + set c : ℝ := (1 - E.lam) * (E.degree : ℝ) / (Fintype.card α : ℝ) with hc + set D : ℝ := ((G.devSet A).card : ℝ) with hD + set U : ℝ := ((G.unsatEdges (G.decode A)).card : ℝ) with hU + have hcloud : c * D ≤ ((G.cloudDarts E A).card : ℝ) := by + have h := G.cloud_charge_le_card_cloudDarts E A + rw [hc, hD] + calc (1 - E.lam) * (E.degree : ℝ) / (Fintype.card α : ℝ) * ((G.devSet A).card : ℝ) + = (1 - E.lam) * (E.degree : ℝ) * ((G.devSet A).card : ℝ) / (Fintype.card α : ℝ) := by + ring + _ ≤ ((G.cloudDarts E A).card : ℝ) := h + have hedge : U ≤ ((G.edgeDarts E A).card : ℝ) + D := by + have h1 := G.card_unsatEdges_le_charge E A + have h2 := G.card_goodEdges_le E A + have h1R : U ≤ ((G.goodEdges E A).card : ℝ) + D := by rw [hU, hD]; exact_mod_cast h1 + have h2R : ((G.goodEdges E A).card : ℝ) ≤ ((G.edgeDarts E A).card : ℝ) := by + exact_mod_cast h2 + linarith + have htotal : ((G.cloudDarts E A).card : ℝ) + ((G.edgeDarts E A).card : ℝ) + = (((G.reduce E).unsatDarts A).card : ℝ) := by + rw [← Nat.cast_add, G.card_cloudDarts_add_card_edgeDarts E A] + have hDnn : 0 ≤ D := by rw [hD]; positivity + have hcnn : 0 ≤ c := by + rw [hc] + have h1 : 0 ≤ 1 - E.lam := by linarith [E.lam_lt_one] + positivity + rcases le_total 1 c with hcge | hcle + · have hmin : min 1 c = 1 := min_eq_left hcge + rw [hmin, one_mul, ← htotal] + nlinarith [hcloud, hedge] + · have hmin : min 1 c = c := min_eq_right hcle + rw [hmin, ← htotal] + nlinarith [hcloud, hedge, hDnn, hcnn] + +/-- **Soundness of degree reduction.** The reduced system's unsatisfied +fraction is at least a constant times the original's unsatisfiability value, +the constant depending only on the alphabet size and the cloud expander. -/ +theorem unsatFrac_reduce_ge (A : (G.reduce E).Assignment) : + min 1 ((1 - E.lam) * (E.degree : ℝ) / (Fintype.card α : ℝ)) / (2 * (1 + (E.degree : ℝ))) + * ((G.unsatVal : ℚ) : ℝ) + ≤ (((G.reduce E).unsatFrac A : ℚ) : ℝ) := by + set c : ℝ := min 1 ((1 - E.lam) * (E.degree : ℝ) / (Fintype.card α : ℝ)) with hc + have hcnn : 0 ≤ c := by + rw [hc] + refine le_min zero_le_one ?_ + have h1 : 0 ≤ 1 - E.lam := by linarith [E.lam_lt_one] + positivity + have hdart : ((G.reduce E).graph.order * (G.reduce E).graph.deg : ℕ) + = 2 * G.numEdges * (1 + E.degree) := by + show ((G.reduceGraph E).order * (G.reduceGraph E).deg : ℕ) = _ + rw [G.order_reduceGraph E, G.deg_reduceGraph E] + rcases Nat.eq_zero_or_pos G.numEdges with hm | hm + · have hsat : G.Satisfiable := by + by_contra hcon + have := G.numEdges_pos_of_not_satisfiable hcon + omega + have h0 : G.unsatVal = 0 := (G.unsatVal_eq_zero_iff_satisfiable).mpr hsat + rw [h0] + simp only [Rat.cast_zero, mul_zero] + have : (0 : ℚ) ≤ (G.reduce E).unsatFrac A := (G.reduce E).unsatFrac_nonneg A + exact_mod_cast this + · have hmq : (0 : ℝ) < (G.numEdges : ℝ) := by exact_mod_cast hm + have hfrac : (((G.reduce E).unsatFrac A : ℚ) : ℝ) + = (((G.reduce E).unsatDarts A).card : ℝ) + / (2 * (G.numEdges : ℝ) * (1 + (E.degree : ℝ))) := by + rw [RegCSP.unsatFrac, hdart] + push_cast + ring + have hU : ((G.unsatVal : ℚ) : ℝ) * (G.numEdges : ℝ) + ≤ ((G.unsatEdges (G.decode A)).card : ℝ) := by + have h := G.unsatVal_le (G.decode A) + rw [unsatFrac] at h + have hR : ((G.unsatVal : ℚ) : ℝ) + ≤ ((G.unsatEdges (G.decode A)).card : ℝ) / (G.numEdges : ℝ) := by + have hcast := (Rat.cast_le (K := ℝ)).mpr h + push_cast at hcast + exact hcast + rwa [le_div_iff₀ hmq] at hR + have hcharge := G.card_unsatDarts_ge E A + have hkey : c * ((G.unsatVal : ℚ) : ℝ) * (G.numEdges : ℝ) + ≤ (((G.reduce E).unsatDarts A).card : ℝ) := by + calc c * ((G.unsatVal : ℚ) : ℝ) * (G.numEdges : ℝ) + = c * (((G.unsatVal : ℚ) : ℝ) * (G.numEdges : ℝ)) := by ring + _ ≤ c * ((G.unsatEdges (G.decode A)).card : ℝ) := + mul_le_mul_of_nonneg_left hU hcnn + _ ≤ (((G.reduce E).unsatDarts A).card : ℝ) := hcharge + have hden : (0 : ℝ) < 2 * (G.numEdges : ℝ) * (1 + (E.degree : ℝ)) := by positivity + rw [hfrac, le_div_iff₀ hden] + calc c / (2 * (1 + (E.degree : ℝ))) * ((G.unsatVal : ℚ) : ℝ) + * (2 * (G.numEdges : ℝ) * (1 + (E.degree : ℝ))) + = c * ((G.unsatVal : ℚ) : ℝ) * (G.numEdges : ℝ) := by + have hd1 : (0 : ℝ) < 1 + (E.degree : ℝ) := by positivity + field_simp + _ ≤ (((G.reduce E).unsatDarts A).card : ℝ) := hkey + +/-- **Soundness of degree reduction, on values.** -/ +theorem le_unsatVal_reduce : + reduceConst E α * ((G.unsatVal : ℚ) : ℝ) ≤ (((G.reduce E).unsatVal : ℚ) : ℝ) := by + obtain ⟨A, hA⟩ := (G.reduce E).exists_assignment_unsatFrac_eq_unsatVal + rw [reduceConst, ← hA] + exact G.unsatFrac_reduce_ge E A + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Dinur.lean b/Complexitylib/Classes/PCP/Internal/Dinur.lean new file mode 100644 index 00000000..09af2c77 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Dinur.lean @@ -0,0 +1,363 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Compose +public import Complexitylib.Classes.PCP.Internal.PoweringBound +public import Complexitylib.Classes.PCP.Internal.Preprocess +public import Complexitylib.Classes.PCP.Internal.Amplification + +/-! +# One round of Dinur's amplification + +Preprocess, power, compose: the three steps assembled into a single +transformation of constraint graphs over a fixed alphabet, packaged as an +`Amplifier`. Given an expander family, the round + +* preserves satisfiability, +* multiplies the number of edges by a constant, and +* at least doubles the unsatisfiability value until it reaches a universal + threshold. + +The alphabet is the one the composition produces, `Alpha ReadIdx`. Powering +blows it up to `KOpinion`, whose size is a fixed function of the powering +length and the preprocessed degree; composition brings it back. + +The only free parameter is the killing rate `q`. The powering bound's slope +grows linearly in `q` while every other loss — preprocessing, composition — +is a constant, so a large enough `q` makes the round double the value. +`q` is chosen by an Archimedean argument, and the threshold is any rational +below the powering bound's floor. + +## Main definitions + +- `Complexity.DinurAlpha` — the fixed alphabet +- `Complexity.Dinur.step` — one round +- `Complexity.Dinur.amplifier` — the round as an `Amplifier` + +## Main results + +- `Complexity.Dinur.numEdges_step` — the edge count grows by a constant factor +- `Complexity.Dinur.satisfiable_step` — completeness +- `Complexity.Dinur.min_le_unsatVal_step` — the value at least doubles, up to + the threshold +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +/-- The fixed alphabet of the amplification: the composition's alphabet. -/ +abbrev DinurAlpha : Type := MultiTest.Alpha ReadIdx + +namespace Dinur + +variable (E : ExpanderFamily) + +/-! ### The powered alphabet's size -/ + +/-- The degree after preprocessing. -/ +def powDeg : ℕ := 2 + 2 * E.degree + +/-- The number of walks of length at most `T` out of a vertex. -/ +def walkCount (T : ℕ) : ℕ := ∑ ℓ ∈ Finset.range (T + 1), powDeg E ^ ℓ + +/-- The number of powered labels, as bits of a one-hot encoding. -/ +def bits (T : ℕ) : ℕ := Fintype.card DinurAlpha ^ walkCount E T + +theorem card_varWalk (G : ConstraintGraph DinurAlpha) (T : ℕ) : + Fintype.card (VarWalk (G.preprocess E).graph T) = walkCount E T := by + have hD : Fintype.card (G.preprocess E).graph.D = powDeg E := by + have := G.deg_preprocess E + rw [RegGraph.deg] at this + exact this + rw [walkCount, ← Fin.sum_univ_eq_sum_range (fun ℓ => powDeg E ^ ℓ) (T + 1)] + show Fintype.card (Σ ℓ : Fin (T + 1), Fin ℓ.val → (G.preprocess E).graph.D) = _ + rw [Fintype.card_sigma] + refine Finset.sum_congr rfl fun ℓ _ => ?_ + rw [Fintype.card_fun, Fintype.card_fin, hD] + +theorem card_kOpinion (G : ConstraintGraph DinurAlpha) (T : ℕ) : + Fintype.card (KOpinion (G.preprocess E).graph T DinurAlpha) = bits E T := by + show Fintype.card (VarWalk (G.preprocess E).graph T → DinurAlpha) = _ + rw [Fintype.card_fun, card_varWalk, bits] + +/-! ### The encoding -/ + +theorem basisVec_injective (n : ℕ) : Function.Injective (basisVec (n := n)) := by + intro i j hij + have h := congrFun hij i + by_contra hne + simp only [basisVec, if_true, if_neg hne] at h + exact absurd h (by decide) + +/-- The encoding of a powered label: the basis vector at its index. -/ +noncomputable def enc (G : ConstraintGraph DinurAlpha) (T : ℕ) + (σ : KOpinion (G.preprocess E).graph T DinurAlpha) : Cube (bits E T) := + basisVec (Fin.cast (card_kOpinion E G T) (Fintype.equivFin _ σ)) + +theorem enc_injective (G : ConstraintGraph DinurAlpha) (T : ℕ) : + Function.Injective (enc E G T) := by + intro σ τ h + have h1 := basisVec_injective _ h + have h2 := Fin.cast_injective _ h1 + exact (Fintype.equivFin _).injective h2 + +/-! ### One round -/ + +/-- The alphabet's size, the `K` of the powering parameters. + +Deliberately a `def` and not an `abbrev`. The alphabet has `2^23` symbols, and +`K` occurs inside `powT K q`, which is itself an exponent; letting a tactic +unfold `K` to a numeral there produces terms far too large to elaborate. -/ +def K : ℕ := Fintype.card DinurAlpha + +theorem one_le_K : 1 ≤ K := Fintype.card_pos + +theorem card_dinurAlpha_eq : Fintype.card DinurAlpha = K := rfl + +/-- **One round of amplification** with killing rate `q`. -/ +noncomputable def step (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) : + ConstraintGraph DinurAlpha := + (((G.preprocess E).killedPow q (powT K q) hq).compose (enc E G (powT K q))).toGraph + +/-- The constant factor by which a round multiplies the edge count. -/ +def edgeFactor (q : ℕ) : ℕ := + 2 * (powDeg E ^ powT K q * q ^ powT K q) * 2 ^ Tester.ROf (bits E (powT K q)) * 22 + +theorem numEdges_step (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) : + (step E q hq G).numEdges = edgeFactor E q * G.numEdges := by + rw [step, MultiTest.numEdges_toGraph, card_readIdx, RegCSP.card_dart, + RegCSP.card_dart_killedPow, G.order_preprocess, G.deg_preprocess, edgeFactor] + show 2 * G.numEdges * ((2 + 2 * E.degree) ^ powT K q * q ^ powT K q) + * 2 ^ Tester.ROf (bits E (powT K q)) * 22 = _ + rw [powDeg] + ring + +theorem satisfiable_step (q : ℕ) (hq : 0 < q) (G : ConstraintGraph DinurAlpha) + (h : G.Satisfiable) : (step E q hq G).Satisfiable := + RegCSP.satisfiable_compose _ _ + (RegCSP.satisfiable_killedPow_of_satisfiable _ _ _ _ + (G.satisfiable_preprocess_of_satisfiable E h)) + +/-! ### The value -/ + +theorem preprocessLam_nonneg : 0 ≤ ConstraintGraph.preprocessLam E := by + have := E.lam_nonneg + rw [ConstraintGraph.preprocessLam] + positivity + +theorem preprocessConst_pos : 0 < ConstraintGraph.preprocessConst E DinurAlpha := by + have hd : (0 : ℝ) < E.degree := by exact_mod_cast E.degree_pos + have hl : 0 < 1 - E.lam := by linarith [E.lam_lt_one] + have hK : (0 : ℝ) < Fintype.card DinurAlpha := by exact_mod_cast (Fintype.card_pos) + rw [ConstraintGraph.preprocessConst, ConstraintGraph.reduceConst] + have : 0 < min (1 : ℝ) ((1 - E.lam) * (E.degree : ℝ) / (Fintype.card DinurAlpha : ℝ)) := by + apply lt_min one_pos + positivity + positivity + +/-- **The value of one round**, for a fixed `q ≥ 2` and any graph with an edge: +at least the `min` of the powering slope (times the preprocessing constant) +times the value, and the powering floor, all divided by the composition's +loss. -/ +theorem le_unsatVal_step (q : ℕ) (hq2 : 2 ≤ q) (G : ConstraintGraph DinurAlpha) + (hG : 0 < G.numEdges) : + min (RegCSP.powSlope (RegCSP.powConst q DinurAlpha) (powT K q) (ConstraintGraph.preprocessLam E) + * ConstraintGraph.preprocessConst E DinurAlpha * ((G.unsatVal : ℚ) : ℝ)) + (RegCSP.powFloor (RegCSP.powConst q DinurAlpha) (powT K q) + (ConstraintGraph.preprocessLam E)) / 704 + ≤ (((step E q (by omega) G).unsatVal : ℚ) : ℝ) := by + have hq : 0 < q := by omega + obtain ⟨hH, hHT, hsq, hloss⟩ := powering_params_spec one_le_K hq2 (G.preprocess E).graph.deg + have hn : 0 < (G.preprocess E).graph.order := by + rw [G.order_preprocess]; omega + have hpow := (G.preprocess E).le_unsatVal_killedPow_min q (powT K q) hq hH hHT hsq + (preprocessLam_nonneg E) (ConstraintGraph.preprocessLam_lt_one E) + (G.spectralBound_preprocess E) hn + (by omega) hloss + have hpre := G.le_unsatVal_preprocess E + have hcomp : (((((G.preprocess E).killedPow q (powT K q) hq).unsatVal : ℚ) : ℝ)) / 704 + ≤ (((step E q hq G).unsatVal : ℚ) : ℝ) := by + have := ((G.preprocess E).killedPow q (powT K q) hq).le_unsatVal_compose + (enc E G (powT K q)) (enc_injective E G (powT K q)) + have h' : ((((((G.preprocess E).killedPow q (powT K q) hq).unsatVal / 704 : ℚ)) : ℝ)) + ≤ (((step E q hq G).unsatVal : ℚ) : ℝ) := by exact_mod_cast this + push_cast at h' + exact h' + refine le_trans ?_ hcomp + refine div_le_div_of_nonneg_right ?_ (by norm_num) + refine le_trans ?_ hpow + refine min_le_min_right _ ?_ + rw [mul_assoc] + refine mul_le_mul_of_nonneg_left hpre ?_ + rw [RegCSP.powSlope] + have hl : 0 < 1 - ConstraintGraph.preprocessLam E := by + linarith [ConstraintGraph.preprocessLam_lt_one E] + have hc : 0 ≤ RegCSP.powConst q DinurAlpha := by + rw [RegCSP.powConst, card_dinurAlpha_eq] + have h1 : (1 : ℝ) ≤ q := by exact_mod_cast (by omega : 1 ≤ q) + have hK0 : (0 : ℝ) < K := by exact_mod_cast one_le_K + apply div_nonneg + · linarith + · have hsq : (0 : ℝ) ≤ (K : ℝ) ^ 2 := sq_nonneg _ + linarith + have hT0 : (0 : ℝ) ≤ (powT K q : ℝ) := Nat.cast_nonneg _ + have hden : 0 ≤ RegCSP.powConst q DinurAlpha + 2 + 2 * (powT K q : ℝ) + / (1 - ConstraintGraph.preprocessLam E) := by + have := div_nonneg (mul_nonneg (by norm_num : (0 : ℝ) ≤ 2) hT0) hl.le + linarith + exact div_nonneg (pow_nonneg hc 2) hden + +/-! ### Choosing the killing rate -/ + +/-- **A killing rate that doubles the value.** -/ +theorem exists_q : ∃ q : ℕ, 2 ≤ q ∧ 1408 + ≤ RegCSP.powSlope (RegCSP.powConst q DinurAlpha) (powT K q) (ConstraintGraph.preprocessLam E) + * ConstraintGraph.preprocessConst E DinurAlpha := by + have hpc := preprocessConst_pos E + have hl1 := ConstraintGraph.preprocessLam_lt_one E + have hK0 : (0 : ℝ) < K := by exact_mod_cast one_le_K + have hs : 0 < slopeUnit (K : ℝ) (ConstraintGraph.preprocessLam E) := by + rw [slopeUnit] + have : 0 < 1 - ConstraintGraph.preprocessLam E := by linarith + positivity + obtain ⟨n, hn⟩ := exists_nat_ge (1408 / (slopeUnit (K : ℝ) (ConstraintGraph.preprocessLam E) + * ConstraintGraph.preprocessConst E DinurAlpha)) + refine ⟨n + 2, by omega, ?_⟩ + have hslope := slopeUnit_mul_le_powSlope (q := n + 2) one_le_K (by omega) hl1 + have hcast : (((n + 2 : ℕ) : ℝ) - 1) = (n : ℝ) + 1 := by push_cast; ring + rw [hcast] at hslope + have hpc' : RegCSP.powConst (n + 2) DinurAlpha = ((n : ℝ) + 1) / (4 * (K : ℝ) ^ 2) := by + rw [RegCSP.powConst, card_dinurAlpha_eq] + push_cast + ring + rw [hpc'] + rw [div_le_iff₀ (by positivity)] at hn + calc (1408 : ℝ) + ≤ n * (slopeUnit (K : ℝ) (ConstraintGraph.preprocessLam E) + * ConstraintGraph.preprocessConst E DinurAlpha) := hn + _ ≤ slopeUnit (K : ℝ) (ConstraintGraph.preprocessLam E) * ((n : ℝ) + 1) + * ConstraintGraph.preprocessConst E DinurAlpha := by + nlinarith [hs, hpc] + _ ≤ _ := mul_le_mul_of_nonneg_right hslope hpc.le + +/-- The chosen killing rate. -/ +noncomputable def q₀ : ℕ := Classical.choose (exists_q E) + +theorem two_le_q₀ : 2 ≤ q₀ E := (Classical.choose_spec (exists_q E)).1 + +theorem q₀_spec : 1408 + ≤ RegCSP.powSlope (RegCSP.powConst (q₀ E) DinurAlpha) (powT K (q₀ E)) + (ConstraintGraph.preprocessLam E) * ConstraintGraph.preprocessConst E DinurAlpha := + (Classical.choose_spec (exists_q E)).2 + +/-- The powering floor at the chosen rate. -/ +noncomputable def floor₀ : ℝ := + RegCSP.powFloor (RegCSP.powConst (q₀ E) DinurAlpha) (powT K (q₀ E)) + (ConstraintGraph.preprocessLam E) + +theorem floor₀_pos : 0 < floor₀ E := by + rw [floor₀, RegCSP.powFloor] + have hl : 0 < 1 - ConstraintGraph.preprocessLam E := by + linarith [ConstraintGraph.preprocessLam_lt_one E] + have hc : 0 < RegCSP.powConst (q₀ E) DinurAlpha := by + rw [RegCSP.powConst, card_dinurAlpha_eq] + have h2 : (2 : ℝ) ≤ q₀ E := by exact_mod_cast two_le_q₀ E + have hK0 : (0 : ℝ) < K := by exact_mod_cast one_le_K + apply div_pos + · linarith + · have hsq : (0 : ℝ) < (K : ℝ) ^ 2 := pow_pos hK0 2 + linarith + have hT : (0 : ℝ) < powT K (q₀ E) := by + have hpos : 0 < powT K (q₀ E) := by + rw [powT] + have h1 : 1 ≤ K := one_le_K + have h2 : 2 ≤ q₀ E := two_le_q₀ E + have h3 : 1 ≤ q₀ E - 1 := by omega + calc 0 < 2 * (4 * 1 * 1) := by norm_num + _ ≤ 2 * (4 * K * (q₀ E - 1)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul (Nat.mul_le_mul_left _ h1) h3) + exact_mod_cast hpos + have hT2 : 0 < (powT K (q₀ E) : ℝ) ^ 2 := pow_pos hT 2 + exact div_pos (div_pos (pow_pos hc 2) hT2) + (add_pos (add_pos hc (mul_pos two_pos hT2)) (div_pos (mul_pos two_pos hT) hl)) + +/-- **A rational threshold** below the floor (after the composition's loss) and +below one. -/ +theorem exists_gap : ∃ g : ℚ, 0 < g ∧ g ≤ 1 ∧ (g : ℝ) ≤ floor₀ E / 704 := by + have h : (0 : ℝ) < min (floor₀ E / 704) 1 := lt_min (by linarith [floor₀_pos E]) one_pos + obtain ⟨g, hg0, hg1⟩ := exists_rat_btwn h + refine ⟨g, by exact_mod_cast hg0, ?_, ?_⟩ + · have : (g : ℝ) ≤ 1 := le_trans hg1.le (min_le_right _ _) + exact_mod_cast this + · exact le_trans hg1.le (min_le_left _ _) + +/-- The chosen threshold. -/ +noncomputable def gap₀ : ℚ := Classical.choose (exists_gap E) + +theorem gap₀_pos : 0 < gap₀ E := (Classical.choose_spec (exists_gap E)).1 +theorem gap₀_le_one : gap₀ E ≤ 1 := (Classical.choose_spec (exists_gap E)).2.1 +theorem gap₀_le : ((gap₀ E : ℚ) : ℝ) ≤ floor₀ E / 704 := (Classical.choose_spec (exists_gap E)).2.2 + +/-- An edgeless graph has value zero. -/ +theorem unsatVal_eq_zero_of_numEdges_eq_zero (G : ConstraintGraph DinurAlpha) + (h : G.numEdges = 0) : G.unsatVal = 0 := by + refine le_antisymm ?_ G.unsatVal_nonneg + have a : G.Assignment := fun _ => Classical.arbitrary _ + refine le_trans (G.unsatVal_le a) ?_ + rw [ConstraintGraph.unsatFrac] + have hz : (G.numEdges : ℚ) = 0 := by rw [h]; norm_num + rw [hz, div_zero] + +/-- **The value at least doubles, up to the threshold.** -/ +theorem min_le_unsatVal_step (G : ConstraintGraph DinurAlpha) : + min (gap₀ E) (2 * G.unsatVal) ≤ (step E (q₀ E) (by have := two_le_q₀ E; omega) G).unsatVal := by + by_cases h0 : G.numEdges = 0 + · rw [unsatVal_eq_zero_of_numEdges_eq_zero G h0, mul_zero] + refine le_trans (min_le_right _ _) ?_ + exact ConstraintGraph.unsatVal_nonneg _ + have hG : 0 < G.numEdges := Nat.pos_of_ne_zero h0 + have hmain := le_unsatVal_step E (q₀ E) (two_le_q₀ E) G hG + have hq := q₀_spec E + have hv0 : (0 : ℝ) ≤ ((G.unsatVal : ℚ) : ℝ) := by exact_mod_cast G.unsatVal_nonneg + have hcast : (((min (gap₀ E) (2 * G.unsatVal) : ℚ)) : ℝ) + ≤ (((step E (q₀ E) (by have := two_le_q₀ E; omega) G).unsatVal : ℚ) : ℝ) := by + push_cast + refine le_trans ?_ hmain + rw [le_div_iff₀ (by norm_num : (0 : ℝ) < 704)] + have hgap := gap₀_le E + rw [floor₀] at hgap + refine le_min ?_ ?_ + · refine le_trans (mul_le_mul_of_nonneg_right (min_le_right _ _) (by norm_num)) ?_ + set s := RegCSP.powSlope (RegCSP.powConst (q₀ E) DinurAlpha) (powT K (q₀ E)) + (ConstraintGraph.preprocessLam E) with hs + set pc := ConstraintGraph.preprocessConst E DinurAlpha with hpc + have : (2 : ℝ) * ((G.unsatVal : ℚ) : ℝ) * 704 = 1408 * ((G.unsatVal : ℚ) : ℝ) := by ring + rw [this] + exact mul_le_mul_of_nonneg_right hq hv0 + · refine le_trans (mul_le_mul_of_nonneg_right (min_le_left _ _) (by norm_num)) ?_ + rw [le_div_iff₀ (by norm_num : (0 : ℝ) < 704)] at hgap + exact hgap + exact_mod_cast hcast + +/-! ### The amplifier -/ + +/-- **Dinur's round as an `Amplifier`.** -/ +noncomputable def amplifier : Amplifier DinurAlpha where + transform := step E (q₀ E) (by have := two_le_q₀ E; omega) + edgeFactor := edgeFactor E (q₀ E) + gap := gap₀ E + gap_pos := gap₀_pos E + gap_le_one := gap₀_le_one E + numEdges_transform_le := fun G => le_of_eq (numEdges_step E _ _ G) + satisfiable_transform := fun G h => satisfiable_step E _ _ G h + unsatVal_transform_ge := fun G => min_le_unsatVal_step E G + +end Dinur + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Disagreement.lean b/Complexitylib/Classes/PCP/Internal/Disagreement.lean new file mode 100644 index 00000000..8209ca23 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Disagreement.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.EdgeExpansion + +/-! +# Disagreement across an expander + +The counting fact that makes Dinur's clouds work. A cloud is wired by an +expander and carries equality constraints, so an assignment that is not constant +on the cloud must break many of them. Quantitatively: if `f` labels the vertices +of an expander and `S` is the set of vertices whose label differs from some +fixed value `c`, then at least `(1 - lam) · deg · |S| · |Sᶜ| / n` darts join two +vertices with *different* labels — because every dart from `S` to `Sᶜ` does, and +`EdgeExpansion` counts those. + +Taking `c` to be a plurality value of `f` — which by pigeonhole is held by at +least a `1 / |α|` fraction of the vertices — turns this into + +`(1 - lam) · deg · |S| / |α| ≤ #disagreeing darts`, + +a bound linear in the number of deviant vertices, with a constant depending only +on the expander and the alphabet. That is exactly the exchange rate degree +reduction needs: each vertex that lies about its cloud's value pays for itself +in broken equality constraints. + +## Main definitions + +- `RegGraph.disagreeDarts` — the darts whose two ends carry different labels + +## Main results + +- `exists_plurality_value` — pigeonhole: some value is held `n / |α|` often +- `RegGraph.card_disagreeDarts_ge` — disagreement is at least the edge boundary +- `RegGraph.card_disagreeDarts_ge_of_plurality` — the form used by clouds +-/ + +@[expose] public section + +namespace Complexity + +/-- **Pigeonhole.** Some value is taken by at least a `1 / |α|` fraction. -/ +theorem exists_plurality_value {V α : Type} [Fintype V] [Fintype α] [Nonempty α] + [DecidableEq α] (f : V → α) : + ∃ c : α, Fintype.card V + ≤ Fintype.card α * (Finset.univ.filter fun v => f v = c).card := by + classical + obtain ⟨c, -, hc⟩ := Finset.exists_max_image (Finset.univ : Finset α) + (fun a => (Finset.univ.filter fun v => f v = a).card) + ⟨Classical.arbitrary α, Finset.mem_univ _⟩ + refine ⟨c, ?_⟩ + have hsum : ∑ a : α, (Finset.univ.filter fun v => f v = a).card = Fintype.card V := by + rw [← Finset.card_eq_sum_card_fiberwise (f := f) (fun v _ => Finset.mem_univ (f v)), + Finset.card_univ] + calc Fintype.card V = ∑ a : α, (Finset.univ.filter fun v => f v = a).card := hsum.symm + _ ≤ ∑ _a : α, (Finset.univ.filter fun v => f v = c).card := + Finset.sum_le_sum fun a _ => hc a (Finset.mem_univ a) + _ = Fintype.card α * (Finset.univ.filter fun v => f v = c).card := by + rw [Finset.sum_const, Finset.card_univ, smul_eq_mul] + +namespace RegGraph + +variable {α : Type} [DecidableEq α] (G : RegGraph) + +/-- The darts whose two endpoints carry different labels. -/ +def disagreeDarts (f : G.V → α) : Finset (G.V × G.D) := + Finset.univ.filter fun p => f p.1 ≠ f (G.nbr p.1 p.2) + +/-- **Disagreement is at least the edge boundary.** Every dart leaving the set +of vertices that differ from `c` joins two differently-labelled vertices. -/ +theorem card_disagreeDarts_ge {lam : ℝ} (hlam : 0 ≤ lam) (h : G.SpectralBound lam) + (hn : 0 < G.order) (f : G.V → α) (c : α) : + (1 - lam) * (G.deg : ℝ) + * (((Finset.univ.filter fun v => f v ≠ c).card : ℝ) + * ((Finset.univ.filter fun v => f v ≠ c)ᶜ.card : ℝ) / (G.order : ℝ)) + ≤ ((G.disagreeDarts f).card : ℝ) := by + classical + set S : Finset G.V := Finset.univ.filter fun v => f v ≠ c with hS + have hsub : G.dartsBetween S Sᶜ ⊆ G.disagreeDarts f := by + intro p hp + rw [dartsBetween, Finset.mem_filter] at hp + obtain ⟨-, h1, h2⟩ := hp + rw [hS, Finset.mem_filter] at h1 + have h2' : f (G.nbr p.1 p.2) = c := by + by_contra hcon + refine (Finset.mem_compl.mp h2) ?_ + rw [hS, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hcon⟩ + rw [disagreeDarts, Finset.mem_filter] + exact ⟨Finset.mem_univ _, by rw [h2']; exact h1.2⟩ + have hcard : ((G.dartsBetween S Sᶜ).card : ℝ) ≤ ((G.disagreeDarts f).card : ℝ) := by + exact_mod_cast Finset.card_le_card hsub + exact le_trans (G.card_dartsBetween_compl_ge hlam h hn S) hcard + +/-- The form the cloud argument uses: with `c` a plurality value, the number of +disagreeing darts is proportional to the number of deviant vertices. -/ +theorem card_disagreeDarts_ge_of_plurality [Fintype α] {lam : ℝ} (hlam : 0 ≤ lam) + (hlam1 : lam ≤ 1) (h : G.SpectralBound lam) (hn : 0 < G.order) (f : G.V → α) (c : α) + (hc : G.order ≤ Fintype.card α * (Finset.univ.filter fun v => f v = c).card) : + (1 - lam) * (G.deg : ℝ) + * (((Finset.univ.filter fun v => f v ≠ c).card : ℝ) / (Fintype.card α : ℝ)) + ≤ ((G.disagreeDarts f).card : ℝ) := by + classical + set S : Finset G.V := Finset.univ.filter fun v => f v ≠ c with hS + have hcompl : Sᶜ = Finset.univ.filter fun v => f v = c := by + rw [hS] + ext v + simp + have hnq : (0 : ℝ) < (G.order : ℝ) := by exact_mod_cast hn + have hαq : (0 : ℝ) < (Fintype.card α : ℝ) := by + have : 0 < Fintype.card α := Fintype.card_pos_iff.mpr ⟨c⟩ + exact_mod_cast this + have hcq : (G.order : ℝ) ≤ (Fintype.card α : ℝ) * (Sᶜ.card : ℝ) := by + rw [hcompl] + exact_mod_cast hc + -- `|Sᶜ| / n ≥ 1 / |α|` + have hfrac : (S.card : ℝ) / (Fintype.card α : ℝ) + ≤ (S.card : ℝ) * (Sᶜ.card : ℝ) / (G.order : ℝ) := by + rw [div_le_div_iff₀ hαq hnq] + have hS0 : (0 : ℝ) ≤ (S.card : ℝ) := by positivity + nlinarith [hcq, hS0] + refine le_trans ?_ (G.card_disagreeDarts_ge hlam h hn f c) + have hfac : (0 : ℝ) ≤ (1 - lam) * (G.deg : ℝ) := by + have : (0 : ℝ) ≤ (G.deg : ℝ) := by positivity + nlinarith [hlam1] + exact mul_le_mul_of_nonneg_left hfrac hfac + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean b/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean new file mode 100644 index 00000000..14a526cf --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Mixing + +/-! +# Edge expansion from the spectral bound + +Dinur's degree-reduction step needs expansion in its *combinatorial* form: a +vertex set with few outgoing edges must be almost everything or almost nothing. +This module derives that from `Mixing` by feeding it indicator functions. + +Specialising `mixing_sq` to `1_S` and `1_T` says that the number of darts from +`S` to `T` is what independence predicts, `deg · |S| · |T| / n`, up to +`lam` times the two variances. Taking `T = Sᶜ`, both variances equal +`|S| |Sᶜ| / n`, so the error term's square root is rational in the data and no +`Real.sqrt` is needed: the number of darts leaving `S` is at least +`(1 - lam) · deg · |S| |Sᶜ| / n`. + +That is exactly the statement degree reduction consumes: inside a cloud built on +an expander, the vertices disagreeing with the cloud's plurality label send out +proportionally many edges, each of which is an unsatisfied equality constraint. + +## Main definitions + +- `RegGraph.dartsBetween` — the darts from one vertex set to another + +## Main results + +- `RegGraph.sum_indicator_mul_step` — the dart count as an operator inner + product +- `RegGraph.mixing_sq_indicator` — the mixing lemma for vertex sets +- `RegGraph.card_dartsBetween_compl_ge` — **edge expansion**: a set sends out at + least `(1 - lam) · deg · |S| |Sᶜ| / n` darts +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-- The darts whose tail lies in `S` and whose head lies in `T`. -/ +def dartsBetween (S T : Finset G.V) : Finset (G.V × G.D) := + Finset.univ.filter fun p => p.1 ∈ S ∧ G.nbr p.1 p.2 ∈ T + +/-- The real-valued indicator of a vertex set. -/ +def indicator (S : Finset G.V) : G.V → ℝ := + fun v => if v ∈ S then 1 else 0 + +@[simp] theorem sum_indicator (S : Finset G.V) : + ∑ v : G.V, G.indicator S v = (S.card : ℝ) := by + simp [indicator, Finset.sum_ite_mem] + +@[simp] theorem sum_sq_indicator (S : Finset G.V) : + ∑ v : G.V, (G.indicator S v) ^ 2 = (S.card : ℝ) := by + have h : ∀ v : G.V, (G.indicator S v) ^ 2 = G.indicator S v := by + intro v; by_cases hv : v ∈ S <;> simp [indicator, hv] + rw [Finset.sum_congr rfl fun v _ => h v, sum_indicator] + +/-- The dart count between two sets, as an inner product against the walk +operator. -/ +theorem sum_indicator_mul_step (S T : Finset G.V) : + ∑ v : G.V, G.indicator S v * G.step (G.indicator T) v + = ((G.dartsBetween S T).card : ℝ) / (G.deg : ℝ) := by + have hstep : ∀ v : G.V, G.indicator S v * G.step (G.indicator T) v + = (∑ i : G.D, G.indicator S v * G.indicator T (G.nbr v i)) / (G.deg : ℝ) := by + intro v + rw [step, mul_div_assoc', Finset.mul_sum] + rw [Finset.sum_congr rfl fun v _ => hstep v, ← Finset.sum_div] + congr 1 + have hprod : ∑ v : G.V, ∑ i : G.D, G.indicator S v * G.indicator T (G.nbr v i) + = ∑ p : G.V × G.D, G.indicator S p.1 * G.indicator T (G.nbr p.1 p.2) := + (Fintype.sum_prod_type + (fun p : G.V × G.D => G.indicator S p.1 * G.indicator T (G.nbr p.1 p.2))).symm + rw [hprod, dartsBetween, Finset.card_filter] + push_cast + refine Finset.sum_congr rfl fun p _ => ?_ + by_cases h1 : p.1 ∈ S + · by_cases h2 : G.nbr p.1 p.2 ∈ T <;> simp [indicator, h1, h2] + · simp [indicator, h1] + +/-- **The mixing lemma for vertex sets.** -/ +theorem mixing_sq_indicator {lam : ℝ} (h : G.SpectralBound lam) (hn : 0 < G.order) + (S T : Finset G.V) : + (((G.dartsBetween S T).card : ℝ) / (G.deg : ℝ) + - (S.card : ℝ) * (T.card : ℝ) / (G.order : ℝ)) ^ 2 + ≤ lam ^ 2 * ((S.card : ℝ) - (S.card : ℝ) ^ 2 / (G.order : ℝ)) + * ((T.card : ℝ) - (T.card : ℝ) ^ 2 / (G.order : ℝ)) := by + have hmix := G.mixing_sq h hn 1 (G.indicator S) (G.indicator T) + rw [stepIter_succ, stepIter_zero] at hmix + rwa [G.sum_indicator_mul_step S T, sum_indicator, sum_indicator, sum_sq_indicator, + sum_sq_indicator] at hmix + +/-- **Edge expansion.** A vertex set sends out at least +`(1 - lam) · deg · |S| · |Sᶜ| / n` darts. -/ +theorem card_dartsBetween_compl_ge {lam : ℝ} (hlam : 0 ≤ lam) (h : G.SpectralBound lam) + (hn : 0 < G.order) (S : Finset G.V) : + (1 - lam) * (G.deg : ℝ) * ((S.card : ℝ) * (Sᶜ.card : ℝ) / (G.order : ℝ)) + ≤ ((G.dartsBetween S Sᶜ).card : ℝ) := by + have hnq : (0 : ℝ) < (G.order : ℝ) := by exact_mod_cast hn + have hdq : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity + set B : ℝ := (S.card : ℝ) * (Sᶜ.card : ℝ) / (G.order : ℝ) with hB + have hBnn : 0 ≤ B := by positivity + -- both variances are `B` + have hcompl : (S.card : ℝ) + (Sᶜ.card : ℝ) = (G.order : ℝ) := by + have h : S.card + Sᶜ.card = Fintype.card G.V := Finset.card_add_card_compl S + rw [order] + exact_mod_cast h + have hvarS : (S.card : ℝ) - (S.card : ℝ) ^ 2 / (G.order : ℝ) = B := by + rw [hB] + field_simp + nlinarith [hcompl] + have hvarT : (Sᶜ.card : ℝ) - (Sᶜ.card : ℝ) ^ 2 / (G.order : ℝ) = B := by + rw [hB] + field_simp + nlinarith [hcompl] + have hmix := G.mixing_sq_indicator h hn S Sᶜ + rw [hvarS, hvarT] at hmix + -- the deviation is at most `lam * B` + set X : ℝ := ((G.dartsBetween S Sᶜ).card : ℝ) / (G.deg : ℝ) with hX + have hsq : (X - B) ^ 2 ≤ (lam * B) ^ 2 := by + calc (X - B) ^ 2 ≤ lam ^ 2 * B * B := by + rw [hB] at hmix ⊢ + exact hmix + _ = (lam * B) ^ 2 := by ring + have habs : B - X ≤ lam * B := by + have h1 : (B - X) ^ 2 ≤ (lam * B) ^ 2 := by + calc (B - X) ^ 2 = (X - B) ^ 2 := by ring + _ ≤ (lam * B) ^ 2 := hsq + exact le_of_sq_le_sq h1 (by positivity) + have hXge : (1 - lam) * B ≤ X := by linarith + calc (1 - lam) * (G.deg : ℝ) * B = (G.deg : ℝ) * ((1 - lam) * B) := by ring + _ ≤ (G.deg : ℝ) * X := by exact mul_le_mul_of_nonneg_left hXge (le_of_lt hdq) + _ = ((G.dartsBetween S Sᶜ).card : ℝ) := by rw [hX]; field_simp + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Expander.lean b/Complexitylib/Classes/PCP/Internal/Expander.lean new file mode 100644 index 00000000..f9ec772a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Expander.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Union +public import Complexitylib.Classes.PCP.Internal.NumEnc + +/-! +# Expander families, and expanderizing a graph + +Dinur's preprocessing needs a *fixed* constant degree `d` and a constant +`lam < 1` such that every vertex count admits a `d`-regular graph with spectral +bound `lam`. `ExpanderFamily` packages exactly that. + +The family is given as **raw rotation data** on `Fin n × Fin degree`, one +involution per vertex count, rather than as a function into `RegGraph`. That +matters downstream: degree reduction puts an expander on the cloud of *every* +vertex at once, and those clouds have different sizes, so all of them must speak +the same label type `Fin degree`. Deriving the graphs from shared data gives +that for free, and makes `order` and `deg` computations `Fintype.card_fin` +rather than hypotheses. + +Isolating the requirement this way matters for a second reason: nothing else in +the development depends on *how* the family is built. Neither Mathlib nor this +library currently contains an explicit expander construction — no spectral gap, +edge expansion, Cheeger inequality, or zig-zag product — so producing an +`ExpanderFamily` is a self-contained sub-project (zig-zag, or a Margulis-type +Cayley construction), and everything downstream is already stated against this +interface. + +## Main definitions + +- `RegGraph.ofRot` — a graph on `Fin n` from a rotation involution +- `ExpanderFamily` — constant degree, uniform spectral bound, shared label type +- `ExpanderFamily.graph`, `ExpanderFamily.expanderize` + +## Main results + +- `ExpanderFamily.order_graph`, `ExpanderFamily.deg_graph` +- `ExpanderFamily.spectralBound_expanderize` — expanderization has a bound +- `ExpanderFamily.expanderize_bound_lt_one` — and the bound is below one +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +/-- The graph on `Fin n` with labels `Fin d` given by a rotation involution. -/ +def ofRot (d : ℕ) (hd : 0 < d) (n : ℕ) (rot : Fin n × Fin d → Fin n × Fin d) + (hrot : Function.Involutive rot) : RegGraph where + V := Fin n + D := Fin d + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨⟨0, hd⟩⟩ + rot := rot + rot_involutive := hrot + +@[simp] theorem order_ofRot (d : ℕ) (hd : 0 < d) (n : ℕ) + (rot : Fin n × Fin d → Fin n × Fin d) (hrot : Function.Involutive rot) : + (ofRot d hd n rot hrot).order = n := Fintype.card_fin n + +@[simp] theorem deg_ofRot (d : ℕ) (hd : 0 < d) (n : ℕ) + (rot : Fin n × Fin d → Fin n × Fin d) (hrot : Function.Involutive rot) : + (ofRot d hd n rot hrot).deg = d := Fintype.card_fin d + +end RegGraph + +/-- A family of constant-degree expanders, presented as rotation data: for every +vertex count `n`, an involution on `Fin n × Fin degree` whose graph contracts +mean-zero functions by a fixed `lam < 1`. -/ +structure ExpanderFamily where + /-- The constant degree, shared by every member. -/ + degree : ℕ + /-- The degree is positive. -/ + degree_pos : 0 < degree + /-- The rotation map on `n` vertices. -/ + rot : ∀ n : ℕ, Fin n × Fin degree → Fin n × Fin degree + /-- Each rotation map is an involution. -/ + rot_involutive : ∀ n, Function.Involutive (rot n) + /-- The uniform contraction factor. -/ + lam : ℝ + /-- The factor is nonnegative. -/ + lam_nonneg : 0 ≤ lam + /-- The factor is below one: this is the spectral gap. -/ + lam_lt_one : lam < 1 + /-- Every member contracts mean-zero functions by `lam`. -/ + spectral : ∀ n : ℕ, + (RegGraph.ofRot degree degree_pos n (rot n) (rot_involutive n)).SpectralBound lam + +namespace ExpanderFamily + +variable (E : ExpanderFamily) (G : RegGraph) [NumEnc G.V] + +/-- The member of the family on `n` vertices. -/ +def graph (n : ℕ) : RegGraph := + RegGraph.ofRot E.degree E.degree_pos n (E.rot n) (E.rot_involutive n) + +@[simp] theorem V_graph (n : ℕ) : (E.graph n).V = Fin n := rfl + +@[simp] theorem D_graph (n : ℕ) : (E.graph n).D = Fin E.degree := rfl + +@[simp] theorem order_graph (n : ℕ) : (E.graph n).order = n := Fintype.card_fin n + +@[simp] theorem deg_graph (n : ℕ) : (E.graph n).deg = E.degree := Fintype.card_fin E.degree + +theorem spectral_graph (n : ℕ) : (E.graph n).SpectralBound E.lam := E.spectral n + +/-- The identification of the family member's vertices with `G`'s: the +numbering `G`'s vertices carry. -/ +noncomputable def vertexEquiv : (E.graph G.order).V ≃ G.V := + (NumEnc.equivFinCard G.V).symm + +/-- `G` with a family expander superposed on its vertices. -/ +noncomputable def expanderize : RegGraph := + RegGraph.union G (E.graph G.order) (E.vertexEquiv G) + +@[simp] theorem order_expanderize : (E.expanderize G).order = G.order := rfl + +@[simp] theorem deg_expanderize : (E.expanderize G).deg = G.deg + E.degree := by + rw [expanderize, RegGraph.deg_union, deg_graph] + +/-- **Expanderization.** Superposing a family expander gives a graph with a +spectral bound. -/ +theorem spectralBound_expanderize : + (E.expanderize G).SpectralBound + (((G.deg : ℝ) + (E.degree : ℝ) * E.lam) / ((G.deg : ℝ) + (E.degree : ℝ))) := by + have h := RegGraph.spectralBound_union G (E.graph G.order) (E.vertexEquiv G) + E.lam_nonneg (E.spectral_graph G.order) + rw [deg_graph] at h + exact h + +omit [NumEnc G.V] in +/-- The resulting bound is strictly below one, which is what makes powering gain +a factor. -/ +theorem expanderize_bound_lt_one : + ((G.deg : ℝ) + (E.degree : ℝ) * E.lam) / ((G.deg : ℝ) + (E.degree : ℝ)) < 1 := by + have hdG : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity + have hdE : (0 : ℝ) < (E.degree : ℝ) := by exact_mod_cast E.degree_pos + rw [div_lt_one (by positivity)] + nlinarith [E.lam_lt_one, E.lam_nonneg] + +end ExpanderFamily + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean b/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean new file mode 100644 index 00000000..9fb87277 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean @@ -0,0 +1,290 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ExpanderMerge +public import Complexitylib.Classes.PCP.Internal.ExpanderPad +public import Complexitylib.Classes.PCP.Internal.Power +public import Complexitylib.Classes.PCP.Internal.Clique + +/-! +# An expander family from expanders of square size + +Explicit constructions such as Margulis's live on `m × m` grids. This module +turns a family on the squares into an `ExpanderFamily` on every vertex count: + +* the square graphs are powered until the bound is at most `1/2`, and their + darts renamed to a `Fin`; +* for `n ≥ 10` a square `N = m²` with `2n ≤ N ≤ 3n` exists, and the merge of + `ExpanderMerge` gives a graph on `n` vertices; +* for `n < 10` a clique with loops does, padded up to the common degree. + +## Main definitions + +- `Complexity.SquareFamily` — expanders on every `m * m` +- `Complexity.SquareFamily.toFamily` — the derived `ExpanderFamily` +-/ + +@[expose] public section + +namespace Complexity + +/-- A family of constant-degree expanders on the squares `m * m`. -/ +structure SquareFamily where + /-- The constant degree. -/ + degree : ℕ + /-- The degree is positive. -/ + degree_pos : 0 < degree + /-- The rotation map on `m * m` vertices. -/ + rot : ∀ m : ℕ, Fin (m * m) × Fin degree → Fin (m * m) × Fin degree + /-- Each rotation map is an involution. -/ + rot_involutive : ∀ m, Function.Involutive (rot m) + /-- The uniform contraction factor. -/ + lam : ℝ + /-- The factor is nonnegative. -/ + lam_nonneg : 0 ≤ lam + /-- The factor is below one. -/ + lam_lt_one : lam < 1 + /-- Every member contracts mean-zero functions by `lam`. -/ + spectral : ∀ m : ℕ, + (RegGraph.ofRot degree degree_pos (m * m) (rot m) (rot_involutive m)).SpectralBound lam + +/-! ### A square between `2n` and `3n` -/ + +/-- For `n ≥ 10`, `(⌊√(2n)⌋ + 1)²` lies in `[2n, 3n]`. -/ +theorem sq_between (n : ℕ) (hn : 10 ≤ n) : + 2 * n ≤ (Nat.sqrt (2 * n) + 1) * (Nat.sqrt (2 * n) + 1) + ∧ (Nat.sqrt (2 * n) + 1) * (Nat.sqrt (2 * n) + 1) ≤ 3 * n := by + set s := Nat.sqrt (2 * n) with hs + have h1 : 2 * n < (s + 1) * (s + 1) := Nat.lt_succ_sqrt (2 * n) + have h2 : s * s ≤ 2 * n := Nat.sqrt_le (2 * n) + refine ⟨h1.le, ?_⟩ + -- `2 s + 1 ≤ n` since otherwise `n² ≤ 4 s² ≤ 8 n` + have h3 : 2 * s + 1 ≤ n := by + by_contra hcon + push Not at hcon + have : n ≤ 2 * s := by omega + nlinarith + nlinarith + +/-! ### The empty graph -/ + +/-- The empty graph satisfies every bound. -/ +theorem spectralBound_zero (D : ℕ) (hD : 0 < D) (lam : ℝ) : + (RegGraph.ofRot D hD 0 id (fun _ => rfl)).SpectralBound lam := by + intro f _ + show (∑ v : Fin 0, ((RegGraph.ofRot D hD 0 id (fun _ => rfl)).step f v) ^ 2) + ≤ lam ^ 2 * ∑ v : Fin 0, (f v) ^ 2 + simp + +namespace SquareFamily + +variable (S : SquareFamily) + +/-! ### Powering the squares -/ + +theorem exists_pow_le_half : ∃ t : ℕ, S.lam ^ t ≤ 1 / 2 := by + obtain ⟨t, ht⟩ := exists_pow_lt_of_lt_one (by norm_num : (0 : ℝ) < 1 / 2) S.lam_lt_one + exact ⟨t, ht.le⟩ + +/-- The powering exponent: enough to bring the bound below one half. -/ +noncomputable def powExp : ℕ := Classical.choose S.exists_pow_le_half + +theorem pow_le_half : S.lam ^ S.powExp ≤ 1 / 2 := Classical.choose_spec S.exists_pow_le_half + +theorem pow_nonneg' : 0 ≤ S.lam ^ S.powExp := pow_nonneg S.lam_nonneg _ + +/-- The degree after powering. -/ +noncomputable def powDeg : ℕ := S.degree ^ S.powExp + +theorem powDeg_pos : 0 < S.powDeg := pow_pos S.degree_pos _ + +/-- Walk labels as a `Fin`. -/ +noncomputable def dartEquiv : (Fin S.powExp → Fin S.degree) ≃ Fin S.powDeg := + Fintype.equivFinOfCardEq (by rw [Fintype.card_fun, Fintype.card_fin, Fintype.card_fin]; rfl) + +/-- The powered square graph, with `Fin` darts. -/ +noncomputable def square (m : ℕ) : RegGraph := + ((RegGraph.ofRot S.degree S.degree_pos (m * m) (S.rot m) (S.rot_involutive m)).power + S.powExp).relabel S.dartEquiv + +theorem spectral_square (m : ℕ) : (S.square m).SpectralBound (S.lam ^ S.powExp) := + RegGraph.spectralBound_relabel _ _ (RegGraph.spectralBound_power _ (S.spectral m) _) + +/-- The powered square as rotation data. -/ +noncomputable def squareRot (m : ℕ) : Fin (m * m) × Fin S.powDeg → Fin (m * m) × Fin S.powDeg := + (S.square m).rot + +theorem squareRot_involutive (m : ℕ) : Function.Involutive (S.squareRot m) := + (S.square m).rot_involutive + +theorem spectral_squareRot (m : ℕ) : + (RegGraph.ofRot S.powDeg S.powDeg_pos (m * m) (S.squareRot m) + (S.squareRot_involutive m)).SpectralBound (S.lam ^ S.powExp) := + S.spectral_square m + +/-! ### The common degree -/ + +/-- The degree of the derived family. -/ +noncomputable def famDeg : ℕ := 3 * S.powDeg + 10 + +theorem famDeg_pos : 0 < S.famDeg := by rw [famDeg]; omega + +/-! ### Large `n`: merge -/ + +/-- The side of the square used for `n`. -/ +def mVal (n : ℕ) : ℕ := Nat.sqrt (2 * n) + 1 + +theorem mVal_spec {n : ℕ} (hn : 10 ≤ n) : + 2 * n ≤ mVal n * mVal n ∧ mVal n * mVal n ≤ 3 * n := sq_between n hn + +/-- The graph on `n ≥ 10` vertices: the merge of a powered square, padded to the +common degree. -/ +noncomputable def bigGraph (n : ℕ) (hn : 10 ≤ n) : RegGraph := + (((RegGraph.merged (N := mVal n * mVal n) (d := S.powDeg) (by omega) S.powDeg_pos + (mVal_spec hn).2 (S.squareRot (mVal n)) (S.squareRot_involutive (mVal n))).relabel + (finProdFinEquiv : Fin 3 × Fin S.powDeg ≃ Fin (3 * S.powDeg))).padLoops 10).relabel + (finSumFinEquiv : Fin (3 * S.powDeg) ⊕ Fin 10 ≃ Fin (3 * S.powDeg + 10)) + +/-- The bound for the large case. -/ +noncomputable def bigLam : ℝ := + Real.sqrt ((3 * (S.powDeg : ℝ) * (17 / 24) + 10) / (3 * (S.powDeg : ℝ) + 10)) + +theorem bigLam_lt_one : S.bigLam < 1 := by + rw [bigLam, Real.sqrt_lt' one_pos, one_pow, div_lt_one (by positivity)] + have : (0 : ℝ) < S.powDeg := by exact_mod_cast S.powDeg_pos + nlinarith + +theorem bigLam_nonneg : 0 ≤ S.bigLam := Real.sqrt_nonneg _ + +theorem spectral_bigGraph (n : ℕ) (hn : 10 ≤ n) : (S.bigGraph n hn).SpectralBound S.bigLam := by + have hl := S.pow_le_half + have hl0 := S.pow_nonneg' + have hl2 : (S.lam ^ S.powExp) ^ 2 ≤ 1 := by nlinarith + have hmerged := RegGraph.spectralBound_merged (N := mVal n * mVal n) (d := S.powDeg) + (by omega : 0 < n) S.powDeg_pos (mVal_spec hn).2 (S.squareRot (mVal n)) + (S.squareRot_involutive (mVal n)) hl2 (S.spectral_squareRot (mVal n)) (mVal_spec hn).1 + have hrel := RegGraph.spectralBound_relabel _ + (finProdFinEquiv : Fin 3 × Fin S.powDeg ≃ Fin (3 * S.powDeg)) hmerged + have hpad := RegGraph.spectralBound_padLoops _ 10 hrel + have hrel2 := RegGraph.spectralBound_relabel _ + (finSumFinEquiv : Fin (3 * S.powDeg) ⊕ Fin 10 ≃ Fin (3 * S.powDeg + 10)) hpad + refine hrel2.mono (Real.sqrt_nonneg _) ?_ + rw [bigLam] + apply Real.sqrt_le_sqrt + rw [RegGraph.deg_relabel, RegGraph.deg_merged] + push_cast + rw [Real.sq_sqrt (by positivity)] + have hD : (0 : ℝ) < 3 * (S.powDeg : ℝ) + 10 := by positivity + rw [div_le_div_iff_of_pos_right hD] + have hmu : 1 / 2 + 5 * (S.lam ^ S.powExp) ^ 2 / 6 ≤ 17 / 24 := by nlinarith + have : (0 : ℝ) ≤ 3 * (S.powDeg : ℝ) := by positivity + nlinarith + +/-! ### Small `n`: cliques -/ + +/-- The graph on `0 < n < 10` vertices: a clique with loops, padded. -/ +noncomputable def smallGraph (n : ℕ) (hn : 0 < n) (hle : n ≤ S.famDeg) : RegGraph := + ((RegGraph.cliqueLoops n hn).padLoops (S.famDeg - n)).relabel + ((finSumFinEquiv : Fin n ⊕ Fin (S.famDeg - n) ≃ Fin (n + (S.famDeg - n))).trans + (finCongr (Nat.add_sub_cancel' hle) : Fin (n + (S.famDeg - n)) ≃ Fin S.famDeg)) + +/-- The bound for the small case. -/ +noncomputable def smallLam : ℝ := Real.sqrt (((S.famDeg : ℝ) - 1) / S.famDeg) + +theorem smallLam_lt_one : S.smallLam < 1 := by + have : (0 : ℝ) < S.famDeg := by exact_mod_cast S.famDeg_pos + rw [smallLam, Real.sqrt_lt' one_pos, one_pow, div_lt_one this] + linarith + +theorem smallLam_nonneg : 0 ≤ S.smallLam := Real.sqrt_nonneg _ + +theorem deg_cliqueLoops (n : ℕ) (hn : 0 < n) : (RegGraph.cliqueLoops n hn).deg = n := + Fintype.card_fin n + +theorem spectral_smallGraph (n : ℕ) (hn : 0 < n) (hle : n ≤ S.famDeg) : + (S.smallGraph n hn hle).SpectralBound S.smallLam := by + have hpad := RegGraph.spectralBound_padLoops _ (S.famDeg - n) + (RegGraph.spectralBound_cliqueLoops hn) + have hrel := RegGraph.spectralBound_relabel _ + ((finSumFinEquiv : Fin n ⊕ Fin (S.famDeg - n) ≃ Fin (n + (S.famDeg - n))).trans + (finCongr (Nat.add_sub_cancel' hle) : Fin (n + (S.famDeg - n)) ≃ Fin S.famDeg)) hpad + refine hrel.mono (Real.sqrt_nonneg _) ?_ + rw [smallLam] + apply Real.sqrt_le_sqrt + rw [deg_cliqueLoops] + have hcast : ((S.famDeg - n : ℕ) : ℝ) = (S.famDeg : ℝ) - n := by + rw [Nat.cast_sub hle] + rw [hcast] + have hn' : (1 : ℝ) ≤ n := by exact_mod_cast hn + have hD : (0 : ℝ) < S.famDeg := by exact_mod_cast S.famDeg_pos + have hsum : (n : ℝ) + ((S.famDeg : ℝ) - n) = S.famDeg := by ring + rw [hsum, div_le_div_iff_of_pos_right hD] + nlinarith + +/-! ### The family -/ + +theorem le_famDeg {n : ℕ} (h : ¬ 10 ≤ n) : n ≤ S.famDeg := by rw [famDeg]; omega + +/-- The rotation map on `n` vertices, by cases. -/ +noncomputable def famRot (n : ℕ) : Fin n × Fin S.famDeg → Fin n × Fin S.famDeg := + if h : 10 ≤ n then (S.bigGraph n h).rot + else if h0 : 0 < n then (S.smallGraph n h0 (S.le_famDeg h)).rot + else id + +theorem famRot_involutive (n : ℕ) : Function.Involutive (S.famRot n) := by + intro x + unfold famRot + split_ifs with h h0 + · exact (S.bigGraph n h).rot_involutive x + · exact (S.smallGraph n h0 _).rot_involutive x + · rfl + +/-- The uniform bound. -/ +noncomputable def famLam : ℝ := max S.bigLam S.smallLam + +theorem famLam_nonneg : 0 ≤ S.famLam := le_max_of_le_left S.bigLam_nonneg + +theorem famLam_lt_one : S.famLam < 1 := max_lt S.bigLam_lt_one S.smallLam_lt_one + +theorem spectral_fam (n : ℕ) : + (RegGraph.ofRot S.famDeg S.famDeg_pos n (S.famRot n) (S.famRot_involutive n)).SpectralBound + S.famLam := by + by_cases h : 10 ≤ n + · have hb := S.spectral_bigGraph n h + have heq : RegGraph.ofRot S.famDeg S.famDeg_pos n (S.famRot n) (S.famRot_involutive n) + = S.bigGraph n h := by + unfold famRot + simp only [dif_pos h] + rfl + rw [heq] + exact hb.mono S.bigLam_nonneg (le_max_left _ _) + · by_cases h0 : 0 < n + · have hs := S.spectral_smallGraph n h0 (S.le_famDeg h) + have heq : RegGraph.ofRot S.famDeg S.famDeg_pos n (S.famRot n) (S.famRot_involutive n) + = S.smallGraph n h0 (S.le_famDeg h) := by + unfold famRot + simp only [dif_neg h, dif_pos h0] + rfl + rw [heq] + exact hs.mono S.smallLam_nonneg (le_max_right _ _) + · have hz : n = 0 := by omega + subst hz + exact spectralBound_zero _ _ _ + +/-- **The derived expander family.** -/ +noncomputable def toFamily : ExpanderFamily where + degree := S.famDeg + degree_pos := S.famDeg_pos + rot := S.famRot + rot_involutive := S.famRot_involutive + lam := S.famLam + lam_nonneg := S.famLam_nonneg + lam_lt_one := S.famLam_lt_one + spectral := S.spectral_fam + +end SquareFamily + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderExists.lean b/Complexitylib/Classes/PCP/Internal/ExpanderExists.lean new file mode 100644 index 00000000..01f79936 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ExpanderExists.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ExpanderRandom +public import Complexitylib.Classes.PCP.Internal.PermGraph +public import Complexitylib.Classes.PCP.Internal.Cheeger +public import Complexitylib.Classes.PCP.Internal.Expander + +/-! +# An expander family exists + +The three strands meet here. `ExpanderRandom` produces, for every `n`, thirty +permutations of `Fin n` no vertex set of at most half the vertices survives; +`PermGraph` turns those into a `60`-regular graph with edge expansion `1/600`; +and `Cheeger` converts edge expansion into a spectral gap once enough self-loops +are added to make the walk lazy. Relabelling the resulting `120` darts as +`Fin 120` puts the graph in the rotation-map form `ExpanderFamily` asks for. + +The construction is not explicit — the permutations come from +`Classical.choose` on a counting argument — which is all the mathematics of +Dinur's proof needs. An explicit family would be needed only to make the +reduction itself polynomial-time computable. + +## Main definitions + +- `Complexity.goodPerms` — the chosen permutations +- `Complexity.randExpander` — the resulting `ExpanderFamily` +-/ + +@[expose] public section + +namespace Complexity + +/-- Thirty permutations of `Fin n` that expand every small set. -/ +noncomputable def goodPerms (n : ℕ) : Fin 30 → Equiv.Perm (Fin n) := + Classical.choose (exists_good_perms n) + +theorem goodPerms_spec (n : ℕ) (S : Finset (Fin n)) (hS : 2 * S.card ≤ n) : + ∃ i, S.card ≤ 10 * escape (goodPerms n i) S := by + rcases S.eq_empty_or_nonempty with rfl | hne + · exact ⟨⟨0, by norm_num⟩, by simp⟩ + · exact Classical.choose_spec (exists_good_perms n) S hS hne + +/-- The `60`-regular graph of those permutations. -/ +noncomputable def baseGraph (n : ℕ) : RegGraph := + RegGraph.permsGraph (by norm_num : (0 : ℕ) < 30) (goodPerms n) + +theorem edgeExpansion_baseGraph (n : ℕ) : + (baseGraph n).EdgeExpansion (1 / (2 * (10 : ℝ) * 30)) := + RegGraph.edgeExpansion_permsGraph _ _ 10 (by norm_num) (goodPerms_spec n) + +theorem deg_baseGraph (n : ℕ) : (baseGraph n).deg = 60 := by + rw [baseGraph, RegGraph.deg_permsGraph] + +/-- The lazy walk on it: a self-loop for every dart. -/ +noncomputable def lazyGraph (n : ℕ) : RegGraph := (baseGraph n).padLoops (baseGraph n).deg + +/-- The spectral bound the construction achieves. -/ +noncomputable def randLam : ℝ := 1 - (1 / (2 * (10 : ℝ) * 30)) ^ 2 / 4 + +theorem randLam_nonneg : 0 ≤ randLam := by + rw [randLam] + norm_num + +theorem randLam_lt_one : randLam < 1 := by + rw [randLam] + norm_num + +theorem spectral_lazyGraph (n : ℕ) : (lazyGraph n).SpectralBound randLam := + RegGraph.spectralBound_padLoops_of_edgeExpansion _ (edgeExpansion_baseGraph n) (by norm_num) + +theorem deg_lazyGraph (n : ℕ) : (lazyGraph n).deg = 120 := by + rw [lazyGraph, RegGraph.deg_padLoops, deg_baseGraph] + +theorem card_lazyDarts (n : ℕ) : Fintype.card (lazyGraph n).D = 120 := deg_lazyGraph n + +/-- The darts of the lazy graph, named by `Fin 120`. -/ +noncomputable def dartEquiv (n : ℕ) : (lazyGraph n).D ≃ Fin 120 := + Fintype.equivFinOfCardEq (card_lazyDarts n) + +/-- The graph on `n` vertices with `Fin 120` darts. -/ +noncomputable def randGraph (n : ℕ) : RegGraph := (lazyGraph n).relabel (dartEquiv n) + +theorem spectral_randGraph (n : ℕ) : (randGraph n).SpectralBound randLam := + RegGraph.spectralBound_relabel _ _ (spectral_lazyGraph n) + +/-- Its rotation map, as data on `Fin n × Fin 120`. -/ +noncomputable def randRot (n : ℕ) : Fin n × Fin 120 → Fin n × Fin 120 := (randGraph n).rot + +theorem randRot_involutive (n : ℕ) : Function.Involutive (randRot n) := + (randGraph n).rot_involutive + +theorem ofRot_randRot (n : ℕ) : + RegGraph.ofRot 120 (by norm_num) n (randRot n) (randRot_involutive n) = randGraph n := rfl + +/-- **An expander family.** -/ +noncomputable def randExpander : ExpanderFamily where + degree := 120 + degree_pos := by norm_num + rot := randRot + rot_involutive := randRot_involutive + lam := randLam + lam_nonneg := randLam_nonneg + lam_lt_one := randLam_lt_one + spectral := fun n => by + rw [ofRot_randRot] + exact spectral_randGraph n + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean b/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean new file mode 100644 index 00000000..6b6640ba --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean @@ -0,0 +1,470 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Expander +public import Complexitylib.Classes.PCP.Internal.Mixing +public import Mathlib.Algebra.Order.Chebyshev +public import Mathlib.Data.Real.Sqrt + +/-! +# Expanders on every vertex count, by merging + +Explicit expander constructions come in special sizes — squares, powers — but +`ExpanderFamily` wants a member on *every* `n`. This module closes the gap: an +expander on `N` vertices with `2n ≤ N ≤ 3n` is folded onto `n` vertices by +identifying `u` with `u mod n`. Every new vertex absorbs two or three old ones, +so the degree triples, with self-loops padding the vertices that absorbed only +two. + +The spectral bound survives, with an explicit loss. Write `f` for a mean-zero +function on the merged graph and `F = f ∘ π` for its lift. The merged step at +`v` is the average of the old steps at the two or three vertices over `v`, +together with `f v` itself for each padding loop, so by Jensen its square is at +most the average of their squares. Summing, the old steps contribute at most +`λ² ‖F‖² + (1 - λ²) N c²` where `c` is the mean of `F` — nonzero, because the +heavier fibres weigh more — and `N c²` is at most half of `‖f‖²` because the +heavy fibres number fewer than `n ≤ N / 2`. The padding loops contribute at +most `‖f‖²`. Altogether the new factor is `μ² = 1/2 + 5λ²/6`, below one as soon +as `λ² < 3/5`, which powering the base graph guarantees. + +## Main definitions + +- `Complexity.RegGraph.mergeRot` — the merged rotation map +- `Complexity.RegGraph.merged` — the merged graph + +## Main results + +- `Complexity.RegGraph.spectralBound_merged` — the spectral bound of the merge +- `Complexity.liftN`, `Complexity.card_liftN_none_le_one` — the balanced fibres + a general merge needs +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable {N d n : ℕ} + +/-! ### The merged rotation map -/ + +/-- The old vertex numbered `i` in the fibre over `v`, if it exists. -/ +def lift (N n : ℕ) (v : Fin n) (i : Fin 3) : Option (Fin N) := + if h : v.val + i.val * n < N then some ⟨v.val + i.val * n, h⟩ else none + +/-- The new vertex an old vertex lands on. -/ +def proj (n : ℕ) (hn : 0 < n) (u : Fin N) : Fin n := ⟨u.val % n, Nat.mod_lt _ hn⟩ + +/-- The position of an old vertex in its fibre; below three when `N ≤ 3 n`. -/ +def slot (n : ℕ) (hN : N ≤ 3 * n) (u : Fin N) : Fin 3 := + ⟨u.val / n, by + rcases Nat.eq_zero_or_pos n with h0 | h0 + · subst h0; omega + · have := u.isLt + rw [Nat.div_lt_iff_lt_mul h0] + omega⟩ + +theorem lift_proj_slot (hn : 0 < n) (hN : N ≤ 3 * n) (u : Fin N) : + lift N n (proj n hn u) (slot n hN u) = some u := by + simp only [lift, proj, slot] + have h : u.val % n + u.val / n * n = u.val := by + rw [mul_comm]; exact Nat.mod_add_div u.val n + rw [dif_pos (by rw [h]; exact u.isLt)] + congr 1 + exact Fin.ext h + +theorem proj_lift (hn : 0 < n) (v : Fin n) (i : Fin 3) (u : Fin N) + (h : lift N n v i = some u) : proj n hn u = v := by + simp only [lift] at h + split_ifs at h with hlt + · simp only [Option.some.injEq] at h + rw [← h] + simp only [proj] + apply Fin.ext + show (v.val + i.val * n) % n = v.val + rw [Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt v.isLt] + +theorem slot_lift (hN : N ≤ 3 * n) (v : Fin n) (i : Fin 3) (u : Fin N) + (h : lift N n v i = some u) : slot n hN u = i := by + simp only [lift] at h + split_ifs at h with hlt + · simp only [Option.some.injEq] at h + rw [← h] + apply Fin.ext + show (v.val + i.val * n) / n = i.val + have hn : 0 < n := by omega + rw [Nat.add_mul_div_right _ _ hn, Nat.div_eq_of_lt v.isLt, zero_add] + +/-- The merged rotation map: a real dart follows the old rotation and is +re-addressed; a padding dart is a self-loop. -/ +def mergeRot (hn : 0 < n) (hN : N ≤ 3 * n) (rot : Fin N × Fin d → Fin N × Fin d) + (x : Fin n × (Fin 3 × Fin d)) : Fin n × (Fin 3 × Fin d) := + match lift N n x.1 x.2.1 with + | some u => + let y := rot (u, x.2.2) + (proj n hn y.1, (slot n hN y.1, y.2)) + | none => x + +theorem mergeRot_involutive (hn : 0 < n) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : + Function.Involutive (mergeRot hn hN rot) := by + intro x + obtain ⟨v, i, s⟩ := x + simp only [mergeRot] + cases hl : lift N n v i with + | none => simp [hl] + | some u => + simp only + rw [lift_proj_slot hn hN] + simp only + rcases hrs : rot (u, s) with ⟨u', s'⟩ + have hy : rot (u', s') = (u, s) := by rw [← hrs]; exact hrot (u, s) + simp only [hy, Prod.mk.injEq] + exact ⟨proj_lift hn v i u hl, slot_lift hN v i u hl, trivial⟩ + +/-- **The merged graph**: `n` vertices of degree `3 d`. -/ +def merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : RegGraph where + V := Fin n + D := Fin 3 × Fin d + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨(0, ⟨0, hd⟩)⟩ + rot := mergeRot hn hN rot + rot_involutive := mergeRot_involutive hn hN rot hrot + +/-! ### The spectral bound -/ + +section Spectral + +/-- The base graph, on `Fin N`. -/ +abbrev base (hd : 0 < d) (rot : Fin N × Fin d → Fin N × Fin d) + (hrot : Function.Involutive rot) : RegGraph := ofRot d hd N rot hrot + +/-- A term of the merged step at `v`: the old step at the `i`-th vertex over +`v`, or `f v` for a padding loop. -/ +noncomputable def term (hn : 0 < n) (hd : 0 < d) (rot : Fin N × Fin d → Fin N × Fin d) + (hrot : Function.Involutive rot) (f : Fin n → ℝ) (v : Fin n) (i : Fin 3) : ℝ := + match lift N n v i with + | some u => (base hd rot hrot).step (fun w => f (proj n hn w)) u + | none => f v + +theorem deg_merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : + (merged hn hd hN rot hrot).deg = 3 * d := by + show Fintype.card (Fin 3 × Fin d) = 3 * d + rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] + +/-- **The merged step is the average of its terms.** -/ +theorem step_merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + (f : Fin n → ℝ) (v : Fin n) : + (merged hn hd hN rot hrot).step f v = (∑ i : Fin 3, term hn hd rot hrot f v i) / 3 := by + have hd' : (d : ℝ) ≠ 0 := by exact_mod_cast hd.ne' + rw [step, deg_merged] + show (∑ x : Fin 3 × Fin d, f (mergeRot hn hN rot (v, x)).1) / ((3 * d : ℕ) : ℝ) = _ + rw [Fintype.sum_prod_type] + have hinner : ∀ i : Fin 3, ∑ s : Fin d, f (mergeRot hn hN rot (v, (i, s))).1 + = d * term hn hd rot hrot f v i := by + intro i + simp only [mergeRot, term] + cases hl : lift N n v i with + | none => + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + | some u => + simp only + rw [step, deg_ofRot] + show _ = (d : ℝ) * ((∑ i : Fin d, f (proj n hn (rot (u, i)).1)) / (d : ℝ)) + field_simp + rw [Finset.sum_congr rfl fun i _ => hinner i, ← Finset.mul_sum] + push_cast + field_simp + +/-- **Jensen**: the square of the average is at most the average of the squares. -/ +theorem sq_step_merged_le (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + (f : Fin n → ℝ) (v : Fin n) : + ((merged hn hd hN rot hrot).step f v) ^ 2 + ≤ (∑ i : Fin 3, (term hn hd rot hrot f v i) ^ 2) / 3 := by + rw [step_merged, div_pow] + have h := sq_sum_le_card_mul_sum_sq (s := (Finset.univ : Finset (Fin 3))) + (f := term hn hd rot hrot f v) + rw [Finset.card_univ, Fintype.card_fin] at h + have h3 : (0 : ℝ) < 3 ^ 2 := by norm_num + rw [div_le_div_iff₀ h3 (by norm_num)] + push_cast at h + nlinarith [h] + +/-- The pairs `(v, i)` naming an old vertex, as the image of the old vertices. -/ +theorem sum_over_lift (hn : 0 < n) (hN : N ≤ 3 * n) (g : Fin N → ℝ) : + ∑ p : Fin n × Fin 3, (match lift N n p.1 p.2 with | some u => g u | none => 0) + = ∑ u : Fin N, g u := by + classical + have hinj : Function.Injective fun u : Fin N => (proj n hn u, slot n hN u) := by + intro u u' h + have h1 := lift_proj_slot hn hN u + have h2 := lift_proj_slot hn hN u' + simp only [Prod.mk.injEq] at h + rw [h.1, h.2, h2] at h1 + exact (Option.some.inj h1).symm + symm + calc ∑ u : Fin N, g u + = ∑ u : Fin N, (match lift N n (proj n hn u) (slot n hN u) with + | some u' => g u' | none => 0) := by + refine Finset.sum_congr rfl fun u _ => ?_ + rw [lift_proj_slot hn hN] + _ = ∑ p ∈ Finset.univ.image (fun u : Fin N => (proj n hn u, slot n hN u)), + (match lift N n p.1 p.2 with | some u' => g u' | none => 0) := by + rw [Finset.sum_image (fun u _ u' _ h => hinj h)] + _ = ∑ p : Fin n × Fin 3, (match lift N n p.1 p.2 with | some u' => g u' | none => 0) := by + refine Finset.sum_subset (Finset.subset_univ _) fun p _ hp => ?_ + cases hl : lift N n p.1 p.2 with + | none => rfl + | some u => + exfalso + apply hp + rw [Finset.mem_image] + refine ⟨u, Finset.mem_univ _, ?_⟩ + rw [proj_lift hn _ _ u hl, slot_lift hN _ _ u hl] + +theorem lift_zero (h2 : 2 * n ≤ N) (v : Fin n) : lift N n v 0 = some ⟨v.val, by omega⟩ := by + simp only [lift, Fin.val_zero, zero_mul, add_zero] + rw [dif_pos (by omega)] + +theorem lift_one (h2 : 2 * n ≤ N) (v : Fin n) : + lift N n v 1 = some ⟨v.val + n, by omega⟩ := by + simp only [lift, Fin.val_one, one_mul] + rw [dif_pos (by omega)] + +/-- **Splitting the terms**: the old steps, plus at most one padding loop per +vertex. -/ +theorem sum_sq_term_le (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + (h2 : 2 * n ≤ N) (f : Fin n → ℝ) : + ∑ v : Fin n, ∑ i : Fin 3, (term hn hd rot hrot f v i) ^ 2 + ≤ (∑ u : Fin N, ((base hd rot hrot).step (fun w => f (proj n hn w)) u) ^ 2) + + ∑ v : Fin n, (f v) ^ 2 := by + classical + have hsplit : ∀ v i, (term hn hd rot hrot f v i) ^ 2 + = (match lift N n v i with + | some u => ((base hd rot hrot).step (fun w => f (proj n hn w)) u) ^ 2 + | none => 0) + + (match lift N n v i with | some _ => 0 | none => (f v) ^ 2) := by + intro v i + simp only [term] + cases lift N n v i <;> simp + simp_rw [hsplit, Finset.sum_add_distrib] + rw [← Fintype.sum_prod_type', sum_over_lift hn hN] + refine add_le_add le_rfl (Finset.sum_le_sum fun v _ => ?_) + rw [Fin.sum_univ_three, lift_zero h2, lift_one h2] + simp only [zero_add] + cases lift N n v 2 with + | some _ => show (0 : ℝ) ≤ f v ^ 2; exact sq_nonneg _ + | none => show f v ^ 2 ≤ f v ^ 2; exact le_rfl + +/-- **The lift's squares**: each `f v` is counted at most three times. -/ +theorem sum_sq_lift_le (hn : 0 < n) (hN : N ≤ 3 * n) (f : Fin n → ℝ) : + ∑ u : Fin N, (f (proj n hn u)) ^ 2 ≤ 3 * ∑ v : Fin n, (f v) ^ 2 := by + classical + have h := sum_over_lift hn hN (fun u => (f (proj n hn u)) ^ 2) + rw [← h, Fintype.sum_prod_type] + rw [Finset.mul_sum] + refine Finset.sum_le_sum fun v _ => ?_ + have : ∀ i : Fin 3, (match lift N n v i with | some u => (f (proj n hn u)) ^ 2 | none => 0) + ≤ (f v) ^ 2 := by + intro i + cases hl : lift N n v i with + | none => show (0 : ℝ) ≤ f v ^ 2; exact sq_nonneg _ + | some u => simp only; rw [proj_lift hn v i u hl] + calc ∑ i : Fin 3, (match lift N n v i with | some u => (f (proj n hn u)) ^ 2 | none => 0) + ≤ ∑ _i : Fin 3, (f v) ^ 2 := Finset.sum_le_sum fun i _ => this i + _ = 3 * (f v) ^ 2 := by simp + +/-- **The lift's sum** is the sum over the heavy fibres, when `f` has mean zero. -/ +theorem sum_lift_eq (hn : 0 < n) (hN : N ≤ 3 * n) (h2 : 2 * n ≤ N) (f : Fin n → ℝ) + (hf : ∑ v, f v = 0) : + ∑ u : Fin N, f (proj n hn u) + = ∑ v : Fin n, (match lift N n v 2 with | some _ => f v | none => 0) := by + classical + have h := sum_over_lift hn hN (fun u => f (proj n hn u)) + rw [← h, Fintype.sum_prod_type] + have hv : ∀ v : Fin n, ∑ i : Fin 3, + (match lift N n v i with | some u => f (proj n hn u) | none => 0) + = 2 * f v + (match lift N n v 2 with | some _ => f v | none => 0) := by + intro v + rw [Fin.sum_univ_three, lift_zero h2, lift_one h2] + simp only + rw [proj_lift hn v 0 _ (lift_zero h2 v), proj_lift hn v 1 _ (lift_one h2 v)] + cases hl : lift N n v 2 with + | none => simp; ring + | some u => simp only; rw [proj_lift hn v 2 u hl]; ring + rw [Finset.sum_congr rfl fun v _ => hv v, Finset.sum_add_distrib, ← Finset.mul_sum, hf] + ring + +/-- **The mean of the lift is small**: `N c² ≤ ‖f‖² / 2`. -/ +theorem sq_sum_lift_le (hn : 0 < n) (hN : N ≤ 3 * n) (h2 : 2 * n ≤ N) (f : Fin n → ℝ) + (hf : ∑ v, f v = 0) : + (∑ u : Fin N, f (proj n hn u)) ^ 2 ≤ (n : ℝ) * ∑ v : Fin n, (f v) ^ 2 := by + classical + rw [sum_lift_eq hn hN h2 f hf] + set H : Finset (Fin n) := Finset.univ.filter fun v => (lift N n v 2).isSome with hH + have hsum : ∑ v : Fin n, (match lift N n v 2 with | some _ => f v | none => 0) + = ∑ v ∈ H, f v := by + rw [hH, Finset.sum_filter] + refine Finset.sum_congr rfl fun v _ => ?_ + cases lift N n v 2 <;> simp + rw [hsum] + have hcs := sq_sum_le_card_mul_sum_sq (s := H) (f := f) + have hcard : (H.card : ℝ) ≤ n := by + have : H.card ≤ Fintype.card (Fin n) := Finset.card_le_univ H + rw [Fintype.card_fin] at this + exact_mod_cast this + have hsub : ∑ v ∈ H, (f v) ^ 2 ≤ ∑ v : Fin n, (f v) ^ 2 := + Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) fun v _ _ => sq_nonneg _ + have h0 : 0 ≤ ∑ v ∈ H, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + calc (∑ v ∈ H, f v) ^ 2 ≤ H.card * ∑ v ∈ H, (f v) ^ 2 := hcs + _ ≤ n * ∑ v : Fin n, (f v) ^ 2 := by + exact mul_le_mul hcard hsub h0 (by positivity) + +/-- **The old steps of the lift**, with the mean corrected. -/ +theorem sum_sq_step_lift_le (hn : 0 < n) (hd : 0 < d) (rot : Fin N × Fin d → Fin N × Fin d) + (hrot : Function.Involutive rot) {lam : ℝ} (hspec : (base hd rot hrot).SpectralBound lam) + (hN0 : 0 < N) (f : Fin n → ℝ) : + ∑ u : Fin N, ((base hd rot hrot).step (fun w => f (proj n hn w)) u) ^ 2 + ≤ lam ^ 2 * ∑ u : Fin N, (f (proj n hn u)) ^ 2 + + (1 - lam ^ 2) * ((∑ u : Fin N, f (proj n hn u)) ^ 2 / (N : ℝ)) := by + classical + set G := base hd rot hrot with hG + set F : Fin N → ℝ := fun w => f (proj n hn w) with hF + have hord : (G.order : ℝ) = N := by rw [hG, order_ofRot] + have hN' : (0 : ℝ) < N := by exact_mod_cast hN0 + have hordpos : 0 < G.order := by rw [hG, order_ofRot]; exact hN0 + -- decompose `F` into its mean and its centred part + have hdec : F = fun v => G.mean F + G.center F v := G.eq_mean_add_center F + have hstep : ∀ u, G.step F u = G.mean F + G.step (G.center F) u := by + intro u + conv_lhs => rw [hdec] + rw [G.step_add (fun _ => G.mean F) (G.center F) u, step_const] + have hcsum : ∑ u, G.center F u = 0 := G.sum_center hordpos F + have hstepsum : ∑ u, G.step (G.center F) u = 0 := by rw [G.sum_step, hcsum] + have hspec' := hspec (G.center F) hcsum + have hsq : ∑ u, (G.step F u) ^ 2 + = ∑ u, (G.step (G.center F) u) ^ 2 + (N : ℝ) * (G.mean F) ^ 2 := by + rw [Finset.sum_congr rfl fun u _ => by rw [hstep u]] + have : ∀ u, (G.mean F + G.step (G.center F) u) ^ 2 + = (G.step (G.center F) u) ^ 2 + 2 * G.mean F * G.step (G.center F) u + + (G.mean F) ^ 2 := fun u => by ring + have hcardV : Fintype.card (base hd rot hrot).V = N := Fintype.card_fin N + rw [Finset.sum_congr rfl fun u _ => this u, Finset.sum_add_distrib, + Finset.sum_add_distrib, ← Finset.mul_sum, hstepsum, Finset.sum_const, Finset.card_univ, + hcardV, nsmul_eq_mul] + ring + have hFsq := G.sum_sq_center hordpos F + rw [hord] at hFsq + have hmean : (N : ℝ) * (G.mean F) ^ 2 = (∑ u, F u) ^ 2 / (N : ℝ) := by + rw [mean, hord] + field_simp + rfl + show ∑ u, G.step F u ^ 2 ≤ lam ^ 2 * ∑ u, F u ^ 2 + (1 - lam ^ 2) * ((∑ u, F u) ^ 2 / (N : ℝ)) + rw [hsq, hmean] + have hsub : ∑ u, (G.center F u) ^ 2 = ∑ u, (F u) ^ 2 - (∑ u, F u) ^ 2 / (N : ℝ) := hFsq + rw [hsub] at hspec' + have hnn : 0 ≤ (∑ u, F u) ^ 2 / (N : ℝ) := by positivity + nlinarith [hspec', hnn] + +/-- **The spectral bound of the merge.** -/ +theorem spectralBound_merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + {lam : ℝ} (hlam : lam ^ 2 ≤ 1) + (hspec : (base hd rot hrot).SpectralBound lam) (h2 : 2 * n ≤ N) : + (merged hn hd hN rot hrot).SpectralBound (Real.sqrt (1 / 2 + 5 * lam ^ 2 / 6)) := by + intro f hf + have hN0 : 0 < N := by omega + have hN' : (0 : ℝ) < N := by exact_mod_cast hN0 + have hsqrt : Real.sqrt (1 / 2 + 5 * lam ^ 2 / 6) ^ 2 = 1 / 2 + 5 * lam ^ 2 / 6 := + Real.sq_sqrt (by positivity) + rw [hsqrt] + have hf' : ∑ v : Fin n, f v = 0 := hf + have hjensen : ∑ v : Fin n, ((merged hn hd hN rot hrot).step f v) ^ 2 + ≤ (∑ v : Fin n, ∑ i : Fin 3, (term hn hd rot hrot f v i) ^ 2) / 3 := by + rw [Finset.sum_div] + exact Finset.sum_le_sum fun v _ => sq_step_merged_le hn hd hN rot hrot f v + have hterms := sum_sq_term_le hn hd hN rot hrot h2 f + have hold := sum_sq_step_lift_le hn hd rot hrot hspec hN0 f + have hlift := sum_sq_lift_le hn hN f + have hmean := sq_sum_lift_le hn hN h2 f hf' + have hmean' : (∑ u : Fin N, f (proj n hn u)) ^ 2 / (N : ℝ) + ≤ (1 / 2) * ∑ v : Fin n, (f v) ^ 2 := by + rw [div_le_iff₀ hN'] + have h2' : (2 : ℝ) * n ≤ N := by exact_mod_cast h2 + have hS : 0 ≤ ∑ v : Fin n, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + nlinarith [hmean, h2', hS] + have hS : 0 ≤ ∑ v : Fin n, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + have hl0 : 0 ≤ lam ^ 2 := sq_nonneg _ + have hl1 : 0 ≤ 1 - lam ^ 2 := by linarith + show ∑ v : Fin n, ((merged hn hd hN rot hrot).step f v) ^ 2 + ≤ (1 / 2 + 5 * lam ^ 2 / 6) * ∑ v : Fin n, (f v) ^ 2 + have hA := mul_le_mul_of_nonneg_left hlift hl0 + have hB := mul_le_mul_of_nonneg_left hmean' hl1 + nlinarith [hjensen, hterms, hold, hA, hB] + +end Spectral + +/-! ### Balanced fibres, for a merge of any width + +The merge above folds `N ≤ 3 n` vertices onto `n`. To fold the sparse sizes a +zig-zag tower produces, the width has to be arbitrary, and what makes that work +is that the fibres stay *balanced*: with `(m - 1) n ≤ N ≤ m n` every fibre has +`m - 1` or `m` elements, so at most one of the `m` slots is empty and the +padding costs one loop per vertex however large `m` is. + +These are the two facts a general merge rests on; they are stated for a +natural-number slot index, which is the form the general construction needs. -/ + +/-- The old vertex in slot `i` of the fibre over `v`, if there is one. -/ +def liftN (N n : ℕ) (v : Fin n) (i : ℕ) : Option (Fin N) := + if h : v.val + i * n < N then some ⟨v.val + i * n, h⟩ else none + +theorem liftN_eq_lift (N n : ℕ) (v : Fin n) (i : Fin 3) : + liftN N n v i.val = lift N n v i := rfl + +/-- **Every slot but the last is filled**, when `(m - 1) n ≤ N`. -/ +theorem liftN_isSome {N n m : ℕ} (hm : (m - 1) * n ≤ N) (v : Fin n) {i : ℕ} + (hi : i + 1 < m) : (liftN N n v i).isSome := by + rw [liftN] + have hv : v.val < n := v.isLt + have hle : v.val + i * n < (m - 1) * n := by + have h1 : i + 1 ≤ m - 1 := by omega + calc v.val + i * n < n + i * n := by omega + _ = (i + 1) * n := by ring + _ ≤ (m - 1) * n := Nat.mul_le_mul_right _ h1 + rw [dif_pos (lt_of_lt_of_le hle hm)] + rfl + +/-- **So at most one slot is empty.** -/ +theorem card_liftN_none_le_one {N n m : ℕ} (hm : (m - 1) * n ≤ N) (v : Fin n) : + ((Finset.range m).filter fun i => liftN N n v i = none).card ≤ 1 := by + classical + refine Finset.card_le_one.2 fun i hi j hj => ?_ + rw [Finset.mem_filter, Finset.mem_range] at hi hj + by_contra hne + have hlast : ∀ k : ℕ, k < m → liftN N n v k = none → k + 1 = m := by + intro k hk hnone + by_contra hcon + have : k + 1 < m := by omega + have := liftN_isSome hm v this + rw [hnone] at this + exact absurd this (by simp) + have h1 := hlast i hi.1 hi.2 + have h2 := hlast j hj.1 hj.2 + omega + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean b/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean new file mode 100644 index 00000000..742e373b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Expander +public import Complexitylib.Classes.PCP.Internal.Mixing +public import Mathlib.Data.Real.Sqrt + +/-! +# Relabelling darts and padding with loops + +Two bookkeeping operations on regular graphs, both preserving the spectral +bound in an explicit way. + +* **Relabelling** the dart type along an equivalence. Constructions produce + structured dart types — pairs, functions, sums — while `ExpanderFamily` + wants `Fin degree`. The step operator is unchanged, so the bound is. + +* **Padding** with self-loops, to raise the degree of a graph to a prescribed + value. The new step is a convex combination of the old step and the identity, + so by Jensen the bound becomes `μ² = α λ² + (1 - α)` with `α` the fraction of + real darts. + +## Main definitions + +- `Complexity.RegGraph.relabel` — the same graph with darts renamed +- `Complexity.RegGraph.padLoops` — the graph with `k` self-loops added at every + vertex + +## Main results + +- `Complexity.RegGraph.spectralBound_relabel` +- `Complexity.RegGraph.spectralBound_padLoops` +- `Complexity.RegGraph.relabelV`, `Complexity.RegGraph.spectralBound_relabelV` — + renaming vertices +- `Complexity.RegGraph.toFinForm` — the same graph with both types numbered +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Relabelling -/ + +/-- The same graph with its darts renamed along `e`. -/ +def relabel {D' : Type} [DecidableEq D'] [Fintype D'] (e : G.D ≃ D') : RegGraph where + V := G.V + D := D' + decEqV := G.decEqV + decEqD := inferInstance + fintypeV := G.fintypeV + fintypeD := inferInstance + nonemptyD := ⟨e (Classical.arbitrary G.D)⟩ + rot := fun p => ((G.rot (p.1, e.symm p.2)).1, e (G.rot (p.1, e.symm p.2)).2) + rot_involutive := by + intro p + simp only [Equiv.symm_apply_apply] + have h := G.rot_involutive (p.1, e.symm p.2) + rw [show (G.rot (p.1, e.symm p.2)).1 = (G.rot (p.1, e.symm p.2)).1 from rfl] + conv_lhs => rw [show ((G.rot (p.1, e.symm p.2)).1, (G.rot (p.1, e.symm p.2)).2) + = G.rot (p.1, e.symm p.2) from rfl] + rw [h] + simp + +@[simp] theorem order_relabel {D' : Type} [DecidableEq D'] [Fintype D'] (e : G.D ≃ D') : + (G.relabel e).order = G.order := rfl + +theorem deg_relabel {D' : Type} [DecidableEq D'] [Fintype D'] (e : G.D ≃ D') : + (G.relabel e).deg = G.deg := by + show Fintype.card D' = Fintype.card G.D + exact (Fintype.card_congr e).symm + +theorem step_relabel {D' : Type} [DecidableEq D'] [Fintype D'] (e : G.D ≃ D') (f : G.V → ℝ) + (v : G.V) : (G.relabel e).step f v = G.step f v := by + simp only [step, deg_relabel] + congr 1 + show ∑ i : D', f (G.rot (v, e.symm i)).1 = ∑ i : G.D, f (G.rot (v, i)).1 + exact Fintype.sum_equiv e.symm _ _ fun i => rfl + +theorem spectralBound_relabel {D' : Type} [DecidableEq D'] [Fintype D'] (e : G.D ≃ D') + {lam : ℝ} (h : G.SpectralBound lam) : (G.relabel e).SpectralBound lam := by + intro f hf + have := h f hf + simp only [step_relabel] + exact this + +/-! ### Padding with loops -/ + +/-- The graph with `k` self-loops added at every vertex. -/ +def padLoops (k : ℕ) : RegGraph where + V := G.V + D := G.D ⊕ Fin k + decEqV := G.decEqV + decEqD := inferInstance + fintypeV := G.fintypeV + fintypeD := inferInstance + nonemptyD := ⟨Sum.inl (Classical.arbitrary G.D)⟩ + rot := fun p => + match p.2 with + | Sum.inl i => ((G.rot (p.1, i)).1, Sum.inl (G.rot (p.1, i)).2) + | Sum.inr j => (p.1, Sum.inr j) + rot_involutive := by + intro p + obtain ⟨v, i | j⟩ := p + · simp only + have h := G.rot_involutive (v, i) + conv_lhs => rw [show ((G.rot (v, i)).1, (G.rot (v, i)).2) = G.rot (v, i) from rfl] + rw [h] + · rfl + +@[simp] theorem order_padLoops (k : ℕ) : (G.padLoops k).order = G.order := rfl + +theorem deg_padLoops (k : ℕ) : (G.padLoops k).deg = G.deg + k := by + show Fintype.card (G.D ⊕ Fin k) = _ + rw [Fintype.card_sum, Fintype.card_fin] + rfl + +theorem step_padLoops (k : ℕ) (f : G.V → ℝ) (v : G.V) : + (G.padLoops k).step f v + = ((G.deg : ℝ) * G.step f v + (k : ℝ) * f v) / ((G.deg : ℝ) + k) := by + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + rw [step, deg_padLoops] + show (∑ i : G.D ⊕ Fin k, f ((G.padLoops k).nbr v i)) / ((G.deg + k : ℕ) : ℝ) = _ + rw [Fintype.sum_sum_type] + have h1 : ∀ i : G.D, (G.padLoops k).nbr v (Sum.inl i) = G.nbr v i := fun i => rfl + have h2 : ∀ j : Fin k, (G.padLoops k).nbr v (Sum.inr j) = v := fun j => rfl + simp only [h1, h2, Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + push_cast + congr 1 + rw [step, mul_div_cancel₀ _ hd] + +/-- **Padding keeps the bound**, with `μ² = α λ² + (1 - α)` for `α` the fraction of +real darts. -/ +theorem spectralBound_padLoops (k : ℕ) {lam : ℝ} (h : G.SpectralBound lam) : + (G.padLoops k).SpectralBound + (Real.sqrt (((G.deg : ℝ) * lam ^ 2 + k) / ((G.deg : ℝ) + k))) := by + intro f hf + have hspec := h f hf + have hd : (0 : ℝ) < G.deg := by exact_mod_cast G.deg_pos + have hk : (0 : ℝ) ≤ k := by positivity + have hD : (0 : ℝ) < (G.deg : ℝ) + k := by positivity + rw [Real.sq_sqrt (by positivity)] + set a : ℝ := (G.deg : ℝ) / ((G.deg : ℝ) + k) with ha + have ha0 : 0 ≤ a := by positivity + have ha1 : a ≤ 1 := by rw [ha, div_le_one hD]; linarith + have hb : (k : ℝ) / ((G.deg : ℝ) + k) = 1 - a := by + rw [ha]; field_simp; ring + -- Jensen for two terms + have hpt : ∀ v, ((G.padLoops k).step f v) ^ 2 ≤ a * (G.step f v) ^ 2 + (1 - a) * (f v) ^ 2 := by + intro v + rw [step_padLoops] + have hrw : ((G.deg : ℝ) * G.step f v + (k : ℝ) * f v) / ((G.deg : ℝ) + k) + = a * G.step f v + (1 - a) * f v := by + rw [← hb, ha]; field_simp + rw [hrw] + nlinarith [mul_nonneg ha0 (sub_nonneg.2 ha1), sq_nonneg (G.step f v - f v)] + have hsum : ∑ v : G.V, ((G.padLoops k).step f v) ^ 2 + ≤ a * ∑ v : G.V, (G.step f v) ^ 2 + (1 - a) * ∑ v : G.V, (f v) ^ 2 := by + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + exact Finset.sum_le_sum fun v _ => hpt v + have hS : 0 ≤ ∑ v : G.V, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + have hcoef : ((G.deg : ℝ) * lam ^ 2 + k) / ((G.deg : ℝ) + k) = a * lam ^ 2 + (1 - a) := by + rw [← hb, ha]; field_simp + rw [hcoef] + show ∑ v : G.V, ((G.padLoops k).step f v) ^ 2 ≤ (a * lam ^ 2 + (1 - a)) * ∑ v : G.V, (f v) ^ 2 + nlinarith [hsum, mul_le_mul_of_nonneg_left hspec ha0] + +/-! ### Renaming vertices -/ + +/-- The same graph with its vertices renamed along `e`. Constructions produce +structured vertex types — products, sums — while a family wants `Fin n`. -/ +def relabelV {V' : Type} [DecidableEq V'] [Fintype V'] (e : G.V ≃ V') : RegGraph where + V := V' + D := G.D + decEqV := inferInstance + decEqD := G.decEqD + fintypeV := inferInstance + fintypeD := G.fintypeD + nonemptyD := G.nonemptyD + rot := fun p => (e (G.rot (e.symm p.1, p.2)).1, (G.rot (e.symm p.1, p.2)).2) + rot_involutive := by + intro p + obtain ⟨v, i⟩ := p + simp only [Equiv.symm_apply_apply] + have h := G.rot_involutive (e.symm v, i) + conv_lhs => rw [show ((G.rot (e.symm v, i)).1, (G.rot (e.symm v, i)).2) + = G.rot (e.symm v, i) from rfl] + rw [h] + simp + +@[simp] theorem deg_relabelV {V' : Type} [DecidableEq V'] [Fintype V'] (e : G.V ≃ V') : + (G.relabelV e).deg = G.deg := rfl + +theorem order_relabelV {V' : Type} [DecidableEq V'] [Fintype V'] (e : G.V ≃ V') : + (G.relabelV e).order = G.order := (Fintype.card_congr e).symm + +theorem step_relabelV {V' : Type} [DecidableEq V'] [Fintype V'] (e : G.V ≃ V') + (f : V' → ℝ) (v : V') : + (G.relabelV e).step f v = G.step (fun w => f (e w)) (e.symm v) := by + simp only [step, deg_relabelV] + congr 1 + +theorem spectralBound_relabelV {V' : Type} [DecidableEq V'] [Fintype V'] (e : G.V ≃ V') + {lam : ℝ} (h : G.SpectralBound lam) : (G.relabelV e).SpectralBound lam := by + intro f hf + have hf' : ∑ w : G.V, f (e w) = 0 := by + rw [Fintype.sum_equiv e (fun w => f (e w)) f fun w => rfl] + exact hf + have hb := h (fun w => f (e w)) hf' + calc ∑ v : V', ((G.relabelV e).step f v) ^ 2 + = ∑ w : G.V, (G.step (fun w => f (e w)) w) ^ 2 := + (Fintype.sum_equiv e (fun w => (G.step (fun w => f (e w)) w) ^ 2) + (fun v => ((G.relabelV e).step f v) ^ 2) fun w => by + dsimp only + rw [step_relabelV, Equiv.symm_apply_apply]).symm + _ ≤ lam ^ 2 * ∑ w : G.V, (f (e w)) ^ 2 := hb + _ = lam ^ 2 * ∑ v : V', (f v) ^ 2 := by + congr 1 + exact Fintype.sum_equiv e (fun w => (f (e w)) ^ 2) (fun v => (f v) ^ 2) fun w => rfl + +/-! ### Numbering both types -/ + +/-- The same graph with its vertices numbered `Fin order` and its darts +`Fin deg`. Constructions build structured types; the merge and the expander +families want numbered ones. -/ +noncomputable def toFinForm : RegGraph := + (G.relabelV (Fintype.equivFin G.V)).relabel (Fintype.equivFin G.D) + +@[simp] theorem order_toFinForm : G.toFinForm.order = G.order := by + rw [toFinForm, order_relabel, order_relabelV] + +@[simp] theorem deg_toFinForm : G.toFinForm.deg = G.deg := by + rw [toFinForm, deg_relabel, deg_relabelV] + +theorem spectralBound_toFinForm {lam : ℝ} (h : G.SpectralBound lam) : + G.toFinForm.SpectralBound lam := + spectralBound_relabel _ _ (spectralBound_relabelV G (Fintype.equivFin G.V) h) + +/-- The same graph numbered at sizes supplied by the caller, so that the +rotation map has the literal type `Fin N × Fin d → Fin N × Fin d` a numeric +construction expects, with no transport at the use site. -/ +noncomputable def toFinFormOf (N d : ℕ) (hN : Fintype.card G.V = N) + (hd : Fintype.card G.D = d) : RegGraph := + (G.relabelV ((Fintype.equivFin G.V).trans (finCongr hN))).relabel + ((Fintype.equivFin G.D).trans (finCongr hd)) + +theorem toFinFormOf_V (N d : ℕ) (hN : Fintype.card G.V = N) (hd : Fintype.card G.D = d) : + (G.toFinFormOf N d hN hd).V = Fin N := rfl + +theorem toFinFormOf_D (N d : ℕ) (hN : Fintype.card G.V = N) (hd : Fintype.card G.D = d) : + (G.toFinFormOf N d hN hd).D = Fin d := rfl + +@[simp] theorem order_toFinFormOf (N d : ℕ) (hN : Fintype.card G.V = N) + (hd : Fintype.card G.D = d) : (G.toFinFormOf N d hN hd).order = N := Fintype.card_fin N + +@[simp] theorem deg_toFinFormOf (N d : ℕ) (hN : Fintype.card G.V = N) + (hd : Fintype.card G.D = d) : (G.toFinFormOf N d hN hd).deg = d := Fintype.card_fin d + +theorem spectralBound_toFinFormOf (N d : ℕ) (hN : Fintype.card G.V = N) + (hd : Fintype.card G.D = d) {lam : ℝ} (h : G.SpectralBound lam) : + (G.toFinFormOf N d hN hd).SpectralBound lam := + spectralBound_relabel _ _ (spectralBound_relabelV G _ h) + +/-- Its vertices are literally numbered. -/ +theorem toFinForm_V : G.toFinForm.V = Fin (Fintype.card G.V) := rfl + +/-- And so are its darts. -/ +theorem toFinForm_D : G.toFinForm.D = Fin (Fintype.card G.D) := rfl + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean b/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean new file mode 100644 index 00000000..7399ea6f --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PermArith +public import Complexitylib.Classes.PCP.Internal.PermCount + +/-! +# A tuple of permutations that expands + +The counting argument. Of the `(n!)^30` tuples of thirty permutations of +`Fin n`, not all can fail to expand: a tuple fails at a vertex set `S` of at +most half the vertices exactly when every one of its thirty permutations keeps +all but a tenth of `S` inside `S`. `PermCount` bounds how many permutations do +that for a fixed `S`; `PermArith.key_estimate` turns the thirtieth power of that +bound into `(n!)^30 / 2^{|S|}`, with room to spare for the `C(n,s)` sets of each +size; and summing `2^{-s}` over `s ≥ 1` stays below one. + +Everything is done with natural numbers — the geometric series appears as an +induction that carries the slack `+ K` explicitly, so no division is needed. + +## Main definitions + +- `Complexity.escLE` — the permutations keeping all but `t` points of `S` in `S` +- `Complexity.tOf` — the escape a set of a given size is allowed + +## Main results + +- `Complexity.exists_good_perms` — a tuple of thirty permutations for which + every set of at most half the vertices is moved out of itself, by at least a + tenth of it, by one of them +-/ + +@[expose] public section + +namespace Complexity + +open Finset + +variable {n : ℕ} + +/-- The permutations moving at most `t` points of `S` out of `S`. -/ +noncomputable def escLE (S : Finset (Fin n)) (t : ℕ) : Finset (Equiv.Perm (Fin n)) := + Finset.univ.filter fun σ => escape σ S ≤ t + +/-- The escape a set of size `s` is allowed before it counts as expanding. -/ +def tOf (S : Finset (Fin n)) : ℕ := (S.card - 1) / 10 + +theorem ten_mul_tOf_le (S : Finset (Fin n)) : 10 * tOf S ≤ S.card := by + rw [tOf] + omega + +theorem mem_escLE_iff {S : Finset (Fin n)} {σ : Equiv.Perm (Fin n)} (hS : 1 ≤ S.card) : + σ ∈ escLE S (tOf S) ↔ ¬ S.card ≤ 10 * escape σ S := by + simp only [escLE, Finset.mem_filter, Finset.mem_univ, true_and, tOf] + omega + +/-- The bound on how many permutations fail to expand a set of size `s`. -/ +def escB (n s : ℕ) : ℕ := + s.choose ((s - 1) / 10) * s.descFactorial (s - (s - 1) / 10) + * Nat.factorial (n - (s - (s - 1) / 10)) + +theorem card_escLE_le (S : Finset (Fin n)) : (escLE S (tOf S)).card ≤ escB n S.card := by + have hts : tOf S ≤ S.card := by have := ten_mul_tOf_le S; omega + have h := card_perm_escape_le S (tOf S) + rw [Nat.choose_symm hts] at h + rw [escLE, escB, ← tOf] + calc (Finset.univ.filter fun σ : Equiv.Perm (Fin n) => escape σ S ≤ tOf S).card + ≤ S.card.choose (tOf S) + * (S.card.descFactorial (S.card - tOf S) * Nat.factorial (n - (S.card - tOf S))) := h + _ = S.card.choose (tOf S) * S.card.descFactorial (S.card - tOf S) + * Nat.factorial (n - (S.card - tOf S)) := by ring + +/-- **The per-size estimate.** -/ +theorem two_pow_mul_escB_le {s : ℕ} (hs : 1 ≤ s) (hsn : 2 * s ≤ n) : + 2 ^ s * (n.choose s * escB n s ^ 30) ≤ Nat.factorial n ^ 30 := by + set t := (s - 1) / 10 with ht + set k := s - t with hk + have hmt : 10 * t ≤ s := by + rw [ht] + omega + have hts : t ≤ s := by omega + have h9 : 9 * s ≤ 10 * k := by omega + have hkn : k ≤ n := by omega + exact key_estimate hs hsn h9 (count_bound (by omega) hts hkn) + +/-! ### The geometric slack -/ + +private theorem sum_geom_bound {K : ℕ} : + ∀ (n : ℕ) (h : ℕ → ℕ), h 0 = 0 → (∀ s, 1 ≤ s → s ≤ n → 2 ^ s * h s ≤ K) → + 2 ^ n * ∑ s ∈ Finset.range (n + 1), h s + K ≤ 2 ^ n * K := by + intro n + induction n with + | zero => + intro h h0 _ + simp [h0] + | succ p ih => + intro h h0 hb + have hIH := ih h h0 fun s hs1 hsp => hb s hs1 (by omega) + have hlast : 2 ^ (p + 1) * h (p + 1) ≤ K := hb (p + 1) (by omega) le_rfl + rw [Finset.sum_range_succ] + set A := 2 ^ p with hA + set T0 := ∑ s ∈ Finset.range (p + 1), h s with hT0 + have hpow : (2 : ℕ) ^ (p + 1) = 2 * A := by rw [hA, pow_succ]; ring + rw [hpow] at hlast ⊢ + set x := A * T0 with hx + set y := A * h (p + 1) with hy + set z := A * K with hz + have e1 : 2 * A * (T0 + h (p + 1)) = 2 * x + 2 * y := by rw [hx, hy]; ring + have e2 : 2 * A * K = 2 * z := by rw [hz]; ring + have e3 : 2 * A * h (p + 1) = 2 * y := by rw [hy]; ring + rw [e1, e2] + rw [e3] at hlast + omega + +/-! ### The union bound -/ + +/-- **A tuple that expands.** -/ +theorem exists_good_perms (n : ℕ) : + ∃ σ : Fin 30 → Equiv.Perm (Fin n), ∀ S : Finset (Fin n), 2 * S.card ≤ n → + S.Nonempty → ∃ i, S.card ≤ 10 * escape (σ i) S := by + classical + set badSets : Finset (Finset (Fin n)) := + Finset.univ.filter fun S => 2 * S.card ≤ n ∧ S.Nonempty with hbadSets + set term : Finset (Fin n) → ℕ := fun S => (escLE S (tOf S)).card ^ 30 with hterm + set h : ℕ → ℕ := fun s => ∑ S ∈ badSets.filter fun S => S.card = s, term S with hh + -- the count of failing tuples + set BAD : Finset (Fin 30 → Equiv.Perm (Fin n)) := + Finset.univ.filter fun σ => ∃ S ∈ badSets, ∀ i, σ i ∈ escLE S (tOf S) with hBAD + have htotal : (Finset.univ : Finset (Fin 30 → Equiv.Perm (Fin n))).card + = Nat.factorial n ^ 30 := by + rw [Finset.card_univ, Fintype.card_pi] + simp [Fintype.card_perm] + have hbound : BAD.card ≤ ∑ S ∈ badSets, term S := by + have hsub : BAD ⊆ badSets.biUnion fun S => Fintype.piFinset fun _ => escLE S (tOf S) := by + intro σ hσ + rw [hBAD, Finset.mem_filter] at hσ + obtain ⟨S, hS, hall⟩ := hσ.2 + exact Finset.mem_biUnion.2 ⟨S, hS, Fintype.mem_piFinset.2 hall⟩ + refine le_trans (Finset.card_le_card hsub) (le_trans Finset.card_biUnion_le ?_) + refine le_of_eq (Finset.sum_congr rfl fun S _ => ?_) + rw [Fintype.card_piFinset, hterm] + simp + -- regroup by size + have hmaps : ∀ S ∈ badSets, S.card ∈ Finset.range (n + 1) := by + intro S hS + rw [hbadSets, Finset.mem_filter] at hS + exact Finset.mem_range.2 (by omega) + have hregroup : ∑ S ∈ badSets, term S = ∑ s ∈ Finset.range (n + 1), h s := + (Finset.sum_fiberwise_of_maps_to hmaps _).symm + -- the per-size bound + have hh0 : h 0 = 0 := by + rw [hh] + refine Finset.sum_eq_zero fun S hS => ?_ + exfalso + rw [Finset.mem_filter, hbadSets, Finset.mem_filter] at hS + have hempty : S = ∅ := Finset.card_eq_zero.1 hS.2 + exact absurd hS.1.2.2 (by rw [hempty]; exact Finset.not_nonempty_empty) + have hhb : ∀ s, 1 ≤ s → s ≤ n → 2 ^ s * h s ≤ Nat.factorial n ^ 30 := by + intro s hs1 _ + rcases Finset.eq_empty_or_nonempty (badSets.filter fun S => S.card = s) with he | ⟨S₀, hS₀⟩ + · rw [hh] + simp only + rw [he, Finset.sum_empty, Nat.mul_zero] + positivity + · have hS₀' := hS₀ + rw [Finset.mem_filter, hbadSets, Finset.mem_filter] at hS₀' + have hsn : 2 * s ≤ n := by rw [← hS₀'.2]; exact hS₀'.1.2.1 + have hcards : ∀ S ∈ badSets.filter fun S => S.card = s, term S ≤ escB n s ^ 30 := by + intro S hS + rw [Finset.mem_filter] at hS + have := card_escLE_le S + rw [hS.2] at this + rw [hterm] + exact Nat.pow_le_pow_left this 30 + have hcnt : (badSets.filter fun S => S.card = s).card ≤ n.choose s := by + have hsub : (badSets.filter fun S => S.card = s) + ⊆ Finset.powersetCard s Finset.univ := by + intro S hS + rw [Finset.mem_filter] at hS + exact Finset.mem_powersetCard.2 ⟨Finset.subset_univ _, hS.2⟩ + have := Finset.card_le_card hsub + rwa [Finset.card_powersetCard, Finset.card_univ, Fintype.card_fin] at this + have hsum : h s ≤ n.choose s * escB n s ^ 30 := by + rw [hh] + calc ∑ S ∈ badSets.filter fun S => S.card = s, term S + ≤ (badSets.filter fun S => S.card = s).card • escB n s ^ 30 := by + refine Finset.sum_le_card_nsmul _ _ _ fun S hS => ?_ + exact hcards S hS + _ = (badSets.filter fun S => S.card = s).card * escB n s ^ 30 := by + rw [smul_eq_mul] + _ ≤ n.choose s * escB n s ^ 30 := Nat.mul_le_mul_right _ hcnt + calc 2 ^ s * h s ≤ 2 ^ s * (n.choose s * escB n s ^ 30) := Nat.mul_le_mul_left _ hsum + _ ≤ Nat.factorial n ^ 30 := two_pow_mul_escB_le hs1 hsn + -- conclude + have hgeom := sum_geom_bound (K := Nat.factorial n ^ 30) n h hh0 hhb + have hfacpos : 0 < Nat.factorial n ^ 30 := pow_pos (Nat.factorial_pos n) 30 + have hlt : ∑ S ∈ badSets, term S < Nat.factorial n ^ 30 := by + rw [hregroup] + have h2 : (0 : ℕ) < 2 ^ n := pow_pos (by norm_num) n + nlinarith [hgeom, hfacpos, h2] + have hBADlt : BAD.card < (Finset.univ : Finset (Fin 30 → Equiv.Perm (Fin n))).card := by + rw [htotal] + exact lt_of_le_of_lt hbound hlt + obtain ⟨σ, -, hσ⟩ := Finset.exists_mem_notMem_of_card_lt_card hBADlt + refine ⟨σ, fun S hS hSne => ?_⟩ + by_contra hcon + push Not at hcon + refine hσ ?_ + rw [hBAD, Finset.mem_filter] + have hS1 : 1 ≤ S.card := Finset.card_pos.2 hSne + refine ⟨Finset.mem_univ _, S, ?_, + fun i => (mem_escLE_iff hS1).2 (by simpa using hcon i)⟩ + rw [hbadSets, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hS, hSne⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean b/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean new file mode 100644 index 00000000..cdf7062f --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Expander +public import Complexitylib.Classes.PCP.Internal.NumEnc +public import Complexitylib.Classes.PCP.Internal.RegCSP + +/-! +# Expanderizing a constraint system + +The second half of Dinur's preprocessing. Degree reduction makes the graph +regular; this step makes it an *expander*, by superposing a member of an +`ExpanderFamily` whose edges carry the trivially true constraint. + +Adding constraints that are never violated cannot create unsatisfiability, and +it cannot destroy it either: the broken darts are exactly the old ones, while +the total number of darts grows from `order · deg` to +`order · (deg + E.degree)`. So the value is scaled by exactly +`deg / (deg + E.degree)` — a constant factor, since both degrees are constants +after degree reduction — and satisfiability is unchanged. The spectral bound is +inherited from `spectralBound_union`. + +## Main definitions + +- `RegCSP.addTrivial` — superpose a graph's edges with trivial constraints +- `RegCSP.expanderize` — the case of a family expander + +## Main results + +- `RegCSP.card_unsatDarts_addTrivial` — the broken darts are unchanged +- `RegCSP.unsatFrac_addTrivial`, `unsatVal_addTrivial` — the value scales by + `deg / (deg + deg')` +- `RegCSP.satisfiable_addTrivial_iff` +- `RegCSP.spectralBound_expanderize` — the result is an expander +-/ + +@[expose] public section + +namespace Complexity + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) (H : RegGraph) (e : H.V ≃ R.graph.V) + +/-- `R` with the edges of `H` superposed, carrying the trivially true +constraint. -/ +def addTrivial : RegCSP α where + graph := RegGraph.union R.graph H e + rel v d a b := + match d with + | Sum.inl i => R.rel v i a b + | Sum.inr _ => true + +@[simp] theorem graph_addTrivial : (R.addTrivial H e).graph = RegGraph.union R.graph H e := rfl + +/-- Only the original constraints can fail. -/ +theorem card_unsatDarts_addTrivial (a : R.Assignment) : + ((R.addTrivial H e).unsatDarts a).card = (R.unsatDarts a).card := by + classical + refine (Finset.card_bij (fun q _ => ((q.1, Sum.inl q.2) : (R.addTrivial H e).Dart)) ?_ ?_ ?_).symm + · intro q hq + rw [mem_unsatDarts] at hq ⊢ + intro hcon + exact hq hcon + · intro q _ q' _ heq + have h1 : q.1 = q'.1 := congrArg (fun r => (r.1 : R.graph.V)) heq + have h2 : Sum.inl q.2 = (Sum.inl q'.2 : R.graph.D ⊕ H.D) := + congrArg (fun r => (r.2 : R.graph.D ⊕ H.D)) heq + exact Prod.ext h1 (Sum.inl.inj h2) + · rintro ⟨v, i | j⟩ hq + · refine ⟨(v, i), ?_, rfl⟩ + rw [mem_unsatDarts] at hq ⊢ + intro hcon + exact hq hcon + · exfalso + rw [mem_unsatDarts] at hq + exact hq rfl + +/-- Superposing trivial constraints scales the value by `deg / (deg + deg')`. -/ +theorem unsatFrac_addTrivial (a : R.Assignment) : + (R.addTrivial H e).unsatFrac a + = R.unsatFrac a * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (H.deg : ℚ)) := by + have hd : (0 : ℚ) < (R.graph.deg : ℚ) := by + have := R.graph.deg_pos + exact_mod_cast this + have hdH : (0 : ℚ) < (H.deg : ℚ) := by + have := H.deg_pos + exact_mod_cast this + have hcards := R.card_unsatDarts_addTrivial H e a + rcases Nat.eq_zero_or_pos R.graph.order with hz | hz + · have hempty : (R.unsatDarts a).card = 0 := by + have hle : (R.unsatDarts a).card ≤ R.graph.order * R.graph.deg := R.card_unsatDarts_le a + rw [hz] at hle + omega + have hempty' : ((R.addTrivial H e).unsatDarts a).card = 0 := by rw [hcards, hempty] + rw [unsatFrac, unsatFrac, hempty, hempty'] + simp + · have hzq : (0 : ℚ) < (R.graph.order : ℚ) := by exact_mod_cast hz + rw [unsatFrac, unsatFrac, hcards] + have hden : (((R.addTrivial H e).graph.order * (R.addTrivial H e).graph.deg : ℕ) : ℚ) + = (R.graph.order : ℚ) * ((R.graph.deg : ℚ) + (H.deg : ℚ)) := by + rw [graph_addTrivial, RegGraph.order_union, RegGraph.deg_union] + push_cast + ring + rw [hden] + field_simp + push_cast + ring + +/-- The scaling passes to the value, since it is the same factor for every +assignment and the assignments are the same. -/ +theorem unsatVal_addTrivial [Fintype α] [Nonempty α] : + (R.addTrivial H e).unsatVal + = R.unsatVal * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (H.deg : ℚ)) := by + have hk : (0 : ℚ) ≤ (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (H.deg : ℚ)) := by positivity + obtain ⟨a, ha⟩ := R.exists_assignment_unsatFrac_eq_unsatVal + obtain ⟨b, hb⟩ := (R.addTrivial H e).exists_assignment_unsatFrac_eq_unsatVal + refine le_antisymm ?_ ?_ + · calc (R.addTrivial H e).unsatVal ≤ (R.addTrivial H e).unsatFrac a := + (R.addTrivial H e).unsatVal_le a + _ = R.unsatFrac a * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (H.deg : ℚ)) := + R.unsatFrac_addTrivial H e a + _ = R.unsatVal * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (H.deg : ℚ)) := by rw [ha] + · rw [← hb, R.unsatFrac_addTrivial H e b, mul_div_assoc, mul_div_assoc] + exact mul_le_mul_of_nonneg_right (R.unsatVal_le b) hk + +theorem satisfiable_addTrivial_iff : (R.addTrivial H e).Satisfiable ↔ R.Satisfiable := by + constructor + · rintro ⟨a, ha⟩ + refine ⟨a, fun p => ?_⟩ + have h := ha (p.1, Sum.inl p.2) + rw [Satisfies, satisfies] at h ⊢ + exact h + · rintro ⟨a, ha⟩ + refine ⟨a, ?_⟩ + rintro ⟨v, i | j⟩ + · have h := ha (v, i) + rw [Satisfies, satisfies] at h ⊢ + exact h + · rw [Satisfies, satisfies] + rfl + +/-- `R` with a family expander superposed. -/ +noncomputable def expanderize (R : RegCSP α) [NumEnc R.graph.V] (E : ExpanderFamily) : + RegCSP α := + R.addTrivial (E.graph R.graph.order) (E.vertexEquiv R.graph) + +@[simp] theorem graph_expanderize [NumEnc R.graph.V] (E : ExpanderFamily) : + (R.expanderize E).graph = E.expanderize R.graph := rfl + +/-- **The expanderized system is an expander.** -/ +theorem spectralBound_expanderize [NumEnc R.graph.V] (E : ExpanderFamily) : + (R.expanderize E).graph.SpectralBound + (((R.graph.deg : ℝ) + (E.degree : ℝ) * E.lam) + / ((R.graph.deg : ℝ) + (E.degree : ℝ))) := + E.spectralBound_expanderize R.graph + +theorem unsatFrac_expanderize [NumEnc R.graph.V] (E : ExpanderFamily) (a : R.Assignment) : + (R.expanderize E).unsatFrac a + = R.unsatFrac a * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (E.degree : ℚ)) := by + have h := R.unsatFrac_addTrivial (E.graph R.graph.order) (E.vertexEquiv R.graph) a + rw [E.deg_graph] at h + exact h + +theorem unsatVal_expanderize [Fintype α] [Nonempty α] [NumEnc R.graph.V] (E : ExpanderFamily) : + (R.expanderize E).unsatVal + = R.unsatVal * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (E.degree : ℚ)) := by + have h := R.unsatVal_addTrivial (E.graph R.graph.order) (E.vertexEquiv R.graph) + rw [E.deg_graph] at h + exact h + +theorem satisfiable_expanderize_iff [NumEnc R.graph.V] (E : ExpanderFamily) : + (R.expanderize E).Satisfiable ↔ R.Satisfiable := + R.satisfiable_addTrivial_iff _ _ + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/FamilyFin.lean b/Complexitylib/Classes/PCP/Internal/FamilyFin.lean new file mode 100644 index 00000000..f8b61ec1 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/FamilyFin.lean @@ -0,0 +1,401 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.TowerFin +public import Complexitylib.Classes.PCP.Internal.TowerFamily + +/-! +# An expander of every size, numbered + +`TowerFin` gives an expander at the tower's own sizes; a constraint graph asks +for one on exactly its own vertex count, and Dinur's degree reduction asks for +one on every vertex degree. This module closes the gap the way `TowerFamily` +does — fold the first large enough member onto `n` vertices, then pad the degree +with self-loops — but keeps every naming explicit, so that the rotation map +stays a formula in numbers. + +The one place `TowerFamily` numbers its darts by an arbitrary bijection is here +replaced by packing a slot and a dart with `finProdFinEquiv` and the padding +with `finSumFinEquiv`. + +## Main definitions + +- `Complexity.FinBase.famGraph` — the member on `n` vertices +- `Complexity.FinBase.toFamily` — the family + +## Main results + +- `Complexity.FinBase.spectral_famGraph` — its spectral bound, below one +-/ + +@[expose] public section + +namespace Complexity + +namespace FinBase + +variable (F : FinBase) (hd : 1 < F.deg) + +/-! ### The member folded onto `n` vertices -/ + +/-- The tower level used for `n` vertices: the first one at least twice as big. -/ +noncomputable def fitLevel (n : ℕ) : ℕ := F.level hd (2 * n) + +/-- **A fit's level is at most twice the size asked for**, so the polynomial an +algorithm needs to bound the search is linear. -/ +theorem fitLevel_le (n : ℕ) : F.fitLevel hd n ≤ 2 * n := F.level_le hd (2 * n) + +/-- Its size. -/ +noncomputable def fitN (n : ℕ) : ℕ := F.size (F.fitLevel hd n) + +/-- The degree of every tower member. -/ +def fitD : ℕ := F.deg ^ 2 + +theorem fitD_pos : 0 < F.fitD := F.sq_pos + +theorem two_mul_le_fitN (n : ℕ) : 2 * n ≤ F.fitN hd n := F.le_size_level hd (2 * n) + +/-- The width bound: the overshoot of the tower is at most `2 deg ^ 4`. -/ +def widthBnd : ℕ := 2 * F.deg ^ 4 + 1 + +/-- The family's degree. -/ +def famDeg : ℕ := F.widthBnd * F.fitD + +theorem famDeg_pos : 0 < F.famDeg := by + have h1 : 0 < F.widthBnd := by rw [widthBnd]; omega + exact Nat.mul_pos h1 F.fitD_pos + +theorem fitN_le {n : ℕ} (hn : 0 < n) : F.fitN hd n ≤ 2 * F.deg ^ 4 * n := by + have h := F.size_level_le hd (2 * n) (by omega) + rw [fitN, fitLevel] + calc F.size (F.level hd (2 * n)) ≤ F.deg ^ 4 * (2 * n) := h + _ = 2 * F.deg ^ 4 * n := by ring + +/-- The width of the fold. -/ +noncomputable def wid (n : ℕ) : ℕ := RegGraph.mergeWidth (F.fitN hd n) n + +theorem three_le_wid {n : ℕ} (hn : 0 < n) : 3 ≤ F.wid hd n := + RegGraph.three_le_mergeWidth hn (F.two_mul_le_fitN hd n) + +theorem wid_pos {n : ℕ} (hn : 0 < n) : 0 < F.wid hd n := by + have := F.three_le_wid hd hn + omega + +theorem wid_le {n : ℕ} (hn : 0 < n) : F.wid hd n ≤ F.widthBnd := + RegGraph.mergeWidth_le hn (F.fitN_le hd hn) + +theorem fitN_le_wid_mul {n : ℕ} (hn : 0 < n) : F.fitN hd n ≤ F.wid hd n * n := + RegGraph.le_mergeWidth_mul _ hn + +theorem wid_sub_one_mul_le (n : ℕ) : (F.wid hd n - 1) * n ≤ F.fitN hd n := + RegGraph.mergeWidth_sub_one_mul_le _ _ + +theorem wid_mul_fitD_le {n : ℕ} (hn : 0 < n) : F.wid hd n * F.fitD ≤ F.famDeg := + Nat.mul_le_mul_right _ (F.wid_le hd hn) + +/-- The tower member used for `n`, on its own numbers. -/ +noncomputable def fitGraph (n : ℕ) : RegGraph := F.graphAt (F.fitLevel hd n) + +@[simp] theorem order_fitGraph (n : ℕ) : (F.fitGraph hd n).order = F.fitN hd n := + F.order_graphAt _ + +@[simp] theorem deg_fitGraph (n : ℕ) : (F.fitGraph hd n).deg = F.fitD := + F.deg_graphAt _ + +theorem spectral_fitGraph (n : ℕ) : (F.fitGraph hd n).SpectralBound (2 / 5) := + spectral_graphAt F _ + +/-- Its rotation map, at the numeric type it lives on. -/ +noncomputable def fitRot (n : ℕ) : + Fin (F.fitN hd n) × Fin F.fitD → Fin (F.fitN hd n) × Fin F.fitD := + (F.data (F.fitLevel hd n)).1 + +theorem fitRot_involutive (n : ℕ) : Function.Involutive (F.fitRot hd n) := + (F.data (F.fitLevel hd n)).2 + +theorem base_fitRot (n : ℕ) : + RegGraph.base F.fitD_pos (F.fitRot hd n) (F.fitRot_involutive hd n) = F.fitGraph hd n := rfl + +/-! ### The fold, and the padding -/ + +/-- The tower member folded onto exactly `n` vertices. -/ +noncomputable def mergedG {n : ℕ} (hn : 0 < n) : RegGraph := + RegGraph.mergedN hn F.fitD_pos (F.wid_pos hd hn) (F.fitN_le_wid_mul hd hn) + (F.fitRot hd n) (F.fitRot_involutive hd n) + +@[simp] theorem order_mergedG {n : ℕ} (hn : 0 < n) : (F.mergedG hd hn).order = n := + RegGraph.order_mergedN _ _ _ _ _ _ + +@[simp] theorem deg_mergedG {n : ℕ} (hn : 0 < n) : + (F.mergedG hd hn).deg = F.wid hd n * F.fitD := + RegGraph.deg_mergedN _ _ _ _ _ _ + +theorem spectral_mergedG {n : ℕ} (hn : 0 < n) : (F.mergedG hd hn).SpectralBound (4 / 5) := by + have hspec : (RegGraph.base F.fitD_pos (F.fitRot hd n) + (F.fitRot_involutive hd n)).SpectralBound (2 / 5) := by + rw [F.base_fitRot hd n] + exact F.spectral_fitGraph hd n + have hmerged := RegGraph.spectralBound_mergedN hn F.fitD_pos (F.wid_pos hd hn) + (F.fitN_le_wid_mul hd hn) (F.wid_sub_one_mul_le hd n) (F.two_mul_le_fitN hd n) + (F.fitRot hd n) (F.fitRot_involutive hd n) (by norm_num) hspec + refine hmerged.mono (Real.sqrt_nonneg _) ?_ + rw [show (4 : ℝ) / 5 = Real.sqrt ((4 / 5) ^ 2) by rw [Real.sqrt_sq (by norm_num)]] + refine Real.sqrt_le_sqrt ?_ + have hm3 : (3 : ℝ) ≤ (F.wid hd n : ℝ) := by exact_mod_cast F.three_le_wid hd hn + have hm0 : (0 : ℝ) < (F.wid hd n : ℝ) := by linarith + set m : ℝ := (F.wid hd n : ℝ) + have h1 : (1 - (2 / 5 : ℝ) ^ 2) / (2 * m) ≤ (1 - (2 / 5 : ℝ) ^ 2) / (2 * 3) := + div_le_div_of_nonneg_left (by norm_num) (by norm_num) (by linarith) + have h2 : (1 : ℝ) / m ≤ 1 / 3 := + div_le_div_of_nonneg_left (by norm_num) (by norm_num) hm3 + nlinarith [h1, h2] + +/-- The fold padded up to the family's uniform degree. -/ +noncomputable def paddedG {n : ℕ} (hn : 0 < n) : RegGraph := + (F.mergedG hd hn).padLoops (F.famDeg - F.wid hd n * F.fitD) + +@[simp] theorem order_paddedG {n : ℕ} (hn : 0 < n) : (F.paddedG hd hn).order = n := + F.order_mergedG hd hn + +@[simp] theorem deg_paddedG {n : ℕ} (hn : 0 < n) : (F.paddedG hd hn).deg = F.famDeg := by + rw [paddedG, RegGraph.deg_padLoops, deg_mergedG] + have := F.wid_mul_fitD_le hd hn + omega + +/-- The uniform contraction factor of the family. -/ +noncomputable def famLam : ℝ := Real.sqrt (1 - 27 / (25 * F.widthBnd)) + +theorem three_le_widthBnd : 3 ≤ F.widthBnd := by + have h1 : 1 ≤ F.deg ^ 4 := Nat.one_le_pow _ _ F.deg_pos + rw [widthBnd] + omega + +theorem famLam_nonneg : 0 ≤ F.famLam := Real.sqrt_nonneg _ + +theorem famLam_lt_one : F.famLam < 1 := by + have hW : (3 : ℝ) ≤ (F.widthBnd : ℝ) := by exact_mod_cast F.three_le_widthBnd + have h0 : (0 : ℝ) ≤ 1 - 27 / (25 * F.widthBnd) := by + rw [sub_nonneg, div_le_one (by linarith)] + linarith + have hlt : (1 : ℝ) - 27 / (25 * F.widthBnd) < 1 := by + have : (0 : ℝ) < 27 / (25 * F.widthBnd) := by positivity + linarith + calc F.famLam = Real.sqrt (1 - 27 / (25 * F.widthBnd)) := rfl + _ < Real.sqrt 1 := Real.sqrt_lt_sqrt h0 hlt + _ = 1 := Real.sqrt_one + +theorem spectral_paddedG {n : ℕ} (hn : 0 < n) : (F.paddedG hd hn).SpectralBound F.famLam := by + have hpad := RegGraph.spectralBound_padLoops (G := F.mergedG hd hn) + (F.famDeg - F.wid hd n * F.fitD) (F.spectral_mergedG hd hn) + refine hpad.mono (Real.sqrt_nonneg _) ?_ + rw [famLam] + refine Real.sqrt_le_sqrt ?_ + have hle : F.wid hd n * F.fitD ≤ F.famDeg := F.wid_mul_fitD_le hd hn + have hF : (0 : ℝ) < (F.fitD : ℝ) := by exact_mod_cast F.fitD_pos + have hW : (3 : ℝ) ≤ (F.widthBnd : ℝ) := by exact_mod_cast F.three_le_widthBnd + have hm : (3 : ℝ) ≤ (F.wid hd n : ℝ) := by exact_mod_cast F.three_le_wid hd hn + have hDeg : ((F.famDeg : ℝ)) = (F.widthBnd : ℝ) * (F.fitD : ℝ) := by + rw [famDeg]; push_cast; ring + have hk : (((F.famDeg - F.wid hd n * F.fitD : ℕ) : ℝ)) + = (F.famDeg : ℝ) - (F.wid hd n : ℝ) * (F.fitD : ℝ) := by + rw [Nat.cast_sub hle]; push_cast; ring + have hWpos : (0 : ℝ) < (F.widthBnd : ℝ) := by linarith + have hDpos : (0 : ℝ) < (F.widthBnd : ℝ) * (F.fitD : ℝ) := by positivity + rw [F.deg_mergedG hd hn, hk] + push_cast + rw [hDeg, show ((F.wid hd n : ℝ) * (F.fitD : ℝ) + + ((F.widthBnd : ℝ) * (F.fitD : ℝ) - (F.wid hd n : ℝ) * (F.fitD : ℝ))) + = (F.widthBnd : ℝ) * (F.fitD : ℝ) from by ring, div_le_iff₀ hDpos, sub_mul, one_mul, + show 27 / (25 * (F.widthBnd : ℝ)) * ((F.widthBnd : ℝ) * (F.fitD : ℝ)) + = 27 * (F.fitD : ℝ) / 25 from by field_simp] + nlinarith [mul_le_mul_of_nonneg_right hm (le_of_lt hF)] + +/-! ### Numbering the darts -/ + +theorem wid_mul_fitD_add {n : ℕ} (hn : 0 < n) : + F.wid hd n * F.fitD + (F.famDeg - F.wid hd n * F.fitD) = F.famDeg := by + have := F.wid_mul_fitD_le hd hn + omega + +/-- The darts of the padded fold, numbered: a slot and a dart of the member are +packed together, and the padding loops follow them. -/ +noncomputable def famDartName {n : ℕ} (hn : 0 < n) : + (F.paddedG hd hn).D ≃ Fin F.famDeg := + (Equiv.sumCongr finProdFinEquiv (Equiv.refl _)).trans + (finSumFinEquiv.trans (finCongr (F.wid_mul_fitD_add hd hn))) + +/-- The member of the family on `n` vertices, for `n` positive. -/ +noncomputable def famGraph {n : ℕ} (hn : 0 < n) : RegGraph := + (F.paddedG hd hn).relabel (F.famDartName hd hn) + +theorem famGraph_V {n : ℕ} (hn : 0 < n) : (F.famGraph hd hn).V = Fin n := rfl + +theorem famGraph_D {n : ℕ} (hn : 0 < n) : (F.famGraph hd hn).D = Fin F.famDeg := rfl + +theorem spectral_famGraph {n : ℕ} (hn : 0 < n) : + (F.famGraph hd hn).SpectralBound F.famLam := + RegGraph.spectralBound_relabel _ _ (F.spectral_paddedG hd hn) + +/-- The family's rotation map. -/ +noncomputable def famRot (n : ℕ) : Fin n × Fin F.famDeg → Fin n × Fin F.famDeg := + if hn : 0 < n then (F.famGraph hd hn).rot else id + +theorem famRot_involutive (n : ℕ) : Function.Involutive (F.famRot hd n) := by + rw [famRot] + split + · exact (F.famGraph hd ‹_›).rot_involutive + · exact fun x => rfl + +theorem famRot_eq {n : ℕ} (hn : 0 < n) : F.famRot hd n = (F.famGraph hd hn).rot := by + rw [famRot, dif_pos hn] + +theorem spectral_famRot (n : ℕ) : + (RegGraph.ofRot F.famDeg F.famDeg_pos n (F.famRot hd n) + (F.famRot_involutive hd n)).SpectralBound F.famLam := by + rcases Nat.eq_zero_or_pos n with h | hn + · subst h + exact RegGraph.spectralBound_of_isEmpty (by exact Fin.isEmpty') _ + · have key : ∀ (r : Fin n × Fin F.famDeg → Fin n × Fin F.famDeg) + (hr : Function.Involutive r), r = (F.famGraph hd hn).rot → + (RegGraph.ofRot F.famDeg F.famDeg_pos n r hr).SpectralBound F.famLam := by + rintro r hr rfl + exact F.spectral_famGraph hd hn + exact key _ _ (F.famRot_eq hd hn) + +/-! ### The rotation map, in numbers -/ + +theorem val_famDartName_inl {n : ℕ} (hn : 0 < n) (s : Fin (F.wid hd n)) (c : Fin F.fitD) : + ((F.famDartName hd hn) (Sum.inl (s, c) : (F.paddedG hd hn).D)).val + = c.val + F.fitD * s.val := rfl + +theorem val_famDartName_inr {n : ℕ} (hn : 0 < n) + (j : Fin (F.famDeg - F.wid hd n * F.fitD)) : + ((F.famDartName hd hn) (Sum.inr j : (F.paddedG hd hn).D)).val + = F.wid hd n * F.fitD + j.val := rfl + +theorem famDartName_symm_of_lt {n : ℕ} (hn : 0 < n) (i : Fin F.famDeg) + (h : i.val < F.wid hd n * F.fitD) : + (F.famDartName hd hn).symm i + = Sum.inl (⟨i.val / F.fitD, by + exact (Nat.div_lt_iff_lt_mul F.fitD_pos).mpr h⟩, + ⟨i.val % F.fitD, Nat.mod_lt _ F.fitD_pos⟩) := by + rw [Equiv.symm_apply_eq] + refine Fin.ext ?_ + show i.val = i.val % F.fitD + F.fitD * (i.val / F.fitD) + exact (Nat.mod_add_div i.val F.fitD).symm + +theorem famDartName_symm_of_ge {n : ℕ} (hn : 0 < n) (i : Fin F.famDeg) + (h : F.wid hd n * F.fitD ≤ i.val) : + (F.famDartName hd hn).symm i + = (Sum.inr ⟨i.val - F.wid hd n * F.fitD, by + have := i.isLt + omega⟩ : (F.paddedG hd hn).D) := by + rw [Equiv.symm_apply_eq] + refine Fin.ext ?_ + show i.val = F.wid hd n * F.fitD + (i.val - F.wid hd n * F.fitD) + omega + +/-- **The family's rotation map, on raw numbers.** A dart below `wid * fitD` +splits into a slot and a dart of the tower member; the vertex it lifts to is +`v + slot * n`, and the vertex it lands on is read modulo `n`, with the slot it +landed in becoming part of the new dart. Every other dart is a self-loop. -/ +noncomputable def famRotVal (n : ℕ) (p : ℕ × ℕ) : ℕ × ℕ := + if p.2 < F.wid hd n * F.fitD then + if p.1 + p.2 / F.fitD * n < F.fitN hd n then + let y := F.rotVal (F.fitLevel hd n) (p.1 + p.2 / F.fitD * n, p.2 % F.fitD) + (y.1 % n, y.2 + F.fitD * (y.1 / n)) + else p + else p + +/-- **The numbers compute the family's rotation map.** -/ +theorem famRotVal_eq {n : ℕ} (hn : 0 < n) (v : Fin n) (i : Fin F.famDeg) : + F.famRotVal hd n (v.val, i.val) + = ((F.famRot hd n (v, i)).1.val, (F.famRot hd n (v, i)).2.val) := by + rw [F.famRot_eq hd hn] + by_cases hi : i.val < F.wid hd n * F.fitD + · obtain ⟨s, c, rfl⟩ : ∃ (s : Fin (F.wid hd n)) (c : Fin F.fitD), + i = F.famDartName hd hn (Sum.inl (s, c)) := by + refine ⟨⟨i.val / F.fitD, (Nat.div_lt_iff_lt_mul F.fitD_pos).mpr hi⟩, + ⟨i.val % F.fitD, Nat.mod_lt _ F.fitD_pos⟩, ?_⟩ + rw [← Equiv.symm_apply_eq] + exact F.famDartName_symm_of_lt hd hn i hi + simp only [famGraph, RegGraph.relabel, val_famDartName_inl] + rw [Equiv.symm_apply_apply] + show F.famRotVal hd n (v.val, c.val + F.fitD * s.val) + = (((F.mergedG hd hn).rot (v, (s, c))).1.val, + ((F.famDartName hd hn) + (Sum.inl ((F.mergedG hd hn).rot (v, (s, c))).2 : (F.paddedG hd hn).D)).val) + by_cases hu : v.val + s.val * n < F.fitN hd n + · have hlift : RegGraph.liftN (F.fitN hd n) n v s.val + = some (⟨v.val + s.val * n, hu⟩ : Fin (F.fitN hd n)) := by + rw [RegGraph.liftN, dif_pos hu] + simp only [mergedG, RegGraph.mergedN, RegGraph.mergeRotN, hlift] + have hlt : c.val + F.fitD * s.val < F.wid hd n * F.fitD := by + have h1 : c.val < F.fitD := c.isLt + have h2 : s.val + 1 ≤ F.wid hd n := s.isLt + nlinarith + have hs : (c.val + F.fitD * s.val) / F.fitD = s.val := by + rw [Nat.add_mul_div_left _ _ F.fitD_pos, Nat.div_eq_of_lt c.isLt, Nat.zero_add] + have hc : (c.val + F.fitD * s.val) % F.fitD = c.val := by + rw [Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt c.isLt] + have hrot := F.rotVal_eq (F.fitLevel hd n) + (⟨v.val + s.val * n, hu⟩ : Fin (F.size (F.fitLevel hd n))) c + rw [famRotVal, if_pos hlt] + dsimp only + rw [hs, hc, if_pos hu, hrot] + rfl + · have hlift : RegGraph.liftN (F.fitN hd n) n v s.val = none := by + rw [RegGraph.liftN, dif_neg hu] + simp only [mergedG, RegGraph.mergedN, RegGraph.mergeRotN, hlift] + have hlt : c.val + F.fitD * s.val < F.wid hd n * F.fitD := by + have h1 : c.val < F.fitD := c.isLt + have h2 : s.val + 1 ≤ F.wid hd n := s.isLt + nlinarith + have hs : (c.val + F.fitD * s.val) / F.fitD = s.val := by + rw [Nat.add_mul_div_left _ _ F.fitD_pos, Nat.div_eq_of_lt c.isLt, Nat.zero_add] + rw [famRotVal, if_pos hlt] + dsimp only + rw [hs, if_neg hu] + rfl + · obtain ⟨j, rfl⟩ : ∃ j : Fin (F.famDeg - F.wid hd n * F.fitD), + i = F.famDartName hd hn (Sum.inr j : (F.paddedG hd hn).D) := by + refine ⟨⟨i.val - F.wid hd n * F.fitD, by have := i.isLt; omega⟩, ?_⟩ + rw [← Equiv.symm_apply_eq] + exact F.famDartName_symm_of_ge hd hn i (by omega) + simp only [famGraph, RegGraph.relabel] + rw [Equiv.symm_apply_apply] + have hge : ¬ (F.wid hd n * F.fitD + j.val < F.wid hd n * F.fitD) := by omega + show F.famRotVal hd n (v.val, F.wid hd n * F.fitD + j.val) = _ + rw [famRotVal, if_neg hge] + rfl + +/-- **The expander family the numbered tower generates**: one member at every +size, of a constant degree, all contracting by the same factor, and with every +naming explicit. -/ +noncomputable def toFamily : ExpanderFamily where + degree := F.famDeg + degree_pos := F.famDeg_pos + rot := F.famRot hd + rot_involutive := F.famRot_involutive hd + lam := F.famLam + lam_nonneg := F.famLam_nonneg + lam_lt_one := F.famLam_lt_one + spectral := F.spectral_famRot hd + +end FinBase + +/-! ### The family the algorithm uses -/ + +/-- A numbered base of degree above one, chosen once. -/ +noncomputable def algBase : FinBase := Classical.choose exists_finBase + +theorem one_lt_algBase_deg : 1 < algBase.deg := Classical.choose_spec exists_finBase + +/-- **The explicit expander family**: the tower over that base. Unlike +`randExpander` it comes with rotation tables an algorithm can read. -/ +noncomputable def algFamily : ExpanderFamily := algBase.toFamily one_lt_algBase_deg + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/FiniteKey.lean b/Complexitylib/Classes/PCP/Internal/FiniteKey.lean new file mode 100644 index 00000000..e81278de --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/FiniteKey.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.FinsetDomain +public import Complexitylib.Classes.P.DecisionFn +public import Complexitylib.Classes.PCP.Internal.PCPtoSAT +public import Complexitylib.Classes.Containments.Internal.FPBridge + +/-! +# Decisions that depend on a bounded amount of data + +A constraint of a constraint graph looks at two symbols and a little local data, +and says yes or no. The rule may be described by something noncomputable — an +alphabet embedding chosen by `Classical.choice`, say — but it still runs in +polynomial time, because it is a table lookup on a bounded key. + +That is the content of this module: if a polynomial-time function extracts a key +of bounded length, then *any* predicate of that key is polynomial-time +decidable. + +The same argument gives functions, not just decisions: a value that depends on +the key alone is a table lookup too, whatever wrote the table. + +## Main results + +- `Complexity.mem_P_of_bounded_key` — a bounded-key predicate is in `P` +- `Complexity.mem_FP_of_bounded_key` — a bounded-key value is in `FP` +- `Complexity.mem_FP_of_key_congr` — and so is a value that merely *agrees* + wherever the key does +-/ + +@[expose] public section + +namespace Complexity + +open Classical in +/-- The strings of length at most `L` satisfying `P`. -/ +noncomputable def keySet (L : ℕ) (Q : List Bool → Prop) : Finset (List Bool) := + (Finset.range (L + 1)).biUnion fun n => + ((allVecs n).filter fun s => Q s).toFinset + +open Classical in +theorem mem_keySet {L : ℕ} {Q : List Bool → Prop} {s : List Bool} : + s ∈ keySet L Q ↔ s.length ≤ L ∧ Q s := by + classical + rw [keySet, Finset.mem_biUnion] + constructor + · rintro ⟨n, hn, hs⟩ + rw [List.mem_toFinset, List.mem_filter] at hs + rw [Finset.mem_range] at hn + have hlen := (mem_allVecs_iff n s).mp hs.1 + exact ⟨by omega, by simpa using hs.2⟩ + · rintro ⟨hlen, hQ⟩ + refine ⟨s.length, Finset.mem_range.mpr (by omega), ?_⟩ + rw [List.mem_toFinset, List.mem_filter] + exact ⟨(mem_allVecs_iff _ _).mpr rfl, by simpa using hQ⟩ + +/-- **A bounded-key predicate is in `P`.** The predicate itself need not be +computable; only the key extraction must be. -/ +theorem mem_P_of_bounded_key {key : List Bool → List Bool} (hkey : key ∈ FP) + {L : ℕ} (hL : ∀ z, (key z).length ≤ L) (Q : List Bool → Prop) : + {z : List Bool | Q (key z)} ∈ P := by + classical + have hite : (fun s => if s ∈ keySet L Q then [true] else ([] : List Bool)) ∈ FP := + ite_mem_finset_mem_FP (fun _ => [true]) (keySet L Q) + have hcomp : (fun z => if key z ∈ keySet L Q then [true] else ([] : List Bool)) ∈ FP := by + have := mem_FP_comp hkey hite + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply] + refine mem_P_of_decisionFn hcomp fun z => ?_ + show Q (key z) ↔ _ + by_cases h : Q (key z) + · rw [if_pos (mem_keySet.mpr ⟨hL z, h⟩)] + exact ⟨fun _ => ⟨true, by simp, rfl⟩, fun _ => h⟩ + · rw [if_neg (fun hcon => h (mem_keySet.mp hcon).2)] + simp [h] + +/-- **A bounded-key value is in `FP`.** The rule computing the value from the +key need not be computable; only the key extraction must be. -/ +theorem mem_FP_of_bounded_key {key : List Bool → List Bool} (hkey : key ∈ FP) + {L : ℕ} (hL : ∀ z, (key z).length ≤ L) (g : List Bool → List Bool) : + (fun z => g (key z)) ∈ FP := by + classical + have hite : (fun s => if s ∈ keySet L (fun _ => True) then g s else ([] : List Bool)) ∈ FP := + ite_mem_finset_mem_FP g (keySet L (fun _ => True)) + have hcomp := mem_FP_comp hkey hite + refine mem_FP_of_eq hcomp fun z => ?_ + rw [Function.comp_apply, if_pos (mem_keySet.mpr ⟨hL z, trivial⟩)] + +/-- **A value that depends on its input only through a bounded key is in `FP`.** +No rule computing the value from the key need be exhibited: agreeing wherever +the key agrees is enough. -/ +theorem mem_FP_of_key_congr {key : List Bool → List Bool} (hkey : key ∈ FP) + {L : ℕ} (hL : ∀ z, (key z).length ≤ L) {val : List Bool → List Bool} + (hcongr : ∀ z z', key z = key z' → val z = val z') : val ∈ FP := by + classical + refine mem_FP_of_eq (mem_FP_of_bounded_key hkey hL + (fun s => if h : ∃ z, key z = s then val (Classical.choose h) else [])) fun z => ?_ + have hex : ∃ w, key w = key z := ⟨z, rfl⟩ + rw [dif_pos hex] + exact hcongr _ z (Classical.choose_spec hex) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/FinsetPlurality.lean b/Complexitylib/Classes/PCP/Internal/FinsetPlurality.lean new file mode 100644 index 00000000..60b0741c --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/FinsetPlurality.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Algebra.BigOperators.Fin +public import Mathlib.Data.Fintype.Card +public import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import Mathlib.Tactic.Linarith + +/-! +# Plurality over a finite set + +The pigeonhole fact behind every "decode a cloud by majority vote" step: among +the `Fintype.card α` possible labels, some label is worn by at least a +`1 / Fintype.card α` fraction of a finite set. + +Dinur's degree reduction uses this to decode the blown-up assignment — a vertex +is given the label that the most half-edges of its cloud claim — and the bound +below is exactly what makes the *disagreeing* part of a cloud small enough for +the cloud expander to charge it. + +## Main results + +- `Complexity.exists_plurality` — some label captures at least `1 / card α` of + the set +-/ + +@[expose] public section + +namespace Complexity + +/-- **Plurality.** Some label is taken by at least a `1 / Fintype.card α` +fraction of `S`. -/ +theorem exists_plurality {β α : Type} [DecidableEq α] [Fintype α] [Nonempty α] + (S : Finset β) (A : β → α) : + ∃ a : α, S.card ≤ Fintype.card α * (S.filter fun p => A p = a).card := by + by_contra hcon + push Not at hcon + have hsum : ∑ a : α, (S.filter fun p => A p = a).card = S.card := + (Finset.card_eq_sum_card_fiberwise (fun x _ => Finset.mem_univ (A x))).symm + have hle : ∀ a : α, Fintype.card α * (S.filter fun p => A p = a).card + 1 ≤ S.card := + fun a => hcon a + have h1 : Fintype.card α * S.card + Fintype.card α ≤ Fintype.card α * S.card := by + calc Fintype.card α * S.card + Fintype.card α + = ∑ a : α, (Fintype.card α * (S.filter fun p => A p = a).card + 1) := by + rw [Finset.sum_add_distrib, ← Finset.mul_sum, hsum] + simp + _ ≤ ∑ _a : α, S.card := Finset.sum_le_sum fun a _ => hle a + _ = Fintype.card α * S.card := by simp [mul_comm] + have hpos : 0 < Fintype.card α := Fintype.card_pos + linarith + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/GapReduction.lean b/Complexitylib/Classes/PCP/Internal/GapReduction.lean new file mode 100644 index 00000000..0b98fd3d --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/GapReduction.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Compose +public import Complexitylib.Classes.PCP.Internal.AlphabetLift +public import Complexitylib.Classes.PCP.Internal.ThreeSATReduction + +/-! +# The starting constraint graph, over the amplifier's alphabet + +Dinur's round is an endomorphism of constraint graphs over the alphabet the +composition step produces, `MultiTest.Alpha ReadIdx`, while the reduction from +3-SAT lands in `Fin 3 → Bool`. The latter has eight symbols and the former +`2^23`, so the small alphabet embeds, and `AlphabetLift` carries the graph +across without disturbing satisfiability. + +## Main definitions + +- `Complexity.alphaEmb` — an injection of the 3-SAT alphabet into the + amplifier's +- `Complexity.baseCSP` — the 3-SAT constraint graph, read over that alphabet + +## Main results + +- `Complexity.satisfiable_baseCSP_iff` — it is satisfiable exactly when the + formula is +-/ + +@[expose] public section + +namespace Complexity + +open ThreeSATCSP SAT + +/-- The alphabet Dinur's round runs over. -/ +abbrev GapAlpha : Type := MultiTest.Alpha ReadIdx + +theorem card_le_gapAlpha : Fintype.card (Fin 3 → Bool) ≤ Fintype.card GapAlpha := by + classical + have hl : Fintype.card (Fin 3 → Bool) = 8 := by + rw [Fintype.card_fun, Fintype.card_bool, Fintype.card_fin] + norm_num + have hr : Fintype.card GapAlpha = 2 * 2 ^ 22 := by + show Fintype.card (ZMod 2 × (ReadIdx → ZMod 2)) = 2 * 2 ^ 22 + rw [Fintype.card_prod, Fintype.card_fun, ZMod.card, card_readIdx] + rw [hl, hr] + norm_num + +/-- An injection of the 3-SAT alphabet into the amplifier's. -/ +noncomputable def alphaEmb : (Fin 3 → Bool) ↪ GapAlpha := + (Function.Embedding.nonempty_of_card_le card_le_gapAlpha).some + +/-- The 3-SAT constraint graph, read over the amplifier's alphabet. -/ +noncomputable def baseCSP (φ : CNF) : ConstraintGraph GapAlpha := + (toGraph φ).lift alphaEmb + +@[simp] theorem numEdges_baseCSP (φ : CNF) : (baseCSP φ).numEdges = 3 * φ.length := rfl + +theorem satisfiable_baseCSP_iff {φ : CNF} (h3 : φ.Is3CNF) : + (baseCSP φ).Satisfiable ↔ φ.Satisfiable := by + classical + rw [baseCSP, ConstraintGraph.satisfiable_lift_iff _ alphaEmb.injective] + exact satisfiable_toGraph_iff h3 + +/-- The starting graph is small enough for logarithmically many rounds. -/ +theorem numEdges_baseCSP_le_pow (φ : CNF) : (baseCSP φ).numEdges ≤ 2 ^ (3 * φ.length) := by + rw [numEdges_baseCSP] + exact Nat.le_of_lt (Nat.lt_two_pow_self) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/GapTheorem.lean b/Complexitylib/Classes/PCP/Internal/GapTheorem.lean new file mode 100644 index 00000000..f9f90774 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/GapTheorem.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Dinur +public import Complexitylib.Classes.PCP.Internal.ExpanderExists +public import Complexitylib.Classes.PCP.Internal.FamilyFin +public import Complexitylib.Classes.PCP.Internal.GapReduction + +/-! +# Dinur's gap theorem for 3-SAT + +The mathematical conclusion of the development. Every 3CNF formula is turned +into a constraint graph over a fixed constant-size alphabet, of size polynomial +in the formula, which is satisfiable when the formula is and whose +unsatisfiability value is at least a universal constant when it is not. + +Three ingredients meet: the reduction of `ThreeSATCSP` carried across alphabets +by `GapReduction`, the expander family of `ExpanderExists`, and the amplifier of +`Dinur`, whose `dichotomy` supplies the gap after logarithmically many rounds. + +What this does *not* supply is computability. `gapGraph` is defined through +`Classical.choose` — the expander family is obtained by counting, not +constructed — so it is a reduction in the mathematical sense only. Turning it +into a `PCPVerifier`, which additionally demands an `FP` query function and a +`P` verdict, needs an explicit expander family and a polynomial-time +implementation of every round. + +## Main definitions + +- `Complexity.dinurAmp` — Dinur's amplifier, with the expander supplied +- `Complexity.gapGraph` — the gap graph of a formula + +## Main results + +- `Complexity.satisfiable_gapGraph` — completeness +- `Complexity.gap_le_unsatVal_gapGraph` — soundness, with a universal gap +- `Complexity.numEdges_gapGraph_le` — the size bound +-/ + +@[expose] public section + +namespace Complexity + +open ThreeSATCSP SAT + +/-- Dinur's amplifier, with the expander family supplied. -/ +noncomputable def dinurAmp : Amplifier DinurAlpha := Dinur.amplifier algFamily + +/-- How many rounds of amplification a formula needs: enough that the doubling +of the unsatisfiability value reaches the threshold, which is the bit length of +the edge count. -/ +def gapRounds (φ : CNF) : ℕ := Nat.log 2 (3 * φ.length) + 1 + +theorem numEdges_baseCSP_le_pow_rounds (φ : CNF) : + (baseCSP φ).numEdges ≤ 2 ^ gapRounds φ := by + rw [numEdges_baseCSP, gapRounds] + exact Nat.le_of_lt (Nat.lt_pow_succ_log_self (by omega) _) + +/-- **The gap graph** of a formula: logarithmically many rounds of amplification +applied to its constraint graph. -/ +noncomputable def gapGraph (φ : CNF) : ConstraintGraph DinurAlpha := + dinurAmp.iter (gapRounds φ) (baseCSP φ) + +/-- **Completeness.** -/ +theorem satisfiable_gapGraph {φ : CNF} (h3 : φ.Is3CNF) (h : φ.Satisfiable) : + (gapGraph φ).Satisfiable := + (Amplifier.dichotomy dinurAmp (baseCSP φ) (numEdges_baseCSP_le_pow_rounds φ)).1 + ((satisfiable_baseCSP_iff h3).2 h) + +/-- **Soundness**, with a gap that does not depend on the formula. -/ +theorem gap_le_unsatVal_gapGraph {φ : CNF} (h3 : φ.Is3CNF) (h : ¬ φ.Satisfiable) : + dinurAmp.gap ≤ (gapGraph φ).unsatVal := + (Amplifier.dichotomy dinurAmp (baseCSP φ) (numEdges_baseCSP_le_pow_rounds φ)).2 + fun hs => h ((satisfiable_baseCSP_iff h3).1 hs) + +/-- The gap is a positive constant. -/ +theorem dinurAmp_gap_pos : 0 < dinurAmp.gap := dinurAmp.gap_pos + +/-- The gap is at most one, as any unsatisfiability value is. -/ +theorem dinurAmp_gap_le_one : dinurAmp.gap ≤ 1 := dinurAmp.gap_le_one + +/-- A bit length costs at most a doubling. -/ +theorem two_pow_log_succ_le (n : ℕ) : 2 ^ (Nat.log 2 n + 1) ≤ 2 * n + 2 := by + rcases Nat.eq_zero_or_pos n with h | h + · subst h + simp + · have hlow : 2 ^ Nat.log 2 n ≤ n := Nat.pow_log_le_self 2 (by omega) + have hsplit : 2 ^ (Nat.log 2 n + 1) = 2 * 2 ^ Nat.log 2 n := by + rw [pow_succ] + ring + omega + +private theorem pow_pow_comm (a b c : ℕ) : (a ^ b) ^ c = (a ^ c) ^ b := by + rw [← pow_mul, ← pow_mul, Nat.mul_comm] + +private theorem pow_rounds_le (E m : ℕ) : + E ^ (Nat.log 2 m + 1) ≤ (2 * m + 2) ^ (Nat.log 2 E + 1) := by + calc E ^ (Nat.log 2 m + 1) + ≤ (2 ^ (Nat.log 2 E + 1)) ^ (Nat.log 2 m + 1) := + Nat.pow_le_pow_left (Nat.le_of_lt (Nat.lt_pow_succ_log_self (by omega) _)) _ + _ = (2 ^ (Nat.log 2 m + 1)) ^ (Nat.log 2 E + 1) := pow_pow_comm 2 _ _ + _ ≤ (2 * m + 2) ^ (Nat.log 2 E + 1) := + Nat.pow_le_pow_left (two_pow_log_succ_le _) _ + +/-- **The size bound**: a constant factor per round, and logarithmically many +rounds, so polynomially many edges. -/ +theorem numEdges_gapGraph_le (φ : CNF) : + (gapGraph φ).numEdges + ≤ (2 * (3 * φ.length) + 2) ^ (Nat.log 2 dinurAmp.edgeFactor + 1) + * (3 * φ.length) := by + have h := Amplifier.numEdges_iter_le dinurAmp (gapRounds φ) (baseCSP φ) + rw [numEdges_baseCSP] at h + exact le_trans h (Nat.mul_le_mul_right _ (pow_rounds_le _ _)) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean b/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean new file mode 100644 index 00000000..f6a7f534 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.SAT.Internal.GuessVerify +public import Complexitylib.Classes.NP.Closure +public import Complexitylib.Classes.P.DecisionFn +public import Complexitylib.Classes.Containments +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble +public import Complexitylib.Classes.Containments.Internal.SavitchFrame +public import Complexitylib.Classes.P.Cobham.Internal + +/-! +# Guess and verify, for any language + +The guess-and-verify machine built for SAT is not in fact specific to SAT: it +takes an arbitrary deterministic verifier `M`, guesses a string of length at +most `|x| + 1`, pairs it with the input and runs `M` on the result. Every +structural theorem about it in `SAT/Internal/GuessVerify` is already stated for +an arbitrary language `L`; only the final assembly mentions SAT. + +This module performs that assembly generically. The result is the +guess-and-verify bridge `NP.WitnessNTMConstruction` was meant to provide, +restricted to witnesses of linear length — which costs nothing, since padding +the input makes any polynomial witness bound linear. + +## Main results + +- `Complexity.mem_NP_of_linear_witness` — a language with a polynomial-time + verifier and witnesses of length at most `|x| + 1` is in `NP` +- `Complexity.mem_NP_of_poly_witness` — the same for any polynomial witness + bound, by padding the input until the bound is linear +-/ + +@[expose] public section + +namespace Complexity + +variable {k : ℕ} + +/-- The guess-and-verify machine decides any language whose members are exactly +the inputs with a short certificate accepted by `M`. -/ +theorem guessVerify_decidesInTime (M : TM k) {L L₀ : Language} {f : ℕ → ℕ} + (hM : M.DecidesInTime L₀ f) + (hchar : ∀ x, x ∈ L ↔ ∃ y : List Bool, y.length ≤ x.length + 1 ∧ pair x y ∈ L₀) : + (SAT.satGuessVerifyNTM M).DecidesInTime L (SAT.satGuessVerifyTime f) := by + refine ⟨SAT.satGuessVerify_allPathsHaltIn_of_decidesInTime M hM, ?_⟩ + intro x + constructor + · intro hx + obtain ⟨y, hlen, hmem⟩ := (hchar x).1 hx + exact SAT.satGuessVerify_acceptsInTime_of_witness_bound_of_decidesInTime M hM x y + hlen hmem + · intro hacc + by_contra hx + obtain ⟨choices, hhalt, hout⟩ := hacc + obtain ⟨y, hy, htrace⟩ := + SAT.satGuessVerify_trace_decides_for_some_setup_witness_of_decidesInTime M hM x choices + have hnot : pair x y ∉ L₀ := fun hmem => hx ((hchar x).2 ⟨y, hy, hmem⟩) + have hzero : ((SAT.satGuessVerifyNTM M).trace (SAT.satGuessVerifyTime f x.length) choices + ((SAT.satGuessVerifyNTM M).initCfg x)).output.cells 1 = Γ.zero := + htrace.2.2 hnot + rw [hzero] at hout + exact (by decide : Γ.zero ≠ Γ.one) hout + +/-- **Guess and verify.** A language whose members are exactly the inputs +carrying a certificate of length at most `|x| + 1` that a polynomial-time +verifier accepts is in `NP`. -/ +theorem mem_NP_of_linear_witness {L L₀ : Language} (hL₀ : L₀ ∈ P) + (hchar : ∀ x, x ∈ L ↔ ∃ y : List Bool, y.length ≤ x.length + 1 ∧ pair x y ∈ L₀) : + L ∈ NP := by + obtain ⟨c, k, M, f, hM, hfO⟩ := Set.mem_iUnion.mp hL₀ + obtain ⟨d, hgO⟩ := SAT.satGuessVerifyTime_bigO_of_bigO hfO + exact Set.mem_iUnion.mpr ⟨d, k + 3, SAT.satGuessVerifyNTM M, SAT.satGuessVerifyTime f, + guessVerify_decidesInTime M hM hchar, hgO⟩ + +/-! ### Any polynomial witness bound -/ + +/-- The input padded with a ruler long enough to make the witness bound linear. -/ +noncomputable def padWith (p : Polynomial ℕ) (x : List Bool) : List Bool := + pair x (polyRuler p x) + +theorem padWith_mem_FP (p : Polynomial ℕ) : padWith p ∈ FP := by + have h : (fun z : List Bool => polyRuler p (id z)) ∈ FP := polyRulerFn_mem_FP p id_mem_FP + exact Cobham.pairFn_mem_FP id_mem_FP h + +/-- The verifier for the padded language: run the original verifier on the +unpadded input, and check that the padding really is long enough. -/ +noncomputable def padVerifier (p : Polynomial ℕ) (L₀ : Language) : Language := + {w | pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w) ∈ L₀ ∧ + (polyRuler p (Cobham.fstBlock (Cobham.fstBlock w))).length + ≤ (Cobham.sndBlock (Cobham.fstBlock w)).length} + +theorem padVerifier_mem_P {p : Polynomial ℕ} {L₀ : Language} (hL₀ : L₀ ∈ P) : + padVerifier p L₀ ∈ P := by + have hff : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + fstBlockOf_mem_FP Cobham.fstBlock_mem_FP + have hsf : (fun w : List Bool => Cobham.sndBlock (Cobham.fstBlock w)) ∈ FP := + sndBlockOf_mem_FP Cobham.fstBlock_mem_FP + have hA : (fun w : List Bool => + pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w)) ⁻¹' L₀ ∈ P := + mem_P_preimage (Cobham.pairFn_mem_FP hff Cobham.sndBlock_mem_FP) hL₀ + have hruler : (fun w : List Bool => + polyRuler p (Cobham.fstBlock (Cobham.fstBlock w))) ∈ FP := + polyRulerFn_mem_FP p hff + have hB : {w : List Bool | + (polyRuler p (Cobham.fstBlock (Cobham.fstBlock w))).length + ≤ (Cobham.sndBlock (Cobham.fstBlock w)).length} ∈ P := by + refine mem_P_of_decisionFn (lenLeFlagFn_mem_FP hsf hruler) fun w => ?_ + simp only [Set.mem_setOf_eq] + set a := Cobham.sndBlock (Cobham.fstBlock w) with ha + set b := polyRuler p (Cobham.fstBlock (Cobham.fstBlock w)) with hb + constructor + · intro hle + rw [(Cobham.lenLeFlag_eq_true_iff a b).mpr hle] + exact ⟨true, by simp, rfl⟩ + · rintro ⟨c, hc, rfl⟩ + rcases Cobham.lenLeFlag_flag a b with h | h + · exact (Cobham.lenLeFlag_eq_true_iff a b).mp h + · rw [h] at hc + simp at hc + exact P_inter hA hB + +/-- The padded language, whose witnesses are short enough for the linear +guess-and-verify machine. -/ +noncomputable def padLang (p : Polynomial ℕ) (L₀ : Language) : Language := + {z | ∃ y : List Bool, y.length ≤ z.length + 1 ∧ pair z y ∈ padVerifier p L₀} + +theorem padLang_mem_NP {p : Polynomial ℕ} {L₀ : Language} (hL₀ : L₀ ∈ P) : + padLang p L₀ ∈ NP := + mem_NP_of_linear_witness (padVerifier_mem_P hL₀) fun _ => Iff.rfl + +/-- **Guess and verify, with any polynomial witness bound.** A language whose +members are exactly the inputs carrying a certificate a polynomial-time verifier +accepts is in `NP`, provided the verifier only accepts certificates of +polynomial length. -/ +theorem mem_NP_of_poly_witness {L L₀ : Language} (p : Polynomial ℕ) (hL₀ : L₀ ∈ P) + (hbal : ∀ x y : List Bool, pair x y ∈ L₀ → y.length ≤ p.eval x.length) + (hchar : ∀ x, x ∈ L ↔ ∃ y : List Bool, pair x y ∈ L₀) : + L ∈ NP := by + have hpre : L = padWith p ⁻¹' padLang p L₀ := by + ext x + rw [Set.mem_preimage, hchar x] + constructor + · rintro ⟨y, hy⟩ + refine ⟨y, ?_, ?_, ?_⟩ + · have := hbal x y hy + rw [padWith, pair_length, polyRuler_length] + omega + · rw [padWith, Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + exact hy + · rw [padWith, Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + · rintro ⟨y, _, hmem, _⟩ + refine ⟨y, ?_⟩ + rw [padWith, Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.fstBlock_pair] at hmem + exact hmem + rw [hpre] + exact mem_NP_preimage (padWith_mem_FP p) (padLang_mem_NP hL₀) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Hadamard.lean b/Complexitylib/Classes/PCP/Internal/Hadamard.lean new file mode 100644 index 00000000..50bce656 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Hadamard.lean @@ -0,0 +1,769 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.BooleanAnalysis.FourierExpansion +public import Complexitylib.Classes.PCP.Internal.CubeBlocks + +/-! +# Decoding a Hadamard proof + +Dinur's alphabet-reduction step composes a constraint system with an inner +verifier — an *assignment tester* — and the classical one is built from the +Hadamard code: an assignment `a ⊆ Fin n` is encoded as the parity function +`χ a`, and the verifier checks that the proof is (close to) such a function. + +The two facts the analysis rests on are already in +`Complexitylib.BooleanAnalysis.FourierExpansion`: `blr_soundness`, which says a +proof passing the linearity test is close to *some* linear function, and +`local_correctability`, which recovers that function's value anywhere. What is +missing for a tester is the *witness*: soundness must hand back the coordinate +set `S`, since `S` is precisely the assignment being decoded. + +This module extracts that witness, and records the two identities that make +`χ S` a usable decoding: its value on a basis vector is the membership bit of +`S`, so reading the corrected proof at basis vectors recovers the assignment. + +## Main results + +- `Complexity.exists_close_parity_of_blr` — soundness with the coordinate set + named +- `Complexity.parityFun_basis` — the decoded assignment is read off at basis + vectors +- `Complexity.hadamard`, `Complexity.signOf_hadamard` — the Hadamard code is a + parity function, so the Fourier results apply to it +- `Complexity.tensor`, `Complexity.hadamard_tensor` — the consistency identity + tying the quadratic table to the linear one +- `Complexity.parity_eq_signOf_hadamard`, `Complexity.exists_assignment_of_blr` — + a proof passing the linearity test decodes to an assignment +- `Complexity.eq_tensorAssign_of_consistent` — the consistency check leaves the + prover no freedom in the quadratic table +- `Complexity.QuadConstraint`, `Complexity.sat_of_checks` — the constraint check, + and tester soundness in exact form +- `Complexity.checks_of_sat` — and its completeness +- `Complexity.hammingDist_comm`, `Complexity.hammingDist_triangle` — basic + metric facts, absent from the Fourier layer +- `Complexity.eq_of_hammingDist_lt_half`, `Complexity.hadamard_inj_of_close` — + the decoding is rigid, so a check passing often holds exactly +- `Complexity.prob_hadamard_ne_zero` — a nonzero linear form is balanced +- `Complexity.tensorRow`, `Complexity.hadamard_tensor_row` — the bilinear form, + read as a linear form in one argument +- `Complexity.prob_mono`, `Complexity.prob_tensorRow_ne_zero` — a nonzero + bilinear form has nonzero rows for at least half the second arguments +- `Complexity.prob₂_tensor_ne_zero` — hence it is nonzero on a quarter of all + pairs +- `Complexity.eq_tensorAssign_of_prob_consistent` — so passing the consistency + check often forces the quadratic table exactly +- `Complexity.prob_corrected_read_left`, `Complexity.prob_two_corrected_reads` — + self-corrected reads over bundled randomness +- `Complexity.sat_of_prob_checks` — soundness when consistency is only tested + on a random pair +- `Complexity.prob_consistency_of_honest` — and the matching completeness +- `Complexity.prob_all_reads` — every read of a tester is correct, for any + bundling of its randomness +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +variable {n : ℕ} + +/-- **BLR soundness, with the witness named.** A proof passing the linearity +test is close to `χ S` for an explicit coordinate set `S` — and `S` is the +assignment the tester decodes. -/ +theorem exists_close_parity_of_blr (f : BooleanFunction n) (hf : IsBooleanValued f) + (ε : ℝ) (h : blrAcceptProb f ≥ 1 - ε) : + ∃ S : Finset (Fin n), hammingDist f (χ S) ≤ ε := by + obtain ⟨g, ⟨S, hg⟩, hclose⟩ := blr_soundness f hf ε h + refine ⟨S, ?_⟩ + have hgS : g = χ S := funext hg + rw [← hgS] + exact hclose + +/-- The basis vector at coordinate `i`. -/ +def basisVec (i : Fin n) : Cube n := fun j => if j = i then 1 else 0 + +/-- **Reading the assignment.** The decoded parity function, evaluated at the +`i`-th basis vector, is `-1` exactly when `i` belongs to the coordinate set: the +assignment is read off the proof one coordinate at a time. -/ +theorem parityFun_basis (S : Finset (Fin n)) (i : Fin n) : + (χ S) (basisVec i) = if i ∈ S then -1 else 1 := by + classical + rw [parityFun] + by_cases hi : i ∈ S + · rw [if_pos hi] + rw [Finset.prod_eq_single i] + · show chi (if i = i then (1 : ZMod 2) else 0) = -1 + rw [if_pos rfl] + show chi 1 = -1 + simp [chi] + · intro j _ hj + show chi (if j = i then (1 : ZMod 2) else 0) = 1 + rw [if_neg hj] + show chi 0 = 1 + simp [chi] + · intro hni + exact absurd hi hni + · rw [if_neg hi] + refine Finset.prod_eq_one fun j hj => ?_ + have hji : j ≠ i := fun h => hi (h ▸ hj) + show chi (if j = i then (1 : ZMod 2) else 0) = 1 + rw [if_neg hji] + show chi 0 = 1 + simp [chi] + +/-! ### The Hadamard code -/ + +/-- An `𝔽₂`-valued function on the cube. The tester's checks are stated over +`𝔽₂` — the consistency check multiplies two bits, which is not a `±1` +operation — while the linearity analysis lives in the `±1` world, so the two +views must be bridged. -/ +abbrev BitFun (n : ℕ) : Type := Cube n → ZMod 2 + +/-- The `±1` encoding of an `𝔽₂`-valued function. -/ +noncomputable def signOf (F : BitFun n) : BooleanFunction n := fun x => chi (F x) + +theorem chi_sum {ι : Type*} (s : Finset ι) (f : ι → ZMod 2) : + chi (∑ i ∈ s, f i) = ∏ i ∈ s, chi (f i) := by + classical + induction s using Finset.induction with + | empty => simp [chi] + | insert a s ha ih => + rw [Finset.sum_insert ha, Finset.prod_insert ha, BooleanAnalysis.Internal.chi_add, ih] + +/-- The Hadamard encoding of an assignment `a`: the linear function +`x ↦ ⟨a, x⟩`. -/ +def hadamard (a : Cube n) : BitFun n := fun x => ∑ i, a i * x i + +/-- **The Hadamard code is a parity function.** Its `±1` encoding is `χ` of the +support of the assignment — so the Fourier layer's linearity results apply to +Hadamard proofs verbatim, and the decoded coordinate set is the assignment's +support. -/ +theorem signOf_hadamard (a : Cube n) : + signOf (hadamard a) = χ (Finset.univ.filter fun i => a i = 1) := by + classical + funext x + show chi (∑ i, a i * x i) = ∏ i ∈ Finset.univ.filter (fun i => a i = 1), chi (x i) + rw [chi_sum] + rw [← Finset.prod_filter_mul_prod_filter_not Finset.univ (fun i => a i = 1) + (fun i => chi (a i * x i))] + have hone : ∏ i ∈ Finset.univ.filter (fun i => ¬ a i = 1), chi (a i * x i) = 1 := by + refine Finset.prod_eq_one fun i hi => ?_ + simp only [Finset.mem_filter] at hi + have hzero : a i = 0 := by + rcases (by decide : ∀ b : ZMod 2, b = 0 ∨ b = 1) (a i) with h | h + · exact h + · exact absurd h hi.2 + rw [hzero, zero_mul] + simp [chi] + rw [hone, mul_one] + refine Finset.prod_congr rfl fun i hi => ?_ + simp only [Finset.mem_filter] at hi + rw [hi.2, one_mul] + +/-! ### The tensor part -/ + +/-- The outer product of two cube points, as a point of the squared cube. The +Fourier layer is indexed by `Fin n`, so the pair index is transported along +`finProdFinEquiv`. -/ +def tensor (x y : Cube n) : Cube (n * n) := + fun k => x (finProdFinEquiv.symm k).1 * y (finProdFinEquiv.symm k).2 + +/-- The tensor square of an assignment — the second table a Hadamard proof +carries, so that the verifier can evaluate quadratic constraints. -/ +def tensorAssign (a : Cube n) : Cube (n * n) := tensor a a + +/-- **The consistency identity.** The tensor table, read at an outer product, +is the product of the two linear readings. This is the check that ties the +quadratic table to the linear one, and it is a statement about *bits*: over +`𝔽₂` the right-hand side is a product, which is why the tester's checks cannot +be phrased in the `±1` encoding. -/ +theorem hadamard_tensor (a x y : Cube n) : + hadamard (tensorAssign a) (tensor x y) = hadamard a x * hadamard a y := by + classical + have hre : ∀ f : Fin n × Fin n → ZMod 2, + ∑ k : Fin (n * n), f (finProdFinEquiv.symm k) = ∑ p : Fin n × Fin n, f p := by + intro f + exact Fintype.sum_equiv finProdFinEquiv.symm (fun k => f (finProdFinEquiv.symm k)) f + fun k => rfl + show ∑ k : Fin (n * n), (tensorAssign a) k * (tensor x y) k + = (∑ i, a i * x i) * (∑ j, a j * y j) + have hstep : ∑ k : Fin (n * n), (tensorAssign a) k * (tensor x y) k + = ∑ p : Fin n × Fin n, (a p.1 * a p.2) * (x p.1 * y p.2) := + hre fun p => (a p.1 * a p.2) * (x p.1 * y p.2) + rw [hstep, Fintype.sum_prod_type, Finset.sum_mul_sum] + refine Finset.sum_congr rfl fun i _ => Finset.sum_congr rfl fun j _ => ?_ + ring + +/-! ### Decoding a proof into an assignment -/ + +/-- The assignment a coordinate set stands for. -/ +def indicatorAssign (S : Finset (Fin n)) : Cube n := fun i => if i ∈ S then 1 else 0 + +/-- **Every parity function is a Hadamard codeword.** With `signOf_hadamard` +this makes the correspondence between assignments and parity functions a +bijection, so BLR's coordinate set can be handed back as an assignment. -/ +theorem parity_eq_signOf_hadamard (S : Finset (Fin n)) : + (χ S) = signOf (hadamard (indicatorAssign S)) := by + classical + rw [signOf_hadamard] + congr 1 + ext i + simp only [Finset.mem_filter, Finset.mem_univ, true_and, indicatorAssign] + by_cases hi : i ∈ S + · simp [hi] + · simp [hi] + +/-- **Decoding.** A proof passing the linearity test is close to the Hadamard +encoding of an explicit assignment — the assignment the tester extracts. -/ +theorem exists_assignment_of_blr (f : BooleanFunction n) (hf : IsBooleanValued f) + (ε : ℝ) (h : blrAcceptProb f ≥ 1 - ε) : + ∃ a : Cube n, hammingDist f (signOf (hadamard a)) ≤ ε := by + obtain ⟨S, hS⟩ := exists_close_parity_of_blr f hf ε h + refine ⟨indicatorAssign S, ?_⟩ + rw [← parity_eq_signOf_hadamard S] + exact hS + +/-! ### Consistency forces the tensor -/ + +/-- Reading a Hadamard table at a basis vector returns that coordinate. -/ +theorem hadamard_basisVec (a : Cube n) (i : Fin n) : hadamard a (basisVec i) = a i := by + classical + show ∑ j, a j * (basisVec i) j = a i + rw [Finset.sum_eq_single i] + · show a i * (if i = i then (1 : ZMod 2) else 0) = a i + rw [if_pos rfl, mul_one] + · intro j _ hj + show a j * (if j = i then (1 : ZMod 2) else 0) = 0 + rw [if_neg hj, mul_zero] + · intro hni + exact absurd (Finset.mem_univ i) hni + +/-- The outer product of two basis vectors is the basis vector at the +corresponding pair index. -/ +theorem tensor_basisVec (i j : Fin n) : + tensor (basisVec i) (basisVec j) = basisVec (finProdFinEquiv (i, j)) := by + classical + funext k + show (basisVec i) (finProdFinEquiv.symm k).1 * (basisVec j) (finProdFinEquiv.symm k).2 + = if k = finProdFinEquiv (i, j) then (1 : ZMod 2) else 0 + by_cases hk : k = finProdFinEquiv (i, j) + · subst hk + rw [if_pos rfl, Equiv.symm_apply_apply] + show (if i = i then (1 : ZMod 2) else 0) * (if j = j then (1 : ZMod 2) else 0) = 1 + rw [if_pos rfl, if_pos rfl, mul_one] + · rw [if_neg hk] + by_cases h1 : (finProdFinEquiv.symm k).1 = i + · by_cases h2 : (finProdFinEquiv.symm k).2 = j + · exfalso + apply hk + have hpair : finProdFinEquiv.symm k = (i, j) := Prod.ext h1 h2 + rw [← hpair, Equiv.apply_symm_apply] + · show (if (finProdFinEquiv.symm k).1 = i then (1 : ZMod 2) else 0) + * (if (finProdFinEquiv.symm k).2 = j then (1 : ZMod 2) else 0) = 0 + rw [if_neg h2, mul_zero] + · show (if (finProdFinEquiv.symm k).1 = i then (1 : ZMod 2) else 0) + * (if (finProdFinEquiv.symm k).2 = j then (1 : ZMod 2) else 0) = 0 + rw [if_neg h1, zero_mul] + +/-- **Consistency forces the tensor.** A quadratic table that agrees with the +product of the linear readings on every outer product *is* the tensor square of +the assignment — testing at basis vectors pins down every entry. This is why the +consistency check suffices: it leaves the prover no freedom in the quadratic +table. -/ +theorem eq_tensorAssign_of_consistent (a : Cube n) (b : Cube (n * n)) + (h : ∀ x y : Cube n, hadamard b (tensor x y) = hadamard a x * hadamard a y) : + b = tensorAssign a := by + classical + funext k + set i := (finProdFinEquiv.symm k).1 with hi + set j := (finProdFinEquiv.symm k).2 with hj + have hk : k = finProdFinEquiv (i, j) := by + rw [hi, hj, Prod.mk.eta, Equiv.apply_symm_apply] + have hb := h (basisVec i) (basisVec j) + rw [tensor_basisVec, hadamard_basisVec, hadamard_basisVec, hadamard_basisVec] at hb + show b k = a i * a j + rw [hk] + exact hb + +/-! ### Checking a constraint -/ + +/-- A quadratic constraint over `𝔽₂`. Dinur's inner verifier tests exactly +this: the constraints of a system with a constant-size alphabet are quadratic +equations once the alphabet symbols are spelled out in bits. -/ +structure QuadConstraint (n : ℕ) where + /-- The quadratic coefficients, indexed like the tensor table. -/ + quad : Cube (n * n) + /-- The linear coefficients. -/ + lin : Cube n + /-- The constant term. -/ + const : ZMod 2 + +/-- The constraint evaluated at an assignment. -/ +def QuadConstraint.eval (C : QuadConstraint n) (a : Cube n) : ZMod 2 := + hadamard (tensorAssign a) C.quad + hadamard a C.lin + C.const + +/-- The assignment satisfies the constraint. -/ +def QuadConstraint.Sat (C : QuadConstraint n) (a : Cube n) : Prop := C.eval a = 0 + +/-- What the verifier computes from the two tables: one query into each. -/ +def checkValue (F : BitFun (n * n)) (f : BitFun n) (C : QuadConstraint n) : ZMod 2 := + F C.quad + f C.lin + C.const + +/-- On honest tables the check *is* the constraint — this is completeness. -/ +theorem checkValue_hadamard (a : Cube n) (C : QuadConstraint n) : + checkValue (hadamard (tensorAssign a)) (hadamard a) C = C.eval a := rfl + +/-- **Tester soundness, exact form.** If the two tables are Hadamard codewords, +the consistency check holds everywhere, and the constraint check passes, then +the decoded assignment satisfies the constraint. The prover's only freedom is +the assignment itself: consistency pins the quadratic table to the tensor of the +linear one, and then the check computes the constraint honestly. -/ +theorem sat_of_checks (a : Cube n) (b : Cube (n * n)) (C : QuadConstraint n) + (hcons : ∀ x y : Cube n, hadamard b (tensor x y) = hadamard a x * hadamard a y) + (hcheck : checkValue (hadamard b) (hadamard a) C = 0) : + C.Sat a := by + rw [QuadConstraint.Sat, QuadConstraint.eval, ← eq_tensorAssign_of_consistent a b hcons] + exact hcheck + +/-- The Hadamard encoding of an assignment is linear, so it passes the +linearity test with certainty. -/ +theorem isLinear_signOf_hadamard (a : Cube n) : IsLinear (signOf (hadamard a)) := by + classical + refine ⟨Finset.univ.filter fun i => a i = 1, fun x => ?_⟩ + rw [signOf_hadamard] + +/-- **Tester completeness, exact form.** The honest tables of a satisfying +assignment pass the linearity test with certainty, satisfy the consistency check +everywhere, and pass the constraint check. -/ +theorem checks_of_sat (a : Cube n) (C : QuadConstraint n) (h : C.Sat a) : + blrAcceptProb (signOf (hadamard a)) = 1 + ∧ (∀ x y : Cube n, + hadamard (tensorAssign a) (tensor x y) = hadamard a x * hadamard a y) + ∧ checkValue (hadamard (tensorAssign a)) (hadamard a) C = 0 := by + refine ⟨blr_completeness _ (isLinear_signOf_hadamard a), hadamard_tensor a, ?_⟩ + rw [checkValue_hadamard] + exact h + +/-! ### Rigidity of the decoding -/ + +/-- **Distinct parity functions are far apart.** Two different parity functions +disagree on exactly half the cube, so agreeing on more than half forces them to +be equal. + +This is what makes the approximate tester work: the decoded tables are linear, +and a check that passes on a large enough fraction of the cube therefore holds +*everywhere* on the corrected tables — turning a probabilistic hypothesis into +the exact one `sat_of_checks` needs. -/ +theorem eq_of_hammingDist_lt_half {S T : Finset (Fin n)} + (h : hammingDist (χ S) (χ T) < 1 / 2) : S = T := by + by_contra hne + have h1 : ⟪χ S, χ T⟫ = 0 := by + rw [parityFun_orthonormal] + exact if_neg hne + have h2 : ⟪χ S, χ T⟫ = 1 - 2 * hammingDist (χ S) (χ T) := + inner_eq_one_sub_two_dist _ _ (isBooleanValued_parityFun S) + (isBooleanValued_parityFun T) + rw [h1] at h2 + linarith + +theorem hammingDist_comm (f g : BooleanFunction n) : + hammingDist f g = hammingDist g f := by + have hpred : (fun x => f x ≠ g x) = (fun x => g x ≠ f x) := by + funext x + exact propext ⟨fun h => Ne.symm h, fun h => Ne.symm h⟩ + rw [hammingDist, hammingDist, hpred] + +theorem hammingDist_triangle (f g h : BooleanFunction n) : + hammingDist f h ≤ hammingDist f g + hammingDist g h := by + have hbound := BooleanAnalysis.Internal.prob_union_bound + (P := fun x => f x = h x) (Q := fun x => f x ≠ g x) (R := fun x => g x ≠ h x) + (fun x hx => by + by_contra hcon + push Not at hcon + exact hx (hcon.1.trans hcon.2)) + exact hbound + +/-- The decoded assignment is unique: a proof cannot be close to the Hadamard +encodings of two different assignments. -/ +theorem hadamard_inj_of_close {S T : Finset (Fin n)} {f : BooleanFunction n} {ε : ℝ} + (hε : ε < 1 / 4) (hS : hammingDist f (χ S) ≤ ε) (hT : hammingDist f (χ T) ≤ ε) : + S = T := by + refine eq_of_hammingDist_lt_half ?_ + have htri : hammingDist (χ S) (χ T) + ≤ hammingDist (χ S) f + hammingDist f (χ T) := + hammingDist_triangle _ _ _ + have hsymm : hammingDist (χ S) f = hammingDist f (χ S) := hammingDist_comm _ _ + rw [hsymm] at htri + linarith + +/-! ### A nonzero linear form is balanced -/ + +/-- The `±1` encoding turns a bit into `1 - 2·bit`. -/ +theorem chi_eq_one_sub_two (v : ZMod 2) : + chi v = 1 - 2 * (if v ≠ 0 then (1 : ℝ) else 0) := by + by_cases h : v = 0 + · rw [h] + norm_num [chi] + · rw [if_pos h] + have hchi : chi v = -1 := by simp [chi, h] + rw [hchi] + norm_num + +theorem card_cube (n : ℕ) : Fintype.card (Cube n) = 2 ^ n := by + show Fintype.card (Fin n → ZMod 2) = 2 ^ n + rw [Fintype.card_fun, ZMod.card, Fintype.card_fin] + +/-- The expectation of a bit function's sign encoding. -/ +theorem expect_signOf (F : BitFun n) : + 𝔼[signOf F] = 1 - 2 * Pr[fun x => F x ≠ 0] := by + classical + rw [expect_unfold, BooleanAnalysis.prob, expect_unfold] + simp only [BooleanAnalysis.indicator] + have hterm : ∀ x : Cube n, (signOf F) x = 1 - 2 * (if F x ≠ 0 then (1 : ℝ) else 0) := + fun x => chi_eq_one_sub_two (F x) + rw [Finset.sum_congr rfl fun x _ => hterm x, Finset.sum_sub_distrib, ← Finset.mul_sum] + have hcard : ∑ _x : Cube n, (1 : ℝ) = 2 ^ n := by + rw [Finset.sum_const, Finset.card_univ, card_cube, nsmul_eq_mul, mul_one] + norm_num + rw [hcard] + have hpow : (2 : ℝ) ^ n ≠ 0 := by positivity + field_simp + ring + +/-- **A nonzero linear form is balanced.** Over `𝔽₂` a nonzero linear form takes +each value on exactly half the cube — the counting fact behind every "the check +cannot pass too often unless it always passes" step. -/ +theorem prob_hadamard_ne_zero (a : Cube n) (ha : a ≠ 0) : + Pr[fun x => hadamard a x ≠ 0] = 1 / 2 := by + classical + have hne : (Finset.univ.filter fun i => a i = 1) ≠ ∅ := by + intro hempty + apply ha + funext i + have hi : i ∉ Finset.univ.filter fun j => a j = 1 := by + rw [hempty] + exact Finset.notMem_empty i + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hi + rcases (by decide : ∀ b : ZMod 2, b = 0 ∨ b = 1) (a i) with h | h + · exact h + · exact absurd h hi + have hexp : 𝔼[signOf (hadamard a)] = 0 := by + rw [signOf_hadamard, expect_parityFun, if_neg hne] + rw [expect_signOf] at hexp + linarith + +/-! ### The bilinear form -/ + +/-- The bilinear form of `c`, contracted against `y`: the linear form in `x` +obtained by fixing the second argument. -/ +def tensorRow (c : Cube (n * n)) (y : Cube n) : Cube n := + fun i => ∑ j, c (finProdFinEquiv (i, j)) * y j + +/-- **Row decomposition.** Reading the quadratic table at an outer product is a +*linear* reading in the first argument, with coefficients contracted against the +second. This is what lets the one-variable balance lemma be applied inside a +two-variable check. -/ +theorem hadamard_tensor_row (c : Cube (n * n)) (x y : Cube n) : + hadamard c (tensor x y) = hadamard (tensorRow c y) x := by + classical + have hre : ∀ f : Fin n × Fin n → ZMod 2, + ∑ k : Fin (n * n), f (finProdFinEquiv.symm k) = ∑ p : Fin n × Fin n, f p := by + intro f + exact Fintype.sum_equiv finProdFinEquiv.symm (fun k => f (finProdFinEquiv.symm k)) f + fun k => rfl + have hlhs : hadamard c (tensor x y) + = ∑ p : Fin n × Fin n, c (finProdFinEquiv p) * (x p.1 * y p.2) := by + show ∑ k : Fin (n * n), c k * (tensor x y) k = _ + have hstep : ∑ k : Fin (n * n), c k * (tensor x y) k + = ∑ p : Fin n × Fin n, + c (finProdFinEquiv p) * (x p.1 * y p.2) := by + refine Eq.trans ?_ (hre fun p => c (finProdFinEquiv p) * (x p.1 * y p.2)) + refine Finset.sum_congr rfl fun k _ => ?_ + show c k * ((x (finProdFinEquiv.symm k).1) * (y (finProdFinEquiv.symm k).2)) + = c (finProdFinEquiv (finProdFinEquiv.symm k)) + * (x (finProdFinEquiv.symm k).1 * y (finProdFinEquiv.symm k).2) + rw [Equiv.apply_symm_apply] + exact hstep + rw [hlhs] + show _ = ∑ i, (∑ j, c (finProdFinEquiv (i, j)) * y j) * x i + rw [Fintype.sum_prod_type] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Finset.sum_mul] + refine Finset.sum_congr rfl fun j _ => ?_ + ring + +/-- Probability is monotone. The Fourier layer has the union bound and +complements but not this. -/ +theorem prob_mono {P Q : Cube n → Prop} (h : ∀ x, P x → Q x) : Pr[P] ≤ Pr[Q] := by + classical + simp only [BooleanAnalysis.prob, expect_unfold, BooleanAnalysis.indicator] + refine mul_le_mul_of_nonneg_left (Finset.sum_le_sum fun x _ => ?_) (by positivity) + by_cases hp : P x + · rw [if_pos hp, if_pos (h x hp)] + · rw [if_neg hp] + split_ifs <;> norm_num + +/-- **The bilinear form is nonzero on many rows.** If the quadratic table's +error `c` is nonzero, then for at least half the `y` the contracted linear form +is nonzero — the first half of the `1/4` bound. -/ +theorem prob_tensorRow_ne_zero (c : Cube (n * n)) (hc : c ≠ 0) : + 1 / 2 ≤ Pr[fun y => tensorRow c y ≠ 0] := by + classical + obtain ⟨k, hk⟩ : ∃ k, c k ≠ 0 := by + by_contra hcon + push Not at hcon + exact hc (funext hcon) + set i := (finProdFinEquiv.symm k).1 with hi + set j := (finProdFinEquiv.symm k).2 with hj + have hkij : k = finProdFinEquiv (i, j) := by + rw [hi, hj, Prod.mk.eta, Equiv.apply_symm_apply] + set d : Cube n := fun j' => c (finProdFinEquiv (i, j')) with hd + have hdne : d ≠ 0 := by + intro h0 + apply hk + rw [hkij] + have := congrFun h0 j + rw [hd] at this + exact this + have hrow : ∀ y : Cube n, (tensorRow c y) i = hadamard d y := fun y => rfl + have hsub : ∀ y : Cube n, hadamard d y ≠ 0 → tensorRow c y ≠ 0 := by + intro y hy hzero + apply hy + rw [← hrow y, hzero] + rfl + calc (1 : ℝ) / 2 = Pr[fun y => hadamard d y ≠ 0] := (prob_hadamard_ne_zero d hdne).symm + _ ≤ Pr[fun y => tensorRow c y ≠ 0] := prob_mono hsub + +theorem expect_mono {f g : BooleanFunction n} (h : ∀ x, f x ≤ g x) : 𝔼[f] ≤ 𝔼[g] := by + rw [expect_unfold, expect_unfold] + exact mul_le_mul_of_nonneg_left (Finset.sum_le_sum fun x _ => h x) (by positivity) + +theorem expect_const_mul (c : ℝ) (f : BooleanFunction n) : + 𝔼[fun x => c * f x] = c * 𝔼[f] := by + rw [expect_unfold, expect_unfold, ← Finset.mul_sum] + ring + +/-- **A nonzero bilinear form is nonzero on a quarter of all pairs.** For at +least half the second arguments the contracted form is nonzero, and each such +form is nonzero on exactly half the first arguments. + +This is the quantitative heart of the consistency check: a prover whose +quadratic table differs from the tensor square fails the check on at least a +quarter of the pairs, so passing it more often than that forces the tables to +agree exactly. -/ +theorem prob₂_tensor_ne_zero (c : Cube (n * n)) (hc : c ≠ 0) : + 1 / 4 ≤ Pr₂[fun y x => hadamard c (tensor x y) ≠ 0] := by + classical + have hpoint : ∀ y : Cube n, + (1 / 2 : ℝ) * (if tensorRow c y ≠ 0 then (1 : ℝ) else 0) + ≤ 𝔼[BooleanAnalysis.indicator (fun x => hadamard c (tensor x y) ≠ 0)] := by + intro y + have hcond : (fun x => hadamard c (tensor x y) ≠ 0) + = (fun x => hadamard (tensorRow c y) x ≠ 0) := by + funext x + rw [hadamard_tensor_row] + by_cases hy : tensorRow c y ≠ 0 + · rw [if_pos hy, mul_one, hcond] + exact le_of_eq (prob_hadamard_ne_zero _ hy).symm + · rw [if_neg hy, mul_zero] + exact BooleanAnalysis.Internal.prob_nonneg _ + have hhalf := prob_tensorRow_ne_zero c hc + calc (1 : ℝ) / 4 = (1 / 2) * (1 / 2) := by norm_num + _ ≤ (1 / 2) * Pr[fun y => tensorRow c y ≠ 0] := by linarith + _ = 𝔼[fun y => (1 / 2 : ℝ) * (if tensorRow c y ≠ 0 then (1 : ℝ) else 0)] := by + rw [expect_const_mul] + congr 1 + rw [BooleanAnalysis.prob] + congr 1 + funext y + simp [BooleanAnalysis.indicator] + _ ≤ Pr₂[fun y x => hadamard c (tensor x y) ≠ 0] := expect_mono hpoint + +/-! ### Approximate consistency -/ + +theorem hadamard_add {m : ℕ} (b c z : Cube m) : + hadamard (b + c) z = hadamard b z + hadamard c z := by + show ∑ i, (b i + c i) * z i = (∑ i, b i * z i) + (∑ i, c i * z i) + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun i _ => by ring + +theorem expect_add (f g : BooleanFunction n) : + 𝔼[fun x => f x + g x] = 𝔼[f] + 𝔼[g] := by + rw [expect_unfold, expect_unfold, expect_unfold, ← mul_add, ← Finset.sum_add_distrib] + +theorem expect_one : 𝔼[fun _ : Cube n => (1 : ℝ)] = 1 := by + rw [expect_unfold, Finset.sum_const, Finset.card_univ, card_cube, nsmul_eq_mul, mul_one] + have hpow : (2 : ℝ) ^ n ≠ 0 := by positivity + push_cast + field_simp + +theorem prob₂_compl (P : Cube n → Cube n → Prop) : + Pr₂[P] + Pr₂[fun x y => ¬ P x y] = 1 := by + classical + rw [BooleanAnalysis.prob₂, BooleanAnalysis.prob₂, ← expect_add, ← expect_one (n := n)] + congr 1 + funext x + exact BooleanAnalysis.Internal.prob_compl (P x) + +/-- **Approximate consistency forces the tensor.** A quadratic table passing the +consistency check on more than three quarters of the pairs must be the tensor +square: otherwise their difference is a nonzero bilinear form, which +`prob₂_tensor_ne_zero` says fails on at least a quarter. -/ +theorem eq_tensorAssign_of_prob_consistent (a : Cube n) (b : Cube (n * n)) + (h : 3 / 4 < Pr₂[fun y x => + hadamard b (tensor x y) = hadamard a x * hadamard a y]) : + b = tensorAssign a := by + classical + by_contra hne + have hcne : b + tensorAssign a ≠ 0 := by + intro h0 + apply hne + funext k + have hk := congrFun h0 k + show b k = (tensorAssign a) k + rcases (by decide : ∀ u v : ZMod 2, u + v = 0 → u = v) (b k) ((tensorAssign a) k) hk with h' + exact h' + have hquarter := prob₂_tensor_ne_zero (b + tensorAssign a) hcne + have hfail : (fun y x => hadamard (b + tensorAssign a) (tensor x y) ≠ 0) + = fun y x => ¬ (hadamard b (tensor x y) = hadamard a x * hadamard a y) := by + funext y x + rw [hadamard_add, hadamard_tensor] + have hiff : (hadamard b (tensor x y) + hadamard a x * hadamard a y = 0) + ↔ (hadamard b (tensor x y) = hadamard a x * hadamard a y) := by + rcases (by decide : ∀ u v : ZMod 2, (u + v = 0) ↔ (u = v)) (hadamard b (tensor x y)) + (hadamard a x * hadamard a y) with h' + exact h' + exact propext (not_congr hiff) + rw [hfail] at hquarter + have hcompl := prob₂_compl (fun y x => + hadamard b (tensor x y) = hadamard a x * hadamard a y) + linarith + +/-! ### Reads over bundled randomness -/ + +/-- **A corrected read is right.** Reading a close-to-linear table by +self-correction, with the randomness taken from the first block of a bundled +random string, returns the codeword's value except with probability `2ε`. -/ +theorem prob_corrected_read_left (f : BooleanFunction n) (hf : IsBooleanValued f) + (S : Finset (Fin n)) {ε : ℝ} (hclose : IsClose f (χ S) ε) (x : Cube n) : + 1 - 2 * ε ≤ Pr[fun z : Cube (n + n) => + f (leftBlock z) * f (x + leftBlock z) = (χ S) x] := by + have h : Pr[fun z : Cube (n + n) => f (leftBlock z) * f (x + leftBlock z) = (χ S) x] + = Pr[fun y : Cube n => f y * f (x + y) = (χ S) x] := + prob_leftBlock (fun y => f y * f (x + y) = (χ S) x) + rw [h] + exact local_correctability f hf S hclose x + +/-- The same for the second block. -/ +theorem prob_corrected_read_right (f : BooleanFunction n) (hf : IsBooleanValued f) + (S : Finset (Fin n)) {ε : ℝ} (hclose : IsClose f (χ S) ε) (x : Cube n) : + 1 - 2 * ε ≤ Pr[fun z : Cube (n + n) => + f (rightBlock z) * f (x + rightBlock z) = (χ S) x] := by + have h : Pr[fun z : Cube (n + n) => f (rightBlock z) * f (x + rightBlock z) = (χ S) x] + = Pr[fun y : Cube n => f y * f (x + y) = (χ S) x] := + prob_rightBlock (fun y => f y * f (x + y) = (χ S) x) + rw [h] + exact local_correctability f hf S hclose x + +/-- **Two corrected reads are both right.** The union bound over the two blocks: +bundling the randomness is what makes this an ordinary one-variable union bound +rather than a product-measure argument. -/ +theorem prob_two_corrected_reads (f : BooleanFunction n) (hf : IsBooleanValued f) + (S : Finset (Fin n)) {ε : ℝ} (hclose : IsClose f (χ S) ε) (x x' : Cube n) : + 1 - 4 * ε ≤ Pr[fun z : Cube (n + n) => + f (leftBlock z) * f (x + leftBlock z) = (χ S) x + ∧ f (rightBlock z) * f (x' + rightBlock z) = (χ S) x'] := by + classical + have hleft := prob_corrected_read_left f hf S hclose x + have hright := prob_corrected_read_right f hf S hclose x' + have hcl : Pr[fun z : Cube (n + n) => ¬ (f (leftBlock z) * f (x + leftBlock z) = (χ S) x)] + ≤ 2 * ε := by + have := BooleanAnalysis.Internal.prob_compl + (fun z : Cube (n + n) => f (leftBlock z) * f (x + leftBlock z) = (χ S) x) + linarith + have hcr : Pr[fun z : Cube (n + n) => + ¬ (f (rightBlock z) * f (x' + rightBlock z) = (χ S) x')] ≤ 2 * ε := by + have := BooleanAnalysis.Internal.prob_compl + (fun z : Cube (n + n) => f (rightBlock z) * f (x' + rightBlock z) = (χ S) x') + linarith + have hunion := BooleanAnalysis.Internal.prob_union_bound + (P := fun z : Cube (n + n) => f (leftBlock z) * f (x + leftBlock z) = (χ S) x + ∧ f (rightBlock z) * f (x' + rightBlock z) = (χ S) x') + (Q := fun z : Cube (n + n) => ¬ (f (leftBlock z) * f (x + leftBlock z) = (χ S) x)) + (R := fun z : Cube (n + n) => + ¬ (f (rightBlock z) * f (x' + rightBlock z) = (χ S) x')) + (fun z hz => by + by_contra hcon + push Not at hcon + exact hz ⟨hcon.1, hcon.2⟩) + have hcompl := BooleanAnalysis.Internal.prob_compl + (fun z : Cube (n + n) => f (leftBlock z) * f (x + leftBlock z) = (χ S) x + ∧ f (rightBlock z) * f (x' + rightBlock z) = (χ S) x') + linarith + +/-- **Tester soundness with a probabilistic consistency check.** The verifier +cannot test consistency everywhere — it tests one random pair. This says that is +enough: passing on more than three quarters of the pairs pins the quadratic table +down exactly, and then the constraint check computes the constraint honestly. + +Together with `checks_of_sat` this is the assignment tester's guarantee at the +level of decoded tables: the prover's only freedom is which assignment to encode, +and if the checks pass, that assignment satisfies the constraint. -/ +theorem sat_of_prob_checks (a : Cube n) (b : Cube (n * n)) (C : QuadConstraint n) + (hcons : 3 / 4 < Pr₂[fun y x => + hadamard b (tensor x y) = hadamard a x * hadamard a y]) + (hcheck : checkValue (hadamard b) (hadamard a) C = 0) : + C.Sat a := by + refine sat_of_checks a b C (fun x y => ?_) hcheck + rw [eq_tensorAssign_of_prob_consistent a b hcons] + exact hadamard_tensor a x y + +theorem prob₂_of_forall {P : Cube n → Cube n → Prop} (h : ∀ x y, P x y) : Pr₂[P] = 1 := by + classical + rw [BooleanAnalysis.prob₂] + have hpt : ∀ x : Cube n, 𝔼[BooleanAnalysis.indicator (P x)] = 1 := + fun x => prob_of_forall (h x) + calc 𝔼[fun x => 𝔼[BooleanAnalysis.indicator (P x)]] = 𝔼[fun _ : Cube n => (1 : ℝ)] := by + congr 1 + funext x + exact hpt x + _ = 1 := expect_one + +/-- **Completeness of the consistency check.** The honest tables pass it on every +pair, so the tester accepts a correct proof with certainty. -/ +theorem prob_consistency_of_honest (a : Cube n) : + Pr₂[fun y x => + hadamard (tensorAssign a) (tensor x y) = hadamard a x * hadamard a y] = 1 := + prob₂_of_forall fun y x => hadamard_tensor a x y + +/-- **All of a tester's reads are correct.** Given a close-to-linear table and +any family of blocks of a bundled random string — each uniformly distributed, +which is what `hblk` asks and what `CubeBlocks` supplies — every self-corrected +read returns the codeword's value, except with probability `2kε`. + +Parameterising by the block maps keeps this independent of how many reads the +tester makes and how the string is carved up. -/ +theorem prob_all_reads {m k : ℕ} (f : BooleanFunction n) (hf : IsBooleanValued f) + (S : Finset (Fin n)) {ε : ℝ} (hclose : IsClose f (χ S) ε) + (blk : Fin k → Cube m → Cube n) + (hblk : ∀ (i : Fin k) (P : Cube n → Prop), + Pr[fun z : Cube m => P (blk i z)] = Pr[P]) + (pts : Fin k → Cube n) : + 1 - k * (2 * ε) ≤ Pr[fun z : Cube m => + ∀ i, f (blk i z) * f (pts i + blk i z) = (χ S) (pts i)] := by + classical + refine prob_forall_ge k + (fun i z => f (blk i z) * f (pts i + blk i z) = (χ S) (pts i)) (2 * ε) fun i => ?_ + have hmarg : Pr[fun z : Cube m => f (blk i z) * f (pts i + blk i z) = (χ S) (pts i)] + = Pr[fun y : Cube n => f y * f (pts i + y) = (χ S) (pts i)] := + hblk i (fun y => f y * f (pts i + y) = (χ S) (pts i)) + rw [hmarg] + exact local_correctability f hf S hclose (pts i) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/HadamardTester.lean b/Complexitylib/Classes/PCP/Internal/HadamardTester.lean new file mode 100644 index 00000000..fd9d0576 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/HadamardTester.lean @@ -0,0 +1,363 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Hadamard + +/-! +# The Hadamard tester, as it actually runs + +`Complexitylib.Classes.PCP.Internal.Hadamard` analyses the tester at the +*decoded* level: its statements are about the codewords `hadamard a` and +`hadamard b` that the two proof tables are supposed to be. A tester cannot read +those. It reads the tables it is given, which are only *close* to codewords, and +it recovers codeword values by self-correction — reading two nearby entries and +multiplying. + +This module closes that gap. The tester's whole random string is one point of a +bundled cube (`CubeBlocks`): the first block picks the two query points, and the +remaining blocks supply one correction string per read. Every read is then +correct except with probability `2ε`, the failures are collected by a union +bound, and `prob_le_of_imp_of_good` transfers the observed acceptance +probability to the decoded check that `Hadamard` already knows how to use. + +The one wrinkle is that the consistency check is *bilinear over `𝔽₂`*, not +multiplicative on signs: `⟨a ⊗ a, x ⊗ y⟩ = ⟨a, x⟩ · ⟨a, y⟩` is a product of +bits, and `chi` does not carry products of bits to products of signs. So the +reads' `±1` answers are converted back to bits by `signBit` before being +compared, which is exactly how the check is stated in the literature. + +## Main definitions + +- `Complexity.signBit` — the bit a `±1` answer stands for +- `Complexity.TesterAccepts` — the tester's check on the raw tables +- `Complexity.ReadsCorrect` — the event that every self-corrected read is right + +## Main results + +- `Complexity.prob_reads_correct` — every read is right except with + probability `4ε + 2ε'` +- `Complexity.prob_testerAccepts_of_honest` — completeness: the honest proof + is accepted always +- `Complexity.sat_of_prob_tester` — **soundness of the tester as it runs**: if + the raw tables are close to codewords and the raw check passes often enough, + the decoded assignment satisfies the constraint +- `Complexity.exists_sat_of_prob_tester` — the same with *nothing* assumed + about the proof: BLR supplies the closeness +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +variable {n : ℕ} + +/-! ### Reading a sign as a bit -/ + +/-- The bit a `±1` answer stands for. -/ +noncomputable def signBit (r : ℝ) : ZMod 2 := if r = 1 then 0 else 1 + +/-- Signs and bits correspond: `signBit` inverts `chi`. -/ +theorem signBit_chi (u : ZMod 2) : signBit (chi u) = u := by + rcases (by decide : ∀ u : ZMod 2, u = 0 ∨ u = 1) u with h | h <;> subst h + · norm_num [signBit, BooleanAnalysis.chi] + · norm_num [signBit, BooleanAnalysis.chi] + +/-- **A self-corrected read is right.** The decoded-level restatement of +`local_correctability`: the value returned is the codeword's bit, read as a +sign. -/ +theorem prob_read_ge {m : ℕ} (f : BooleanFunction m) (hf : IsBooleanValued f) + (a : Cube m) {ε : ℝ} (hc : IsClose f (signOf (hadamard a)) ε) (x : Cube m) : + 1 - 2 * ε ≤ Pr[fun r : Cube m => f r * f (x + r) = chi (hadamard a x)] := by + classical + have hS : IsClose f (χ (Finset.univ.filter fun i => a i = 1)) ε := by + rwa [← signOf_hadamard] + have heq : (χ (Finset.univ.filter fun i => a i = 1)) x = chi (hadamard a x) := by + rw [← signOf_hadamard] + rfl + have h := local_correctability f hf (Finset.univ.filter fun i => a i = 1) hS x + rw [heq] at h + exact h + +/-! ### The tester -/ + +/-- The first query point: the second half of the query block. -/ +def qX (z : Cube ((n + n) + (n + (n + n * n)))) : Cube n := rightBlock (leftBlock z) + +/-- The second query point: the first half of the query block. -/ +def qY (z : Cube ((n + n) + (n + (n + n * n)))) : Cube n := leftBlock (leftBlock z) + +/-- The correction string for the first read of the linear table. -/ +def cX (z : Cube ((n + n) + (n + (n + n * n)))) : Cube n := leftBlock (rightBlock z) + +/-- The correction string for the second read of the linear table. -/ +def cY (z : Cube ((n + n) + (n + (n + n * n)))) : Cube n := + leftBlock (rightBlock (rightBlock z)) + +/-- The correction string for the read of the quadratic table. -/ +def cQ (z : Cube ((n + n) + (n + (n + n * n)))) : Cube (n * n) := + rightBlock (rightBlock (rightBlock z)) + +/-- **The tester's check**, made on the raw tables: the self-corrected value of +the quadratic table at `x ⊗ y` must be the product, as bits, of the +self-corrected values of the linear table at `x` and at `y`. -/ +def TesterAccepts (f : BooleanFunction n) (g : BooleanFunction (n * n)) + (z : Cube ((n + n) + (n + (n + n * n)))) : Prop := + signBit (g (cQ z) * g (tensor (qX z) (qY z) + cQ z)) + = signBit (f (cX z) * f (qX z + cX z)) * signBit (f (cY z) * f (qY z + cY z)) + +/-- The event that all three self-corrected reads return the codeword's value. -/ +def ReadsCorrect (a : Cube n) (b : Cube (n * n)) (f : BooleanFunction n) + (g : BooleanFunction (n * n)) (z : Cube ((n + n) + (n + (n + n * n)))) : Prop := + f (cX z) * f (qX z + cX z) = chi (hadamard a (qX z)) + ∧ f (cY z) * f (qY z + cY z) = chi (hadamard a (qY z)) + ∧ g (cQ z) * g (tensor (qX z) (qY z) + cQ z) + = chi (hadamard b (tensor (qX z) (qY z))) + +/-- **Every read is right, at once.** The query points are chosen by the first +block and the corrections by the rest, so `prob_blocks_ge` fixes the points +before the corrections are drawn and the three failure probabilities simply +add. -/ +theorem prob_reads_correct (a : Cube n) (b : Cube (n * n)) + (f : BooleanFunction n) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε' : ℝ} + (hgc : IsClose g (signOf (hadamard b)) ε') : + 1 - (4 * ε + 2 * ε') ≤ Pr[ReadsCorrect a b f g] := by + classical + have hsplit : (1 : ℝ) - (4 * ε + 2 * ε') = 1 - (2 * ε + (2 * ε + 2 * ε')) := by ring + rw [hsplit] + refine prob_blocks_ge (fun u w => + f (leftBlock w) * f (rightBlock u + leftBlock w) = chi (hadamard a (rightBlock u)) + ∧ f (leftBlock (rightBlock w)) * f (leftBlock u + leftBlock (rightBlock w)) + = chi (hadamard a (leftBlock u)) + ∧ g (rightBlock (rightBlock w)) + * g (tensor (rightBlock u) (leftBlock u) + rightBlock (rightBlock w)) + = chi (hadamard b (tensor (rightBlock u) (leftBlock u)))) _ fun u => ?_ + · refine prob_and_ge ?_ (prob_and_ge ?_ ?_) + · have h : Pr[fun w : Cube (n + (n + n * n)) => + f (leftBlock w) * f (rightBlock u + leftBlock w) + = chi (hadamard a (rightBlock u))] + = Pr[fun r : Cube n => + f r * f (rightBlock u + r) = chi (hadamard a (rightBlock u))] := + prob_leftBlock (fun r : Cube n => + f r * f (rightBlock u + r) = chi (hadamard a (rightBlock u))) + rw [h] + exact prob_read_ge f hf a hfc (rightBlock u) + · have h : Pr[fun w : Cube (n + (n + n * n)) => + f (leftBlock (rightBlock w)) * f (leftBlock u + leftBlock (rightBlock w)) + = chi (hadamard a (leftBlock u))] + = Pr[fun r : Cube n => + f r * f (leftBlock u + r) = chi (hadamard a (leftBlock u))] := + prob_leftBlock_rightBlock (fun r : Cube n => + f r * f (leftBlock u + r) = chi (hadamard a (leftBlock u))) + rw [h] + exact prob_read_ge f hf a hfc (leftBlock u) + · have h : Pr[fun w : Cube (n + (n + n * n)) => + g (rightBlock (rightBlock w)) + * g (tensor (rightBlock u) (leftBlock u) + rightBlock (rightBlock w)) + = chi (hadamard b (tensor (rightBlock u) (leftBlock u)))] + = Pr[fun r : Cube (n * n) => + g r * g (tensor (rightBlock u) (leftBlock u) + r) + = chi (hadamard b (tensor (rightBlock u) (leftBlock u)))] := + prob_rightBlock_rightBlock (fun r : Cube (n * n) => + g r * g (tensor (rightBlock u) (leftBlock u) + r) + = chi (hadamard b (tensor (rightBlock u) (leftBlock u)))) + rw [h] + exact prob_read_ge g hg b hgc (tensor (rightBlock u) (leftBlock u)) + +/-- **Consistency forces the tensor, on raw tables.** The consistency check +passing often enough on tables close to codewords forces the quadratic codeword +to be the tensor square of the linear one. -/ +theorem eq_tensorAssign_of_prob_tester (a : Cube n) (b : Cube (n * n)) + (f : BooleanFunction n) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε' : ℝ} + (hgc : IsClose g (signOf (hadamard b)) ε') + (haccept : 3 / 4 + (4 * ε + 2 * ε') < Pr[TesterAccepts f g]) : + b = tensorAssign a := by + classical + have hgood := prob_reads_correct a b f hf hfc g hg hgc + have htrans := prob_le_of_imp_of_good (E := TesterAccepts f g) + (F := fun z : Cube ((n + n) + (n + (n + n * n))) => + hadamard b (tensor (rightBlock (leftBlock z)) (leftBlock (leftBlock z))) + = hadamard a (rightBlock (leftBlock z)) * hadamard a (leftBlock (leftBlock z))) + (A := ReadsCorrect a b f g) fun z hE hA => by + have hE' : signBit (chi (hadamard b (tensor (qX z) (qY z)))) + = signBit (chi (hadamard a (qX z))) * signBit (chi (hadamard a (qY z))) := by + rw [← hA.1, ← hA.2.1, ← hA.2.2] + exact hE + rw [signBit_chi, signBit_chi, signBit_chi] at hE' + exact hE' + have hpair : Pr[fun z : Cube ((n + n) + (n + (n + n * n))) => + hadamard b (tensor (rightBlock (leftBlock z)) (leftBlock (leftBlock z))) + = hadamard a (rightBlock (leftBlock z)) * hadamard a (leftBlock (leftBlock z))] + = Pr₂[fun y x => hadamard b (tensor x y) = hadamard a x * hadamard a y] := + prob_pair_block (fun y x => hadamard b (tensor x y) = hadamard a x * hadamard a y) + rw [hpair] at htrans + exact eq_tensorAssign_of_prob_consistent a b (by linarith) + +/-- **Soundness of the tester as it runs.** Raw tables close to Hadamard +codewords, a raw check passing on more than three quarters of the randomness +(with room for the reads' failure probability), and a constraint satisfied by +the decoded tables together force the decoded assignment to satisfy the +constraint. + +The gap `4ε + 2ε'` is the price of self-correction: three reads, each wrong +with probability at most twice the table's distance from its codeword. -/ +theorem sat_of_prob_tester (a : Cube n) (b : Cube (n * n)) (C : QuadConstraint n) + (f : BooleanFunction n) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε' : ℝ} + (hgc : IsClose g (signOf (hadamard b)) ε') + (haccept : 3 / 4 + (4 * ε + 2 * ε') < Pr[TesterAccepts f g]) + (hcheck : checkValue (hadamard b) (hadamard a) C = 0) : + C.Sat a := by + have hb := eq_tensorAssign_of_prob_tester a b f hf hfc g hg hgc haccept + rw [hb] at hcheck + exact hcheck + +/-! ### Completeness -/ + +/-- A Hadamard codeword is linear in the query point. -/ +theorem hadamard_add_right {m : ℕ} (a x r : Cube m) : + hadamard a (x + r) = hadamard a x + hadamard a r := by + show ∑ i, a i * (x i + r i) = (∑ i, a i * x i) + (∑ i, a i * r i) + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun i _ => by ring + +/-- **Self-correction is exact on an honest table.** The two reads are +`chi ⟨a, r⟩` and `chi (⟨a, x⟩ + ⟨a, r⟩)`, and their product telescopes because +`chi` turns the `𝔽₂` sum into a product of signs and `2⟨a, r⟩ = 0`. -/ +theorem corrected_read_honest {m : ℕ} (a x r : Cube m) : + signOf (hadamard a) r * signOf (hadamard a) (x + r) = chi (hadamard a x) := by + show chi (hadamard a r) * chi (hadamard a (x + r)) = chi (hadamard a x) + rw [hadamard_add_right, ← BooleanAnalysis.Internal.chi_add] + congr 1 + have h2 : hadamard a r + hadamard a r = 0 := by + rcases (by decide : ∀ u : ZMod 2, u + u = 0) (hadamard a r) with h + exact h + calc hadamard a r + (hadamard a x + hadamard a r) + = hadamard a x + (hadamard a r + hadamard a r) := by ring + _ = hadamard a x := by rw [h2, add_zero] + +/-- **The honest proof passes every read.** -/ +theorem readsCorrect_of_honest (a : Cube n) (z : Cube ((n + n) + (n + (n + n * n)))) : + ReadsCorrect a (tensorAssign a) (signOf (hadamard a)) + (signOf (hadamard (tensorAssign a))) z := + ⟨corrected_read_honest a (qX z) (cX z), corrected_read_honest a (qY z) (cY z), + corrected_read_honest (tensorAssign a) (tensor (qX z) (qY z)) (cQ z)⟩ + +/-- **Completeness of the tester as it runs.** The honest proof — the Hadamard +encoding of an assignment together with the encoding of its tensor square — is +accepted on every random string, so with probability one. -/ +theorem testerAccepts_of_honest (a : Cube n) (z : Cube ((n + n) + (n + (n + n * n)))) : + TesterAccepts (signOf (hadamard a)) (signOf (hadamard (tensorAssign a))) z := by + have hr := readsCorrect_of_honest a z + show signBit (signOf (hadamard (tensorAssign a)) (cQ z) + * signOf (hadamard (tensorAssign a)) (tensor (qX z) (qY z) + cQ z)) = _ + rw [hr.1, hr.2.1, hr.2.2, signBit_chi, signBit_chi, signBit_chi] + exact hadamard_tensor a (qX z) (qY z) + +/-- The honest proof is accepted with probability one. -/ +theorem prob_testerAccepts_of_honest (a : Cube n) : + Pr[TesterAccepts (signOf (hadamard a)) (signOf (hadamard (tensorAssign a)))] = 1 := + prob_of_forall (testerAccepts_of_honest a) + +/-! ### The constraint check -/ + +/-- **The tester's constraint check**, made on the raw tables: the constraint's +quadratic part is read from `g`, its linear part from `f`, both by +self-correction, and the two bits plus the constant must cancel. -/ +def ConstraintAccepts (f : BooleanFunction n) (g : BooleanFunction (n * n)) + (C : QuadConstraint n) (z : Cube (n + n * n)) : Prop := + signBit (g (rightBlock z) * g (C.quad + rightBlock z)) + + signBit (f (leftBlock z) * f (C.lin + leftBlock z)) + C.const = 0 + +/-- Both reads of the constraint check are right except with probability +`2ε + 2ε'`. -/ +theorem prob_constraint_reads (a : Cube n) (b : Cube (n * n)) (C : QuadConstraint n) + (f : BooleanFunction n) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε' : ℝ} + (hgc : IsClose g (signOf (hadamard b)) ε') : + 1 - (2 * ε + 2 * ε') ≤ Pr[fun z : Cube (n + n * n) => + f (leftBlock z) * f (C.lin + leftBlock z) = chi (hadamard a C.lin) + ∧ g (rightBlock z) * g (C.quad + rightBlock z) = chi (hadamard b C.quad)] := by + classical + refine prob_and_ge ?_ ?_ + · have h : Pr[fun z : Cube (n + n * n) => + f (leftBlock z) * f (C.lin + leftBlock z) = chi (hadamard a C.lin)] + = Pr[fun r : Cube n => f r * f (C.lin + r) = chi (hadamard a C.lin)] := + prob_leftBlock (fun r : Cube n => f r * f (C.lin + r) = chi (hadamard a C.lin)) + rw [h] + exact prob_read_ge f hf a hfc C.lin + · have h : Pr[fun z : Cube (n + n * n) => + g (rightBlock z) * g (C.quad + rightBlock z) = chi (hadamard b C.quad)] + = Pr[fun r : Cube (n * n) => g r * g (C.quad + r) = chi (hadamard b C.quad)] := + prob_rightBlock (fun r : Cube (n * n) => + g r * g (C.quad + r) = chi (hadamard b C.quad)) + rw [h] + exact prob_read_ge g hg b hgc C.quad + +/-- **The constraint check is decisive.** Its conclusion — that the decoded +tables satisfy the constraint — does not depend on the randomness, so it is +enough that *some* random string both passes the check and has correct reads. +That happens as soon as the check passes more often than the reads fail. -/ +theorem checkValue_eq_zero_of_prob (a : Cube n) (b : Cube (n * n)) (C : QuadConstraint n) + (f : BooleanFunction n) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε' : ℝ} + (hgc : IsClose g (signOf (hadamard b)) ε') + (hprob : 2 * ε + 2 * ε' < Pr[ConstraintAccepts f g C]) : + checkValue (hadamard b) (hadamard a) C = 0 := by + classical + have hreads := prob_constraint_reads a b C f hf hfc g hg hgc + have hboth : 0 < Pr[fun z : Cube (n + n * n) => ConstraintAccepts f g C z + ∧ (f (leftBlock z) * f (C.lin + leftBlock z) = chi (hadamard a C.lin) + ∧ g (rightBlock z) * g (C.quad + rightBlock z) = chi (hadamard b C.quad))] := by + have := prob_and_ge (P := ConstraintAccepts f g C) + (Q := fun z : Cube (n + n * n) => + f (leftBlock z) * f (C.lin + leftBlock z) = chi (hadamard a C.lin) + ∧ g (rightBlock z) * g (C.quad + rightBlock z) = chi (hadamard b C.quad)) + (p := 1 - Pr[ConstraintAccepts f g C]) (q := 2 * ε + 2 * ε') + (by linarith) hreads + linarith + obtain ⟨z, haccept, hleft, hright⟩ := exists_of_prob_pos hboth + have h : signBit (chi (hadamard b C.quad)) + signBit (chi (hadamard a C.lin)) + + C.const = 0 := by + rw [← hleft, ← hright] + exact haccept + rw [signBit_chi, signBit_chi] at h + exact h + +/-! ### Soundness with nothing assumed about the proof -/ + +/-- **The Hadamard assignment tester is sound.** Nothing is assumed about the +two tables: linearity is what the BLR test establishes, and the assignment is +what its soundness decodes. A proof passing all three tests often enough +certifies that the constraint is satisfiable. + +This is the inner verifier Dinur's alphabet-reduction step composes with: its +proof length and query count do not depend on the outer system at all, only on +the constant-size constraint being checked. -/ +theorem exists_sat_of_prob_tester (C : QuadConstraint n) + (f : BooleanFunction n) (hf : IsBooleanValued f) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε ε' : ℝ} + (hblrf : blrAcceptProb f ≥ 1 - ε) (hblrg : blrAcceptProb g ≥ 1 - ε') + (hcons : 3 / 4 + (4 * ε + 2 * ε') < Pr[TesterAccepts f g]) + (hchk : 2 * ε + 2 * ε' < Pr[ConstraintAccepts f g C]) : + ∃ a : Cube n, C.Sat a := by + classical + obtain ⟨a, ha⟩ := exists_assignment_of_blr f hf ε hblrf + obtain ⟨b, hb⟩ := exists_assignment_of_blr g hg ε' hblrg + have hfc : IsClose f (signOf (hadamard a)) ε := ha + have hgc : IsClose g (signOf (hadamard b)) ε' := hb + exact ⟨a, sat_of_prob_tester a b C f hf hfc g hg hgc hcons + (checkValue_eq_zero_of_prob a b C f hf hfc g hg hgc hchk)⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/KilledCSP.lean b/Complexitylib/Classes/PCP/Internal/KilledCSP.lean new file mode 100644 index 00000000..f22dc2ba --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/KilledCSP.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.KilledWalk +public import Complexitylib.Classes.PCP.Internal.NumEncPi +public import Complexitylib.Classes.PCP.Internal.RegCSP + +/-! +# Powering a constraint system along killed walks + +Dinur's gap amplification, over the walk law of `KilledWalk`. The vertices are +unchanged; the constraints are indexed by killed walks, and the alphabet is +*opinions* — but now indexed by walks of **any** length up to `T`, so that no +padding is ever needed. + +## Opinions + +A label at `v` is a function `VarWalk G T → α`: for every walk out of `v` of +length at most `T`, a claim about the label of its endpoint. The index type is +finite of size `∑_{ℓ ≤ T} deg ^ ℓ`, so the alphabet stays a constant +`|α| ^ (∑_{ℓ ≤ T} deg ^ ℓ)`, independent of the number of vertices — which is +what makes the alphabet-reduction step afterwards possible. + +Variable-length indices are the point of the redesign. With the fixed-length +indices of `PowerCSP`, a short prefix had to be padded out with self-loops, and +the padded indices formed a vanishing sub-cube that the plurality bound could +not see; that module's docstring records why this sinks soundness there. + +## The constraint + +On a killed walk `(v, x)` with effective length `ℓ`, **every** step `i < ℓ` is +checked — no window is needed, since the start's opinion reaches `v i` through +the walk's own first `i` steps and the end's reaches `v (i+1)` through the +reversed walk's first `ℓ - (i+1)` steps. Both indices are genuine walks, of the +exact lengths the walk itself provides. + +## Main definitions + +- `VarWalk`, `KOpinion` — short walks, and the alphabet of opinions about them +- `RegGraph.startIdx`, `RegGraph.endIdx` — the two indices a step is read at +- `RegCSP.killedPow` — the powered system +- `RegCSP.kTruthful` — the opinion assignment induced by an assignment of `R` + +## Main results + +- `RegGraph.walkEnd_startIdx`, `RegGraph.walkEnd_endIdx` — the two indices name + the two ends of the `i`-th dart +- `RegCSP.rel_killedPow_iff` — the constraint, unfolded +- `RegCSP.satisfiable_killedPow_of_satisfiable` — perfect completeness +- `RegCSP.not_satisfies_killedPow_of_faulty` — the soundness witness: a failed + step with truthful opinions at both ends breaks the constraint +-/ + +@[expose] public section + +namespace Complexity + +/-- A walk out of a vertex, of any length up to `T`. -/ +abbrev VarWalk (G : RegGraph) (T : ℕ) : Type := Σ ℓ : Fin (T + 1), Fin ℓ.val → G.D + +/-- A label of the killed power: a claim about the endpoint of every walk of +length at most `T` out of the vertex. -/ +abbrev KOpinion (G : RegGraph) (T : ℕ) (α : Type) : Type := VarWalk G T → α + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### The two indices a step is read at -/ + +/-- Where the start of a killed walk holds its opinion about the walk's `i`-th +vertex: at the walk's own first `i` steps. -/ +def startIdx {T ℓ : ℕ} (hℓ : ℓ ≤ T) (w : Fin ℓ → G.D) (i : Fin ℓ) : VarWalk G T := + ⟨⟨i.val, by have := i.isLt; omega⟩, fun j => w (Fin.castLE (le_of_lt i.isLt) j)⟩ + +/-- Where the end of a killed walk holds its opinion about the walk's +`(i+1)`-st vertex: at the reversed walk's first `ℓ - (i+1)` steps. -/ +def endIdx {T ℓ : ℕ} (hℓ : ℓ ≤ T) (v : G.V) (w : Fin ℓ → G.D) (i : Fin ℓ) : VarWalk G T := + ⟨⟨ℓ - (i.val + 1), by have := i.isLt; omega⟩, + fun j : Fin (ℓ - (i.val + 1)) => G.revWalk v w ⟨j.val, by have := j.isLt; omega⟩⟩ + +/-- The start's index names the `i`-th vertex of the walk. -/ +theorem walkEnd_startIdx {T ℓ : ℕ} (hℓ : ℓ ≤ T) (v : G.V) (w : Fin ℓ → G.D) (i : Fin ℓ) : + G.walkEnd (G.startIdx hℓ w i).1.val v (G.startIdx hℓ w i).2 = G.walkAt ℓ v w i.val := by + rw [G.walkAt_eq_walkEnd_prefix v w i.val (le_of_lt i.isLt)] + rfl + +/-- The end's index names the `(i+1)`-st vertex of the walk. -/ +theorem walkEnd_endIdx {T ℓ : ℕ} (hℓ : ℓ ≤ T) (v : G.V) (w : Fin ℓ → G.D) (i : Fin ℓ) : + G.walkEnd (G.endIdx hℓ v w i).1.val (G.walkEnd ℓ v w) (G.endIdx hℓ v w i).2 + = G.walkAt ℓ v w (i.val + 1) := by + have hle : ℓ - (i.val + 1) ≤ ℓ := by omega + have key : G.walkAt ℓ (G.walkEnd ℓ v w) (G.revWalk v w) (ℓ - (i.val + 1)) + = G.walkAt ℓ v w (i.val + 1) := by + rw [G.walkAt_revWalk v w _ hle] + congr 1 + have := i.isLt + omega + rw [← key, G.walkAt_eq_walkEnd_prefix (G.walkEnd ℓ v w) (G.revWalk v w) _ hle] + rfl + +/-! ### The effective data of a killed dart -/ + +/-- The effective length of a killed dart. -/ +def kLen {T q : ℕ} (x : (Fin T → G.D) × (Fin T → Fin q)) : ℕ := stopAt x.2 + +theorem kLen_le {T q : ℕ} (x : (Fin T → G.D) × (Fin T → Fin q)) : G.kLen x ≤ T := + stopAt_le x.2 + +/-- The effective walk of a killed dart. -/ +def kWalk {T q : ℕ} (x : (Fin T → G.D) × (Fin T → Fin q)) : Fin (G.kLen x) → G.D := + G.preWalk x.1 (stopAt_le x.2) + +theorem killedEnd_eq {T q : ℕ} (v : G.V) (x : (Fin T → G.D) × (Fin T → Fin q)) : + G.killedEnd v x.1 x.2 = G.walkEnd (G.kLen x) v (G.kWalk x) := rfl + +end RegGraph + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) (q T : ℕ) (hq : 0 < q) + +/-- The killed power of a constraint system: one constraint per killed walk, +checking `R`'s constraint at every step of the effective walk, between the +opinions the two ends hold about that step's two vertices. -/ +def killedPow (R : RegCSP α) (q T : ℕ) (hq : 0 < q) : RegCSP (KOpinion R.graph T α) where + graph := R.graph.killedPower q T hq + rel v x a b := + decide (∀ i : Fin (R.graph.kLen x), + R.rel (R.graph.walkAt (R.graph.kLen x) v (R.graph.kWalk x) i.val) (R.graph.kWalk x i) + (a (R.graph.startIdx (R.graph.kLen_le x) (R.graph.kWalk x) i)) + (b (R.graph.endIdx (R.graph.kLen_le x) v (R.graph.kWalk x) i)) = true) + +@[simp] theorem graph_killedPow : + (R.killedPow q T hq).graph = R.graph.killedPower q T hq := rfl + +/-- Powering leaves the vertices alone, so they keep their numbering. -/ +noncomputable instance [NumEnc R.graph.V] : NumEnc (R.killedPow q T hq).graph.V := + inferInstanceAs (NumEnc R.graph.V) + +/-- A killed walk is a tuple of darts and a tuple of coins; both are numbered +digit by digit, so an algorithm can read the walk off. -/ +noncomputable instance [NumEnc R.graph.D] : NumEnc (R.killedPow q T hq).graph.D := + inferInstanceAs (NumEnc ((Fin T → R.graph.D) × (Fin T → Fin q))) + +theorem rel_killedPow_iff (v : R.graph.V) (x : (Fin T → R.graph.D) × (Fin T → Fin q)) + (a b : KOpinion R.graph T α) : + (R.killedPow q T hq).rel v x a b = true + ↔ ∀ i : Fin (R.graph.kLen x), + R.rel (R.graph.walkAt (R.graph.kLen x) v (R.graph.kWalk x) i.val) (R.graph.kWalk x i) + (a (R.graph.startIdx (R.graph.kLen_le x) (R.graph.kWalk x) i)) + (b (R.graph.endIdx (R.graph.kLen_le x) v (R.graph.kWalk x) i)) = true := by + exact decide_eq_true_iff + +/-! ### Completeness -/ + +/-- The opinion assignment induced by an assignment of `R`: every claim is the +truth. -/ +def kTruthful (σ : R.Assignment) : (R.killedPow q T hq).Assignment := + fun v w => σ (R.graph.walkEnd w.1.val v w.2) + +/-- A satisfying assignment of `R` makes every killed-walk constraint hold. -/ +theorem satisfies_killedPow_truthful {σ : R.Assignment} (hσ : ∀ p, R.Satisfies σ p) + (x : (R.killedPow q T hq).Dart) : + (R.killedPow q T hq).Satisfies (R.kTruthful q T hq σ) x := by + obtain ⟨v, y⟩ := x + rw [Satisfies, satisfies] + dsimp only + rw [show (R.killedPow q T hq).graph.nbr v y = R.graph.killedEnd v y.1 y.2 from rfl] + rw [rel_killedPow_iff] + intro i + have hstart : R.kTruthful q T hq σ v + (R.graph.startIdx (R.graph.kLen_le y) (R.graph.kWalk y) i) + = σ (R.graph.walkAt (R.graph.kLen y) v (R.graph.kWalk y) i.val) := by + rw [kTruthful] + exact congrArg σ (R.graph.walkEnd_startIdx (R.graph.kLen_le y) v (R.graph.kWalk y) i) + have hend : R.kTruthful q T hq σ (R.graph.killedEnd v y.1 y.2) + (R.graph.endIdx (R.graph.kLen_le y) v (R.graph.kWalk y) i) + = σ (R.graph.walkAt (R.graph.kLen y) v (R.graph.kWalk y) (i.val + 1)) := by + rw [kTruthful, R.graph.killedEnd_eq] + exact congrArg σ (R.graph.walkEnd_endIdx (R.graph.kLen_le y) v (R.graph.kWalk y) i) + rw [hstart, hend] + have hdart := hσ (R.graph.walkAt (R.graph.kLen y) v (R.graph.kWalk y) i.val, + R.graph.kWalk y i) + rw [Satisfies, satisfies] at hdart + dsimp only at hdart + rw [← R.graph.walkAt_succ_of_lt v (R.graph.kWalk y) i.isLt] at hdart + exact hdart + +/-- **Perfect completeness.** -/ +theorem satisfiable_killedPow_of_satisfiable (hR : R.Satisfiable) : + (R.killedPow q T hq).Satisfiable := by + obtain ⟨σ, hσ⟩ := hR + exact ⟨R.kTruthful q T hq σ, fun x => R.satisfies_killedPow_truthful q T hq hσ x⟩ + +/-! ### The soundness witness -/ + +/-- A step of the effective walk that `σ` fails, whose two vertices both ends +have truthful opinions about, breaks the killed walk's constraint. This is the +shape every soundness count is built from. -/ +theorem not_satisfies_killedPow_of_faulty {σ : R.Assignment} + (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (y : (Fin T → R.graph.D) × (Fin T → Fin q)) (i : Fin (R.graph.kLen y)) + (hfault : ¬ R.Satisfies σ + (R.graph.walkAt (R.graph.kLen y) v (R.graph.kWalk y) i.val, R.graph.kWalk y i)) + (htruth₁ : A v (R.graph.startIdx (R.graph.kLen_le y) (R.graph.kWalk y) i) + = σ (R.graph.walkAt (R.graph.kLen y) v (R.graph.kWalk y) i.val)) + (htruth₂ : A (R.graph.killedEnd v y.1 y.2) + (R.graph.endIdx (R.graph.kLen_le y) v (R.graph.kWalk y) i) + = σ (R.graph.walkAt (R.graph.kLen y) v (R.graph.kWalk y) (i.val + 1))) : + ¬ (R.killedPow q T hq).Satisfies A (v, y) := by + intro hsat + rw [Satisfies, satisfies] at hsat + dsimp only at hsat + rw [show (R.killedPow q T hq).graph.nbr v y = R.graph.killedEnd v y.1 y.2 from rfl, + rel_killedPow_iff] at hsat + have hi := hsat i + rw [htruth₁, htruth₂] at hi + rw [Satisfies, satisfies] at hfault + dsimp only at hfault + rw [← R.graph.walkAt_succ_of_lt v (R.graph.kWalk y) i.isLt] at hfault + exact hfault hi + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean b/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean new file mode 100644 index 00000000..2c879bd4 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean @@ -0,0 +1,1235 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.KilledPlurality +public import Complexitylib.Classes.PCP.Internal.WalkSplit +public import Complexitylib.Classes.PCP.Internal.DartCorrelation +public import Complexitylib.Classes.PCP.Internal.SecondMoment +public import Mathlib.Algebra.BigOperators.Intervals + +/-! +# The first moment of Dinur's powering step + +Counting, for a fixed faulty dart of `R` and a fixed crossing position, the +killed-power constraints that the dart breaks — those whose walk crosses it and +whose two ends both hold the decoded opinion about the dart's endpoints. + +`WalkSplit.card_label_crossing` already counts such labels as +`(prefix count) * (suffix count) * (fibre weight)`, for *arbitrary* conditions +on the two pieces. Here the conditions are the ones the powered constraint +actually reads, and then each count is by definition a `truthCount` — the +quantity `KilledPlurality.card_le_mul_sum_truthCount` bounds from below. + +That is the whole point of the killed walk law: the prefix and suffix conditions +concern different vertices and *independent* lengths, so summing over both +positions multiplies two plurality bounds instead of entangling them. + +## Main results + +- `RegCSP.opinionOf_eq_startIdx`, `RegCSP.opinionOf_eq_endIdx` — the counted + conditions are the constraint's own two terms +- `RegCSP.card_good_crossing` — the count, as a product of two `truthCount`s and + the fibre weight +- `RegCSP.not_satisfies_of_good_crossing` — every counted crossing breaks its + constraint +- `weight_factor` — the crossing weight is the product of the two plurality + weights, up to a fixed normaliser +- `sum_crossing_factor`, `sum_goodCount_factor` — hence the double sum over + positions is a product of two weighted sums +- `geom_tail_le`, `RegCSP.truthCount_le` — the discarded positions carry + geometrically little weight +- `RegCSP.card_le_mul_sum_truthCount_half` — plurality survives the restriction + to half the range +- `RegCSP.card_good_crossing_sq` — the count indexed by the two lengths +- `RegCSP.halfSum`, `pluralityLoss`, `RegCSP.per_dart_lower` — the first moment + for a single dart of `R` +- `RegCSP.sum_dart_lower` — summed over all the failed darts +- `RegCSP.goodCrossings`, `RegCSP.mem_unsatDarts_of_goodCrossings_nonempty` — the + count the second-moment method uses, and its support condition +- `RegCSP.sum_sq_goodCrossings` — its second moment, as a sum over pairs +- `RegCSP.goodPos`, `RegCSP.card_pairs_goodPos` — the same positions indexed by + naturals, so summation order can be exchanged +- `RegCSP.sum_card_pairs_eq` — that exchange, carried out +- `RegCSP.card_both_good_le` — two good crossings imply two failed crossings of + the underlying walk +- `RegCSP.sum_pairs_bound` — the second moment's pair term, bounded +- `RegCSP.sum_sq_goodCrossings_le` — the second moment of the crossing count +- `RegCSP.sum_card_goodPos_eq` — the first moment, with counting exchanged +- `RegCSP.sum_over_len_le` — summing over effective lengths stays within the + constraints good at a position +- `RegCSP.mem_goodPos_of_crossing` — a counted crossing of a failed dart is a + good position +- `RegCSP.crossingSet`, `RegCSP.sum_crossingSet_le` — the counted sets, and that + different darts contribute disjointly +- `RegCSP.sum_len_pos_le`, `RegCSP.sum_Cd_le_sum_goodCrossings` — the first + moment is bounded by the total crossing count +- `RegCSP.crossCount`, `RegCSP.sum_goodCrossings_ge` — the first moment in closed + form +- `RegCSP.card_unsatDarts_ge` — the second-moment bound on unsatisfied + constraints +- `RegCSP.powering_soundness` — soundness of the killed powering step +- `RegCSP.unsatFrac_killedPow_ge`, `RegCSP.le_unsatVal_killedPow` — the same + bound on the unsatisfied fraction, and on the value +-/ + +@[expose] public section + +namespace Complexity + +/-- **The weights factorise.** The fibre weight of a walk of length `i + j + 1` +is, up to the fixed normaliser `deg ^ (T+1) * q ^ T`, the product of the weights +of lengths `i` and `j` times `q - 1`. + +This identity is why the first moment splits: summing a product +`truthCount a i * truthCount b j` against the crossing weight is the same as +multiplying two sums each weighted exactly as the plurality bound weights them. +Geometric weights are what make this work, and geometric weights are what the +killed walk law produces. -/ +theorem weight_factor (deg q : ℕ) {T i j : ℕ} (h : i + j + 1 < T) : + (deg ^ (T - (i + j + 1)) * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1))) + * (deg ^ (T + 1) * q ^ T) + = (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1))) + * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))) * (q - 1) := by + have e1 : deg ^ (T - (i + j + 1)) * deg ^ (T + 1) = deg ^ (T - i) * deg ^ (T - j) := by + rw [← pow_add, ← pow_add] + congr 1 + omega + have e2 : q ^ (T - (i + j + 1) - 1) * q ^ T = q ^ (T - i - 1) * q ^ (T - j - 1) := by + rw [← pow_add, ← pow_add] + congr 1 + omega + have e3 : (q - 1) ^ (i + j + 1) = (q - 1) ^ i * (q - 1) ^ j * (q - 1) := by + rw [pow_add, pow_add, pow_one] + calc (deg ^ (T - (i + j + 1)) * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1))) + * (deg ^ (T + 1) * q ^ T) + = (deg ^ (T - (i + j + 1)) * deg ^ (T + 1)) * (q - 1) ^ (i + j + 1) + * (q ^ (T - (i + j + 1) - 1) * q ^ T) := by ring + _ = (deg ^ (T - i) * deg ^ (T - j)) * ((q - 1) ^ i * (q - 1) ^ j * (q - 1)) + * (q ^ (T - i - 1) * q ^ (T - j - 1)) := by rw [e1, e2, e3] + _ = (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1))) + * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))) * (q - 1) := by ring + +/-- **The double sum factorises.** Over a square of positions small enough that +`i + j + 1` never reaches the truncation `T`, the crossing sum is — up to the +normaliser — `(q-1)` times the product of the two weighted sums that the +plurality bound controls. + +Restricting to a square rather than the full triangle `i + j + 1 < T` is what +makes this an identity: the triangle is not a product region. The tail thrown +away is geometrically small. -/ +theorem sum_crossing_factor (deg q T H : ℕ) (hH : 2 * H + 1 < T) (f g : ℕ → ℕ) : + (∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + f i * g j * (deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) + * (deg ^ (T + 1) * q ^ T) + = (q - 1) * ((∑ i ∈ Finset.range (H + 1), + f i * (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1)))) + * (∑ j ∈ Finset.range (H + 1), + g j * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))))) := by + have key : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), + (f i * g j * (deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) * (deg ^ (T + 1) * q ^ T) + = (q - 1) * ((f i * (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1)))) + * (g j * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))))) := by + intro i hi j hj + simp only [Finset.mem_range] at hi hj + have hij : i + j + 1 < T := by omega + have hw := weight_factor deg q hij + calc (f i * g j * (deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) * (deg ^ (T + 1) * q ^ T) + = f i * g j * ((deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1))) + * (deg ^ (T + 1) * q ^ T)) := by ring + _ = f i * g j * ((deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1))) + * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))) * (q - 1)) := by rw [hw] + _ = (q - 1) * ((f i * (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1)))) + * (g j * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))))) := by ring + calc (∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + f i * g j * (deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) + * (deg ^ (T + 1) * q ^ T) + = ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + ((f i * g j * (deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) + * (deg ^ (T + 1) * q ^ T)) := by + rw [Finset.sum_mul] + exact Finset.sum_congr rfl fun i _ => Finset.sum_mul _ _ _ + _ = ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + ((q - 1) * ((f i * (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1)))) + * (g j * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1)))))) := + Finset.sum_congr rfl fun i hi => Finset.sum_congr rfl fun j hj => key i hi j hj + _ = (q - 1) * ((∑ i ∈ Finset.range (H + 1), + f i * (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1)))) + * (∑ j ∈ Finset.range (H + 1), + g j * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))))) := by + rw [Finset.sum_mul_sum, Finset.mul_sum] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Finset.mul_sum] + +/-- **The geometric tail.** The weights decay geometrically, so the positions +beyond `k` carry at most `(q-1)^k * q^(T-k)` — a `((q-1)/q)^k` fraction of the +total. This is what makes both the truncation term and the restriction to a +square of positions harmless. -/ +theorem geom_tail_le {q : ℕ} (hq : 0 < q) (T : ℕ) : ∀ (n k : ℕ), T - k = n → k ≤ T → + ∑ m ∈ Finset.Ico k T, (q - 1) ^ m * q ^ (T - 1 - m) ≤ (q - 1) ^ k * q ^ (T - k) := by + intro n + induction n with + | zero => + intro k hk hkT + have hkeq : k = T := by omega + subst hkeq + simp + | succ n ih => + intro k hk hkT + have hklt : k < T := by omega + have hrec := ih (k + 1) (by omega) (by omega) + rw [Finset.sum_eq_sum_Ico_succ_bot hklt] + have hstep : (q - 1) ^ k * q ^ (T - 1 - k) + (q - 1) ^ (k + 1) * q ^ (T - (k + 1)) + = (q - 1) ^ k * q ^ (T - k) := by + have hq1 : 1 + (q - 1) = q := by omega + have hidx : T - k = (T - 1 - k) + 1 := by omega + have hidx2 : T - (k + 1) = T - 1 - k := by omega + rw [hidx, hidx2, pow_succ, pow_succ] + calc (q - 1) ^ k * q ^ (T - 1 - k) + (q - 1) ^ k * (q - 1) * q ^ (T - 1 - k) + = (q - 1) ^ k * q ^ (T - 1 - k) * (1 + (q - 1)) := by ring + _ = (q - 1) ^ k * (q ^ (T - 1 - k) * q) := by rw [hq1]; ring + calc (q - 1) ^ k * q ^ (T - 1 - k) + ∑ m ∈ Finset.Ico (k + 1) T, + (q - 1) ^ m * q ^ (T - 1 - m) + ≤ (q - 1) ^ k * q ^ (T - 1 - k) + (q - 1) ^ (k + 1) * q ^ (T - (k + 1)) := + Nat.add_le_add_left hrec _ + _ = (q - 1) ^ k * q ^ (T - k) := hstep + +/-- `sum_crossing_factor` in the form callers can use: the counts are supplied +as an abstract function `C`, since the concrete count at position `(i, j)` is a +`Finset.card` whose very statement needs `i + j + 1 < T`, a fact only available +pointwise inside the sum. -/ +theorem sum_goodCount_factor (deg q T H : ℕ) (hH : 2 * H + 1 < T) (f g : ℕ → ℕ) + (C : ℕ → ℕ → ℕ) + (hC : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), + C i j = f i * g j * (deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) : + (∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), C i j) + * (deg ^ (T + 1) * q ^ T) + = (q - 1) * ((∑ i ∈ Finset.range (H + 1), + f i * (deg ^ (T - i) * ((q - 1) ^ i * q ^ (T - i - 1)))) + * (∑ j ∈ Finset.range (H + 1), + g j * (deg ^ (T - j) * ((q - 1) ^ j * q ^ (T - j - 1))))) := by + rw [Finset.sum_congr rfl fun i hi => Finset.sum_congr rfl fun j hj => hC i hi j hj] + exact sum_crossing_factor deg q T H hH f g + +namespace RegCSP + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] +variable (R : RegCSP α) (q T : ℕ) (hq : 0 < q) + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- The prefix condition counted above is exactly the constraint's own +`startIdx` term: the opinion `v` holds about the walk's `i`-th vertex. -/ +theorem opinionOf_eq_startIdx (A : (R.killedPow q T hq).Assignment) {ℓ : ℕ} + (hℓ : ℓ ≤ T) (v : R.graph.V) (W : Fin ℓ → R.graph.D) (i : Fin ℓ) + (hiT : i.val ≤ T) : + R.opinionOf q T hq A (R.graph.walkAt ℓ v W i.val) hiT + (R.graph.revWalk v (R.graph.segPre W (le_of_lt i.isLt))) + = A v (R.graph.startIdx hℓ W i) := by + have hP : R.graph.walkEnd i.val v (R.graph.segPre W (le_of_lt i.isLt)) + = R.graph.walkAt ℓ v W i.val := + (R.graph.walkAt_eq_walkEnd_prefix v W i.val (le_of_lt i.isLt)).symm + rw [opinionOf, ← hP, R.graph.walkEnd_revWalk, R.graph.revWalk_revWalk] + rfl + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- The suffix condition counted above is exactly the constraint's own `endIdx` +term: the opinion the walk's far end holds about the `(i+1)`-st vertex. -/ +theorem opinionOf_eq_endIdx (A : (R.killedPow q T hq).Assignment) {ℓ : ℕ} + (hℓ : ℓ ≤ T) (v : R.graph.V) (W : Fin ℓ → R.graph.D) (i : Fin ℓ) + (hjT : ℓ - (i.val + 1) ≤ T) : + R.opinionOf q T hq A (R.graph.walkAt ℓ v W (i.val + 1)) hjT + (R.graph.segSuf W i.val) + = A (R.graph.walkEnd ℓ v W) (R.graph.endIdx hℓ v W i) := by + have hend : R.graph.walkEnd (ℓ - (i.val + 1)) (R.graph.walkAt ℓ v W (i.val + 1)) + (R.graph.segSuf W i.val) = R.graph.walkEnd ℓ v W := by + have hidx : i.val + 1 + (ℓ - (i.val + 1)) = ℓ := by + have := i.isLt + omega + have h := R.graph.walkAt_segSuf v W i.val (ℓ - (i.val + 1)) (le_refl _) + rw [hidx] at h + simp only [R.graph.walkAt_self_eq_walkEnd] at h + exact h + rw [opinionOf, hend, R.graph.revWalk_segSuf v W i.isLt] + rfl + +/-- **The crossing count with the constraint's own conditions.** For a dart +`(a, d)` of `R` and a crossing position `i` inside an effective length `ℓ`, the +killed-power constraints crossing `(a, d)` at `i` with truthful opinions at both +ends number `truthCount a i * truthCount (nbr a d) (ℓ - (i+1))` times the fibre +weight. -/ +theorem card_good_crossing (A : (R.killedPow q T hq).Assignment) (a : R.graph.V) + (d : R.graph.D) {ℓ i : ℕ} (hℓ : ℓ < T) (hi : i < ℓ) (hiT : i ≤ T) + (hjT : ℓ - (i + 1) ≤ T) : + (Finset.univ.filter fun z : R.graph.V × ((Fin T → R.graph.D) × (Fin T → Fin q)) => + stopAt z.2.2 = ℓ ∧ + (R.graph.walkAt ℓ z.1 (R.graph.preWalk z.2.1 (le_of_lt hℓ)) i = a + ∧ (R.graph.preWalk z.2.1 (le_of_lt hℓ)) ⟨i, hi⟩ = d + ∧ R.opinionOf q T hq A a hiT (R.graph.revWalk z.1 + (R.graph.segPre (R.graph.preWalk z.2.1 (le_of_lt hℓ)) (le_of_lt hi))) + = R.kPlurality q T hq A a + ∧ R.opinionOf q T hq A (R.graph.nbr a d) hjT + (R.graph.segSuf (R.graph.preWalk z.2.1 (le_of_lt hℓ)) i) + = R.kPlurality q T hq A (R.graph.nbr a d))).card + = R.truthCount q T hq A a i + * R.truthCount q T hq A (R.graph.nbr a d) (ℓ - (i + 1)) + * (R.graph.deg ^ (T - ℓ) * ((q - 1) ^ ℓ * q ^ (T - ℓ - 1))) := by + classical + rw [R.graph.card_label_crossing hq hℓ hi a d + (fun p => R.opinionOf q T hq A a hiT p = R.kPlurality q T hq A a) + (fun s => R.opinionOf q T hq A (R.graph.nbr a d) hjT s + = R.kPlurality q T hq A (R.graph.nbr a d)), + truthCount, dif_pos hiT, truthCount, dif_pos hjT] + +/-! ### Every counted crossing breaks its constraint -/ + +/-- **The counted darts really are unsatisfied.** A killed walk crossing a dart +that the decoded assignment fails, with both ends holding the decoded opinion +about that dart's two vertices, breaks its own constraint. The two hypotheses +are exactly the conditions `card_good_crossing` counts, turned into the +constraint's `startIdx` / `endIdx` terms by the two identification lemmas. -/ +theorem not_satisfies_of_good_crossing (A : (R.killedPow q T hq).Assignment) + (z : R.graph.V × R.KLabels q T) (i : Fin (R.graph.kLen z.2)) + (hiT : i.val ≤ T) (hjT : R.graph.kLen z.2 - (i.val + 1) ≤ T) + (hfault : ¬ R.Satisfies (R.kDecode q T hq A) + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i.val, + R.graph.kWalk z.2 i)) + (hpre : R.opinionOf q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i.val) hiT + (R.graph.revWalk z.1 (R.graph.segPre (R.graph.kWalk z.2) (le_of_lt i.isLt))) + = R.kDecode q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i.val)) + (hsuf : R.opinionOf q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) (i.val + 1)) hjT + (R.graph.segSuf (R.graph.kWalk z.2) i.val) + = R.kDecode q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) (i.val + 1))) : + ¬ (R.killedPow q T hq).Satisfies A z := by + obtain ⟨v, y⟩ := z + refine R.not_satisfies_killedPow_of_faulty q T hq A v y i hfault ?_ ?_ + · rw [← R.opinionOf_eq_startIdx q T hq A (R.graph.kLen_le y) v (R.graph.kWalk y) i hiT] + exact hpre + · show A (R.graph.walkEnd (R.graph.kLen y) v (R.graph.kWalk y)) + (R.graph.endIdx (R.graph.kLen_le y) v (R.graph.kWalk y) i) = _ + rw [← R.opinionOf_eq_endIdx q T hq A (R.graph.kLen_le y) v (R.graph.kWalk y) i hjT] + exact hsuf + +/-- A walk count never exceeds the number of walks. -/ +theorem truthCount_le (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) (m : ℕ) : + R.truthCount q T hq A v m ≤ R.graph.deg ^ m := by + rw [truthCount] + split + · calc (Finset.univ.filter fun w : Fin m → R.graph.D => + R.opinionOf q T hq A v _ w = R.kPlurality q T hq A v).card + ≤ (Finset.univ : Finset (Fin m → R.graph.D)).card := Finset.card_filter_le _ _ + _ = R.graph.deg ^ m := by + rw [Finset.card_univ, Fintype.card_fun, Fintype.card_fin] + rfl + · exact Nat.zero_le _ + +/-- **Plurality on half the range.** Restricting the weighted sum to positions +at most `H` costs only the geometric tail, so the plurality bound survives the +restriction to a square of positions that `sum_crossing_factor` needs. -/ +theorem card_le_mul_sum_truthCount_half (A : (R.killedPow q T hq).Assignment) + (v : R.graph.V) {H : ℕ} (hH : H + 1 ≤ T) : + R.graph.deg ^ T * q ^ T + ≤ Fintype.card α * ((∑ m ∈ Finset.range (H + 1), + R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1)))) + + R.graph.deg ^ T * (q - 1) ^ T + + R.graph.deg ^ T * ((q - 1) ^ (H + 1) * q ^ (T - (H + 1)))) := by + classical + have hfull := R.card_le_mul_sum_truthCount q T hq A v + have hsum : ∑ m ∈ Finset.range T, R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) + = (∑ m ∈ Finset.range (H + 1), R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1)))) + + ∑ m ∈ Finset.Ico (H + 1) T, R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) := by + rw [Finset.range_eq_Ico, Finset.range_eq_Ico, + ← Finset.sum_Ico_consecutive _ (Nat.zero_le (H + 1)) hH] + have hterm : ∀ m ∈ Finset.Ico (H + 1) T, + R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) + ≤ R.graph.deg ^ T * ((q - 1) ^ m * q ^ (T - 1 - m)) := by + intro m hm + simp only [Finset.mem_Ico] at hm + have h1 : R.truthCount q T hq A v m ≤ R.graph.deg ^ m := R.truthCount_le q T hq A v m + have h2 : R.graph.deg ^ m * R.graph.deg ^ (T - m) = R.graph.deg ^ T := by + rw [← pow_add] + congr 1 + omega + have h3 : T - m - 1 = T - 1 - m := by omega + calc R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) + ≤ R.graph.deg ^ m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) := + Nat.mul_le_mul_right _ h1 + _ = R.graph.deg ^ T * ((q - 1) ^ m * q ^ (T - 1 - m)) := by + rw [h3, ← mul_assoc, h2] + have htail : ∑ m ∈ Finset.Ico (H + 1) T, R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) + ≤ R.graph.deg ^ T * ((q - 1) ^ (H + 1) * q ^ (T - (H + 1))) := by + calc ∑ m ∈ Finset.Ico (H + 1) T, R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) + ≤ ∑ m ∈ Finset.Ico (H + 1) T, R.graph.deg ^ T * ((q - 1) ^ m * q ^ (T - 1 - m)) := + Finset.sum_le_sum hterm + _ = R.graph.deg ^ T * ∑ m ∈ Finset.Ico (H + 1) T, (q - 1) ^ m * q ^ (T - 1 - m) := by + rw [Finset.mul_sum] + _ ≤ R.graph.deg ^ T * ((q - 1) ^ (H + 1) * q ^ (T - (H + 1))) := + Nat.mul_le_mul_left _ (geom_tail_le hq T (T - (H + 1)) (H + 1) rfl hH) + rw [hsum] at hfull + refine le_trans hfull (Nat.mul_le_mul_left _ ?_) + omega + +/-- The crossing count indexed by the two *lengths* rather than by length and +position — the form `sum_goodCount_factor` consumes. -/ +theorem card_good_crossing_sq (A : (R.killedPow q T hq).Assignment) (a : R.graph.V) + (d : R.graph.D) {i j : ℕ} (hij : i + j + 1 < T) (hiT : i ≤ T) + (hjT : (i + j + 1) - (i + 1) ≤ T) : + (Finset.univ.filter fun z : R.graph.V × ((Fin T → R.graph.D) × (Fin T → Fin q)) => + stopAt z.2.2 = i + j + 1 ∧ + (R.graph.walkAt (i + j + 1) z.1 (R.graph.preWalk z.2.1 (le_of_lt hij)) i = a + ∧ (R.graph.preWalk z.2.1 (le_of_lt hij)) ⟨i, by omega⟩ = d + ∧ R.opinionOf q T hq A a hiT (R.graph.revWalk z.1 + (R.graph.segPre (R.graph.preWalk z.2.1 (le_of_lt hij)) (by omega))) + = R.kPlurality q T hq A a + ∧ R.opinionOf q T hq A (R.graph.nbr a d) hjT + (R.graph.segSuf (R.graph.preWalk z.2.1 (le_of_lt hij)) i) + = R.kPlurality q T hq A (R.graph.nbr a d))).card + = R.truthCount q T hq A a i * R.truthCount q T hq A (R.graph.nbr a d) j + * (R.graph.deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1))) := by + have hsub : (i + j + 1) - (i + 1) = j := by omega + rw [R.card_good_crossing q T hq A a d hij (by omega) hiT hjT, hsub] + +/-! ### The per-dart bound -/ + +/-- The weighted count of truthful walks out of `v`, over positions at most +`H`. -/ +noncomputable def halfSum (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (H : ℕ) : ℕ := + ∑ m ∈ Finset.range (H + 1), R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) + +/-- What plurality pays for truncation: the walks that never stop, and those +that stop after position `H`. Both are geometrically small next to +`deg ^ T * q ^ T`. -/ +def pluralityLoss (deg q T H : ℕ) : ℕ := + deg ^ T * (q - 1) ^ T + deg ^ T * ((q - 1) ^ (H + 1) * q ^ (T - (H + 1))) + +theorem card_le_mul_halfSum_add_loss (A : (R.killedPow q T hq).Assignment) + (v : R.graph.V) {H : ℕ} (hH : H + 1 ≤ T) : + R.graph.deg ^ T * q ^ T + ≤ Fintype.card α * R.halfSum q T hq A v H + + Fintype.card α * pluralityLoss R.graph.deg q T H := by + have h := R.card_le_mul_sum_truthCount_half q T hq A v hH + calc R.graph.deg ^ T * q ^ T + ≤ Fintype.card α * ((∑ m ∈ Finset.range (H + 1), R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1)))) + + R.graph.deg ^ T * (q - 1) ^ T + + R.graph.deg ^ T * ((q - 1) ^ (H + 1) * q ^ (T - (H + 1)))) := h + _ = Fintype.card α * R.halfSum q T hq A v H + + Fintype.card α * pluralityLoss R.graph.deg q T H := by + rw [halfSum, pluralityLoss] + ring + +/-- **The per-dart first moment.** For one dart of `R`, the killed-power +constraints crossing it with truthful opinions at both ends number at least + +`(q-1) · (X - |α|·loss)² / (|α|² · normaliser)`, + +with `X = deg^T · q^T`. The two plurality bounds multiply because the crossing +sum factorises — the payoff of the killed walk law. -/ +theorem per_dart_lower (A : (R.killedPow q T hq).Assignment) (a : R.graph.V) + (d : R.graph.D) {H : ℕ} (hH : 2 * H + 1 < T) (hHT : H + 1 ≤ T) + (C : ℕ → ℕ → ℕ) + (hC : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), + C i j = R.truthCount q T hq A a i * R.truthCount q T hq A (R.graph.nbr a d) j + * (R.graph.deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) : + (q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H)) + ≤ Fintype.card α ^ 2 + * ((∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), C i j) + * (R.graph.deg ^ (T + 1) * q ^ T)) := by + have hid := sum_goodCount_factor R.graph.deg q T H hH + (fun i => R.truthCount q T hq A a i) + (fun j => R.truthCount q T hq A (R.graph.nbr a d) j) C hC + have ha := R.card_le_mul_halfSum_add_loss q T hq A a hHT + have hb := R.card_le_mul_halfSum_add_loss q T hq A (R.graph.nbr a d) hHT + have ha' : R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H + ≤ Fintype.card α * R.halfSum q T hq A a H := by omega + have hb' : R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H + ≤ Fintype.card α * R.halfSum q T hq A (R.graph.nbr a d) H := by omega + calc (q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H)) + ≤ (q - 1) * ((Fintype.card α * R.halfSum q T hq A a H) + * (Fintype.card α * R.halfSum q T hq A (R.graph.nbr a d) H)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul ha' hb') + _ = Fintype.card α ^ 2 * ((q - 1) * (R.halfSum q T hq A a H + * R.halfSum q T hq A (R.graph.nbr a d) H)) := by ring + _ = Fintype.card α ^ 2 + * ((∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), C i j) + * (R.graph.deg ^ (T + 1) * q ^ T)) := by + rw [hid, halfSum, halfSum] + +/-- **The first moment, summed over the failed darts.** Every dart of `R` that +the decoded assignment fails contributes its own crossings, and for a given +killed walk and position the dart crossed there is determined, so the +contributions never overlap. -/ +theorem sum_dart_lower (A : (R.killedPow q T hq).Assignment) (F : Finset R.Dart) + {H : ℕ} (hH : 2 * H + 1 < T) (hHT : H + 1 ≤ T) + (Cd : R.Dart → ℕ → ℕ → ℕ) + (hCd : ∀ p ∈ F, ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), + Cd p i j = R.truthCount q T hq A p.1 i + * R.truthCount q T hq A (R.graph.nbr p.1 p.2) j + * (R.graph.deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1)))) : + F.card * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) + ≤ Fintype.card α ^ 2 + * ((∑ p ∈ F, ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), Cd p i j) + * (R.graph.deg ^ (T + 1) * q ^ T)) := by + have hstep : ∀ p ∈ F, (q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H)) + ≤ Fintype.card α ^ 2 + * ((∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), Cd p i j) + * (R.graph.deg ^ (T + 1) * q ^ T)) := fun p hp => + R.per_dart_lower q T hq A p.1 p.2 hH hHT (Cd p) (hCd p hp) + calc F.card * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) + = ∑ _p ∈ F, ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) := by + rw [Finset.sum_const, smul_eq_mul] + _ ≤ ∑ p ∈ F, (Fintype.card α ^ 2 + * ((∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), Cd p i j) + * (R.graph.deg ^ (T + 1) * q ^ T))) := Finset.sum_le_sum hstep + _ = Fintype.card α ^ 2 + * ((∑ p ∈ F, ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), Cd p i j) + * (R.graph.deg ^ (T + 1) * q ^ T)) := by + rw [← Finset.mul_sum, ← Finset.sum_mul] + +/-! ### The crossing count of a single constraint -/ + +/-- The steps at which a killed walk crosses a dart the decoded assignment +fails, with truthful opinions at both ends. Its cardinality is the count the +second-moment method is applied to. -/ +noncomputable def goodCrossings (A : (R.killedPow q T hq).Assignment) + (z : R.graph.V × R.KLabels q T) : Finset (Fin (R.graph.kLen z.2)) := + Finset.univ.filter fun i => + (¬ R.Satisfies (R.kDecode q T hq A) + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i.val, + R.graph.kWalk z.2 i)) + ∧ R.opinionOf q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i.val) + (le_trans (le_of_lt i.isLt) (R.graph.kLen_le z.2)) + (R.graph.revWalk z.1 (R.graph.segPre (R.graph.kWalk z.2) (le_of_lt i.isLt))) + = R.kDecode q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i.val) + ∧ R.opinionOf q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) (i.val + 1)) + (le_trans (Nat.sub_le _ _) (R.graph.kLen_le z.2)) + (R.graph.segSuf (R.graph.kWalk z.2) i.val) + = R.kDecode q T hq A + (R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) (i.val + 1)) + +/-- **The support condition.** A constraint with any good crossing is +unsatisfied, so the second-moment method's support sits inside the unsatisfied +darts. -/ +theorem mem_unsatDarts_of_goodCrossings_nonempty (A : (R.killedPow q T hq).Assignment) + (z : R.graph.V × R.KLabels q T) (h : (R.goodCrossings q T hq A z).Nonempty) : + z ∈ (R.killedPow q T hq).unsatDarts A := by + obtain ⟨i, hi⟩ := h + rw [goodCrossings, Finset.mem_filter] at hi + have hns := R.not_satisfies_of_good_crossing q T hq A z i _ _ hi.2.1 hi.2.2.1 hi.2.2.2 + exact (RegCSP.mem_unsatDarts (R := R.killedPow q T hq) (a := A) (p := z)).mpr hns + +/-- **The second moment, in terms of pairs of crossings.** Squaring the count +of good crossings and summing turns into the count itself plus twice the ordered +pairs — and pairs of crossings are what the correlation bound estimates. -/ +theorem sum_sq_goodCrossings (A : (R.killedPow q T hq).Assignment) : + ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) ^ 2 + = (∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + + 2 * ∑ z : R.graph.V × R.KLabels q T, + ((((R.goodCrossings q T hq A z) ×ˢ (R.goodCrossings q T hq A z)).filter + fun p => p.1 < p.2).card : ℝ) := by + classical + have hpt : ∀ z : R.graph.V × R.KLabels q T, + ((R.goodCrossings q T hq A z).card : ℝ) ^ 2 + = ((R.goodCrossings q T hq A z).card : ℝ) + + 2 * ((((R.goodCrossings q T hq A z) ×ˢ (R.goodCrossings q T hq A z)).filter + fun p => p.1 < p.2).card : ℝ) := by + intro z + have h := card_sq_eq_add_two_mul_pairs (R.goodCrossings q T hq A z) + exact_mod_cast congrArg (fun n : ℕ => (n : ℝ)) h + rw [Finset.sum_congr rfl fun z _ => hpt z, Finset.sum_add_distrib, Finset.mul_sum] + +/-! ### Positions as naturals -/ + +/-- The good crossing positions of a constraint, as naturals. The `Fin` version +carries the constraint's own length in its type, which blocks the exchange of +summation order the second moment needs; this one does not. -/ +noncomputable def goodPos (A : (R.killedPow q T hq).Assignment) + (z : R.graph.V × R.KLabels q T) : Finset ℕ := + (R.goodCrossings q T hq A z).image Fin.val + +theorem card_goodPos (A : (R.killedPow q T hq).Assignment) + (z : R.graph.V × R.KLabels q T) : + (R.goodPos q T hq A z).card = (R.goodCrossings q T hq A z).card := + Finset.card_image_of_injective _ Fin.val_injective + +theorem mem_goodPos {A : (R.killedPow q T hq).Assignment} + {z : R.graph.V × R.KLabels q T} {k : ℕ} : + k ∈ R.goodPos q T hq A z + ↔ ∃ h : k < R.graph.kLen z.2, (⟨k, h⟩ : Fin (R.graph.kLen z.2)) + ∈ R.goodCrossings q T hq A z := by + classical + rw [goodPos, Finset.mem_image] + constructor + · rintro ⟨i, hi, rfl⟩ + exact ⟨i.isLt, by simpa using hi⟩ + · rintro ⟨h, hmem⟩ + exact ⟨⟨k, h⟩, hmem, rfl⟩ + +/-- Counting ordered pairs of positions is the same in either indexing. -/ +theorem card_pairs_goodPos (A : (R.killedPow q T hq).Assignment) + (z : R.graph.V × R.KLabels q T) : + (((R.goodPos q T hq A z) ×ˢ (R.goodPos q T hq A z)).filter fun p => p.1 < p.2).card + = (((R.goodCrossings q T hq A z) ×ˢ (R.goodCrossings q T hq A z)).filter + fun p => p.1 < p.2).card := by + classical + refine (Finset.card_bij (fun p _ => ((p.1.val : ℕ), (p.2.val : ℕ))) ?_ ?_ ?_).symm + · intro p hp + simp only [Finset.mem_filter, Finset.mem_product] at hp ⊢ + refine ⟨⟨?_, ?_⟩, hp.2⟩ + · exact Finset.mem_image_of_mem _ hp.1.1 + · exact Finset.mem_image_of_mem _ hp.1.2 + · intro p _ p' _ hpp + have h1 : p.1.val = p'.1.val := congrArg Prod.fst hpp + have h2 : p.2.val = p'.2.val := congrArg Prod.snd hpp + exact Prod.ext (Fin.ext h1) (Fin.ext h2) + · intro p hp + simp only [Finset.mem_filter, Finset.mem_product] at hp + obtain ⟨⟨h1, h2⟩, hlt⟩ := hp + obtain ⟨hb1, hm1⟩ := (R.mem_goodPos q T hq).mp h1 + obtain ⟨hb2, hm2⟩ := (R.mem_goodPos q T hq).mp h2 + refine ⟨(⟨p.1, hb1⟩, ⟨p.2, hb2⟩), ?_, rfl⟩ + simp only [Finset.mem_filter, Finset.mem_product] + exact ⟨⟨hm1, hm2⟩, hlt⟩ + +theorem lt_T_of_mem_goodPos {A : (R.killedPow q T hq).Assignment} + {z : R.graph.V × R.KLabels q T} {k : ℕ} (h : k ∈ R.goodPos q T hq A z) : k < T := by + obtain ⟨hb, -⟩ := (R.mem_goodPos q T hq).mp h + exact lt_of_lt_of_le hb (R.graph.kLen_le z.2) + +/-- **Exchanging the order of counting.** The pairs of good crossings, summed +over the constraints, are the same as the constraints with two good crossings, +summed over the pairs of positions. The right-hand side is the form the +correlation bound estimates. -/ +theorem sum_card_pairs_eq (A : (R.killedPow q T hq).Assignment) : + ∑ z : R.graph.V × R.KLabels q T, + (((R.goodPos q T hq A z) ×ˢ (R.goodPos q T hq A z)).filter fun p => p.1 < p.2).card + = ∑ p ∈ ((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2, + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + p.1 ∈ R.goodPos q T hq A z ∧ p.2 ∈ R.goodPos q T hq A z).card := by + classical + have hzcard : ∀ z : R.graph.V × R.KLabels q T, + (((R.goodPos q T hq A z) ×ˢ (R.goodPos q T hq A z)).filter fun p => p.1 < p.2).card + = ((((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2).filter + fun p => p.1 ∈ R.goodPos q T hq A z ∧ p.2 ∈ R.goodPos q T hq A z).card := by + intro z + congr 1 + ext p + simp only [Finset.mem_filter, Finset.mem_product, Finset.mem_range] + constructor + · rintro ⟨⟨h1, h2⟩, hlt⟩ + exact ⟨⟨⟨R.lt_T_of_mem_goodPos q T hq h1, R.lt_T_of_mem_goodPos q T hq h2⟩, hlt⟩, h1, h2⟩ + · rintro ⟨⟨-, hlt⟩, h1, h2⟩ + exact ⟨⟨h1, h2⟩, hlt⟩ + rw [Finset.sum_congr rfl fun z _ => hzcard z] + simp only [Finset.card_filter] + exact Finset.sum_comm + +/-- **Dropping to the underlying walk.** Constraints with good crossings at two +positions are, after forgetting the truthfulness conditions and the stopping +signals, walks that cross a failed dart at both positions. Forgetting the +signals costs the factor `q ^ T`; both omissions only weaken an upper bound. -/ +theorem card_both_good_le (A : (R.killedPow q T hq).Assignment) {k l : ℕ} + (hk : k < T) (hl : l < T) : + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + k ∈ R.goodPos q T hq A z ∧ l ∈ R.goodPos q T hq A z).card + ≤ q ^ T * (Finset.univ.filter fun w : R.graph.V × (Fin T → R.graph.D) => + (R.graph.walkAt T w.1 w.2 k, w.2 ⟨k, hk⟩) ∈ R.unsatDarts (R.kDecode q T hq A) + ∧ (R.graph.walkAt T w.1 w.2 l, w.2 ⟨l, hl⟩) + ∈ R.unsatDarts (R.kDecode q T hq A)).card := by + classical + have hfaulty : ∀ (z : R.graph.V × R.KLabels q T) (j : ℕ) (hj : j < T), + j ∈ R.goodPos q T hq A z → + (R.graph.walkAt T z.1 z.2.1 j, z.2.1 ⟨j, hj⟩) + ∈ R.unsatDarts (R.kDecode q T hq A) := by + intro z j hj hmem + obtain ⟨hb, hgc⟩ := (R.mem_goodPos q T hq).mp hmem + rw [goodCrossings, Finset.mem_filter] at hgc + have hns := hgc.2.1 + have hwalk : R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) j + = R.graph.walkAt T z.1 z.2.1 j := + R.graph.walkAt_preWalk (R.graph.kLen_le z.2) z.1 z.2.1 j (le_of_lt hb) + have hlab : R.graph.kWalk z.2 ⟨j, hb⟩ = z.2.1 ⟨j, hj⟩ := rfl + rw [hwalk, hlab] at hns + exact (RegCSP.mem_unsatDarts (R := R) (a := R.kDecode q T hq A) + (p := (R.graph.walkAt T z.1 z.2.1 j, z.2.1 ⟨j, hj⟩))).mpr hns + refine le_trans (Finset.card_le_mul_card_image_of_maps_to + (f := fun z : R.graph.V × R.KLabels q T => (z.1, z.2.1)) + (t := Finset.univ.filter fun w : R.graph.V × (Fin T → R.graph.D) => + (R.graph.walkAt T w.1 w.2 k, w.2 ⟨k, hk⟩) ∈ R.unsatDarts (R.kDecode q T hq A) + ∧ (R.graph.walkAt T w.1 w.2 l, w.2 ⟨l, hl⟩) + ∈ R.unsatDarts (R.kDecode q T hq A)) ?_ (q ^ T) ?_) (le_refl _) + · intro z hz + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hz ⊢ + exact ⟨hfaulty z k hk hz.1, hfaulty z l hl hz.2⟩ + · intro w _ + refine le_trans (Finset.card_le_card_of_injOn (fun z => z.2.2) + (fun _ _ => Finset.mem_univ _) ?_) ?_ + · intro z hz z' hz' hzz + simp only [Finset.coe_filter, Set.mem_setOf_eq] at hz hz' + have hz1 : z.1 = w.1 := congrArg Prod.fst hz.2 + have hz2 : z.2.1 = w.2 := congrArg Prod.snd hz.2 + have hz1' : z'.1 = w.1 := congrArg Prod.fst hz'.2 + have hz2' : z'.2.1 = w.2 := congrArg Prod.snd hz'.2 + exact Prod.ext (hz1.trans hz1'.symm) (Prod.ext (hz2.trans hz2'.symm) hzz) + · rw [Finset.card_univ, Fintype.card_fun, Fintype.card_fin, Fintype.card_fin] + +/-- **The second moment's pair term, bounded.** Chaining the drop to underlying +walks, the two-crossing identity and the correlation bound. -/ +theorem sum_pairs_bound (A : (R.killedPow q T hq).Assignment) {lam : ℝ} + (hlam0 : 0 ≤ lam) (hlam1 : lam < 1) (hspec : R.graph.SpectralBound lam) + (hn : 0 < R.graph.order) : + ∑ p ∈ ((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2, + ((Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + p.1 ∈ R.goodPos q T hq A z ∧ p.2 ∈ R.goodPos q T hq A z).card : ℝ) + ≤ (q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ((T : ℝ) * (T : ℝ) * (((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) / (R.graph.order : ℝ)) + + (T : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ)))) := by + classical + set F := R.unsatDarts (R.kDecode q T hq A) with hF + set Cop : ℕ → ℕ → ℝ := fun k l => ∑ z : R.graph.V, (R.graph.headCount F z : ℝ) + * R.graph.stepIter (l - k - 1) (fun w => (R.graph.dartCount F w : ℝ)) z with hCop + have hterm : ∀ p ∈ ((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2, + ((Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + p.1 ∈ R.goodPos q T hq A z ∧ p.2 ∈ R.goodPos q T hq A z).card : ℝ) + ≤ (q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) * Cop p.1 p.2) := by + intro p hp + simp only [Finset.mem_filter, Finset.mem_product, Finset.mem_range] at hp + obtain ⟨⟨hk, hl⟩, hlt⟩ := hp + have h1 := R.card_both_good_le q T hq A hk hl + have h1R : ((Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + p.1 ∈ R.goodPos q T hq A z ∧ p.2 ∈ R.goodPos q T hq A z).card : ℝ) + ≤ (q : ℝ) ^ T * ((Finset.univ.filter fun w : R.graph.V × (Fin T → R.graph.D) => + (R.graph.walkAt T w.1 w.2 p.1, w.2 ⟨p.1, hk⟩) ∈ F + ∧ (R.graph.walkAt T w.1 w.2 p.2, w.2 ⟨p.2, hl⟩) ∈ F).card : ℝ) := by + exact_mod_cast h1 + refine le_trans h1R ?_ + have hcount : ((Finset.univ.filter fun w : R.graph.V × (Fin T → R.graph.D) => + (R.graph.walkAt T w.1 w.2 p.1, w.2 ⟨p.1, hk⟩) ∈ F + ∧ (R.graph.walkAt T w.1 w.2 p.2, w.2 ⟨p.2, hl⟩) ∈ F).card : ℝ) + = (R.graph.deg : ℝ) ^ (T - 2) * Cop p.1 p.2 := by + rw [card_filter_eq_sum_prod, Fintype.sum_prod_type, hCop] + exact R.graph.sum_two_crossings F hlt hl + rw [hcount] + refine le_trans (Finset.sum_le_sum hterm) ?_ + have hfactor : ∑ p ∈ ((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2, + (q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) * Cop p.1 p.2) + = (q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ∑ k ∈ Finset.range T, ∑ l ∈ Finset.Ico (k + 1) T, Cop k l) := by + rw [← sum_pairs_eq_sum_Ico T fun p => Cop p.1 p.2, Finset.mul_sum, Finset.mul_sum] + rw [hfactor] + have hnn : (0 : ℝ) ≤ (q : ℝ) ^ T * (R.graph.deg : ℝ) ^ (T - 2) := by positivity + have hinner := R.graph.sum_pairs_le F hlam0 hlam1 hspec hn T Cop + (fun k _ l _ => rfl) + calc (q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ∑ k ∈ Finset.range T, ∑ l ∈ Finset.Ico (k + 1) T, Cop k l) + = ((q : ℝ) ^ T * (R.graph.deg : ℝ) ^ (T - 2)) + * ∑ k ∈ Finset.range T, ∑ l ∈ Finset.Ico (k + 1) T, Cop k l := by ring + _ ≤ ((q : ℝ) ^ T * (R.graph.deg : ℝ) ^ (T - 2)) + * ((T : ℝ) * (T : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (R.graph.order : ℝ)) + + (T : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) * (F.card : ℝ))) := + mul_le_mul_of_nonneg_left hinner hnn + _ = (q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ((T : ℝ) * (T : ℝ) * ((F.card : ℝ) * (F.card : ℝ) / (R.graph.order : ℝ)) + + (T : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) * (F.card : ℝ)))) := by ring + +/-- **The second moment of the crossing count.** Everything above, assembled: +the sum of squares is the sum plus twice a pair term, and the pair term is +controlled by the spectral gap. -/ +theorem sum_sq_goodCrossings_le (A : (R.killedPow q T hq).Assignment) {lam : ℝ} + (hlam0 : 0 ≤ lam) (hlam1 : lam < 1) (hspec : R.graph.SpectralBound lam) + (hn : 0 < R.graph.order) : + ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) ^ 2 + ≤ (∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + + 2 * ((q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ((T : ℝ) * (T : ℝ) * (((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) / (R.graph.order : ℝ)) + + (T : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ))))) := by + classical + rw [R.sum_sq_goodCrossings q T hq A] + have hpair : ∑ z : R.graph.V × R.KLabels q T, + ((((R.goodCrossings q T hq A z) ×ˢ (R.goodCrossings q T hq A z)).filter + fun p => p.1 < p.2).card : ℝ) + = ∑ p ∈ ((Finset.range T) ×ˢ (Finset.range T)).filter fun p => p.1 < p.2, + ((Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + p.1 ∈ R.goodPos q T hq A z ∧ p.2 ∈ R.goodPos q T hq A z).card : ℝ) := by + rw [← Nat.cast_sum, ← Nat.cast_sum] + congr 1 + rw [Finset.sum_congr rfl fun z _ => (R.card_pairs_goodPos q T hq A z).symm] + exact R.sum_card_pairs_eq q T hq A + rw [hpair] + have hbound := R.sum_pairs_bound q T hq A hlam0 hlam1 hspec hn + linarith [hbound] + +/-- The first moment, with the order of counting exchanged: summing the good +crossings over the constraints is the same as counting, for each position, the +constraints good there. -/ +theorem sum_card_goodPos_eq (A : (R.killedPow q T hq).Assignment) : + ∑ z : R.graph.V × R.KLabels q T, (R.goodPos q T hq A z).card + = ∑ k ∈ Finset.range T, + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + k ∈ R.goodPos q T hq A z).card := by + classical + have hzcard : ∀ z : R.graph.V × R.KLabels q T, + (R.goodPos q T hq A z).card + = ((Finset.range T).filter fun k => k ∈ R.goodPos q T hq A z).card := by + intro z + congr 1 + ext k + simp only [Finset.mem_filter, Finset.mem_range] + exact ⟨fun h => ⟨R.lt_T_of_mem_goodPos q T hq h, h⟩, fun h => h.2⟩ + rw [Finset.sum_congr rfl fun z _ => hzcard z] + simp only [Finset.card_filter] + exact Finset.sum_comm + +/-- Constraints of different effective lengths are different constraints, so +summing over the suffix length `j` at a fixed crossing position stays within the +constraints good at that position. -/ +theorem sum_over_len_le (A : (R.killedPow q T hq).Assignment) (i H : ℕ) : + ∑ j ∈ Finset.range (H + 1), + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j + 1 ∧ i ∈ R.goodPos q T hq A z).card + ≤ (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + i ∈ R.goodPos q T hq A z).card := by + classical + have hdisj : ∀ j ∈ Finset.range (H + 1), ∀ j' ∈ Finset.range (H + 1), j ≠ j' → + Disjoint + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j + 1 ∧ i ∈ R.goodPos q T hq A z) + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j' + 1 ∧ i ∈ R.goodPos q T hq A z) := by + intro j _ j' _ hjj + refine Finset.disjoint_left.mpr fun z hz hz' => ?_ + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hz hz' + apply hjj + have := hz.1.symm.trans hz'.1 + omega + rw [← Finset.card_biUnion hdisj] + refine Finset.card_le_card ?_ + intro z hz + simp only [Finset.mem_biUnion, Finset.mem_filter, Finset.mem_univ, true_and] at hz ⊢ + obtain ⟨j, -, -, hgood⟩ := hz + exact hgood + +/-- **From a counted crossing to a good position.** A constraint counted by +`card_good_crossing_sq`, whose crossed dart the decoded assignment fails, is good +at that position. The two descriptions differ only in how the walk's length is +named — `i + j + 1` on one side, `kLen` on the other — which `walkAt_preWalk` +and `opinionOf_congr` reconcile without any transport. -/ +theorem mem_goodPos_of_crossing (A : (R.killedPow q T hq).Assignment) (a : R.graph.V) + (d : R.graph.D) {i j : ℕ} (hij : i + j + 1 < T) (hiT : i ≤ T) + (hjT : (i + j + 1) - (i + 1) ≤ T) + (hfault : ¬ R.Satisfies (R.kDecode q T hq A) (a, d)) + (z : R.graph.V × R.KLabels q T) (hlen : stopAt z.2.2 = i + j + 1) + (hwalk : R.graph.walkAt (i + j + 1) z.1 (R.graph.preWalk z.2.1 (le_of_lt hij)) i = a) + (hlab : R.graph.preWalk z.2.1 (le_of_lt hij) ⟨i, by omega⟩ = d) + (hpre : R.opinionOf q T hq A a hiT (R.graph.revWalk z.1 + (R.graph.segPre (R.graph.preWalk z.2.1 (le_of_lt hij)) (by omega))) + = R.kPlurality q T hq A a) + (hsuf : R.opinionOf q T hq A (R.graph.nbr a d) hjT + (R.graph.segSuf (R.graph.preWalk z.2.1 (le_of_lt hij)) i) + = R.kPlurality q T hq A (R.graph.nbr a d)) : + i ∈ R.goodPos q T hq A z := by + classical + have hkl : R.graph.kLen z.2 = i + j + 1 := hlen + have hb : i < R.graph.kLen z.2 := by omega + refine (R.mem_goodPos q T hq).mpr ⟨hb, ?_⟩ + -- the walk position, computed two ways + have hA1 : R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i + = R.graph.walkAt T z.1 z.2.1 i := + R.graph.walkAt_preWalk (R.graph.kLen_le z.2) z.1 z.2.1 i (le_of_lt hb) + have hA2 : R.graph.walkAt (i + j + 1) z.1 (R.graph.preWalk z.2.1 (le_of_lt hij)) i + = R.graph.walkAt T z.1 z.2.1 i := + R.graph.walkAt_preWalk (le_of_lt hij) z.1 z.2.1 i (by omega) + have hvert : R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) i = a := by + rw [hA1, ← hA2, hwalk] + have hlabel : R.graph.kWalk z.2 ⟨i, hb⟩ = d := hlab + -- the prefix walk, pointwise equal on the nose + have hprewalk : R.graph.segPre (R.graph.kWalk z.2) (le_of_lt hb) + = R.graph.segPre (R.graph.preWalk z.2.1 (le_of_lt hij)) (by omega) := rfl + rw [goodCrossings, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_, ?_, ?_⟩ + · rw [hvert, hlabel] + exact hfault + · rw [hvert, hprewalk] + exact hpre + · have hnext : R.graph.walkAt (R.graph.kLen z.2) z.1 (R.graph.kWalk z.2) (i + 1) + = R.graph.nbr a d := by + rw [R.graph.walkAt_succ_of_lt z.1 (R.graph.kWalk z.2) hb, hvert, hlabel] + rw [hnext] + refine Eq.trans ?_ hsuf + have hsub : R.graph.kLen z.2 - ((⟨i, hb⟩ : Fin (R.graph.kLen z.2)).val + 1) + = (i + j + 1) - (i + 1) := by + dsimp only + omega + refine R.opinionOf_congr q T hq A (R.graph.nbr a d) _ hjT hsub _ _ ?_ + intro k hk hk' + rfl + +/-- The constraints counted by `card_good_crossing_sq`, packaged. -/ +noncomputable def crossingSet (A : (R.killedPow q T hq).Assignment) (a : R.graph.V) + (d : R.graph.D) {i j : ℕ} (hij : i + j + 1 < T) (hiT : i ≤ T) + (hjT : (i + j + 1) - (i + 1) ≤ T) : Finset (R.graph.V × R.KLabels q T) := + Finset.univ.filter fun z => + stopAt z.2.2 = i + j + 1 ∧ + (R.graph.walkAt (i + j + 1) z.1 (R.graph.preWalk z.2.1 (le_of_lt hij)) i = a + ∧ (R.graph.preWalk z.2.1 (le_of_lt hij)) ⟨i, by omega⟩ = d + ∧ R.opinionOf q T hq A a hiT (R.graph.revWalk z.1 + (R.graph.segPre (R.graph.preWalk z.2.1 (le_of_lt hij)) (by omega))) + = R.kPlurality q T hq A a + ∧ R.opinionOf q T hq A (R.graph.nbr a d) hjT + (R.graph.segSuf (R.graph.preWalk z.2.1 (le_of_lt hij)) i) + = R.kPlurality q T hq A (R.graph.nbr a d)) + +theorem card_crossingSet (A : (R.killedPow q T hq).Assignment) (a : R.graph.V) + (d : R.graph.D) {i j : ℕ} (hij : i + j + 1 < T) (hiT : i ≤ T) + (hjT : (i + j + 1) - (i + 1) ≤ T) : + (R.crossingSet q T hq A a d hij hiT hjT).card + = R.truthCount q T hq A a i * R.truthCount q T hq A (R.graph.nbr a d) j + * (R.graph.deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1))) := + R.card_good_crossing_sq q T hq A a d hij hiT hjT + +/-- **The crossings of different darts do not overlap.** At a fixed position the +dart a walk crosses is determined, so summing over the failed darts stays within +the constraints good at that position. -/ +theorem sum_crossingSet_le (A : (R.killedPow q T hq).Assignment) {i j : ℕ} + (hij : i + j + 1 < T) (hiT : i ≤ T) (hjT : (i + j + 1) - (i + 1) ≤ T) : + ∑ p ∈ R.unsatDarts (R.kDecode q T hq A), + (R.crossingSet q T hq A p.1 p.2 hij hiT hjT).card + ≤ (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j + 1 ∧ i ∈ R.goodPos q T hq A z).card := by + classical + have hdisj : ∀ p ∈ R.unsatDarts (R.kDecode q T hq A), + ∀ p' ∈ R.unsatDarts (R.kDecode q T hq A), p ≠ p' → + Disjoint (R.crossingSet q T hq A p.1 p.2 hij hiT hjT) + (R.crossingSet q T hq A p'.1 p'.2 hij hiT hjT) := by + intro p _ p' _ hpp + refine Finset.disjoint_left.mpr fun z hz hz' => ?_ + rw [crossingSet, Finset.mem_filter] at hz hz' + apply hpp + exact Prod.ext (hz.2.2.1.symm.trans hz'.2.2.1) (hz.2.2.2.1.symm.trans hz'.2.2.2.1) + rw [← Finset.card_biUnion hdisj] + refine Finset.card_le_card ?_ + intro z hz + rw [Finset.mem_biUnion] at hz + obtain ⟨p, hp, hzp⟩ := hz + rw [crossingSet, Finset.mem_filter] at hzp + obtain ⟨-, hlen, hwalk, hlab, hpre, hsuf⟩ := hzp + have hfault : ¬ R.Satisfies (R.kDecode q T hq A) (p.1, p.2) := by + have := (RegCSP.mem_unsatDarts (R := R) (a := R.kDecode q T hq A) (p := p)).mp hp + exact this + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨hlen, R.mem_goodPos_of_crossing q T hq A p.1 p.2 hij hiT hjT hfault z hlen hwalk + hlab hpre hsuf⟩ + +/-- Summed over both lengths, the constraints good at a position never exceed +the total crossing count. -/ +theorem sum_len_pos_le (A : (R.killedPow q T hq).Assignment) {H : ℕ} (hHT : H + 1 ≤ T) : + ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j + 1 ∧ i ∈ R.goodPos q T hq A z).card + ≤ ∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card := by + classical + calc ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j + 1 ∧ i ∈ R.goodPos q T hq A z).card + ≤ ∑ i ∈ Finset.range (H + 1), + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + i ∈ R.goodPos q T hq A z).card := + Finset.sum_le_sum fun i _ => R.sum_over_len_le q T hq A i H + _ ≤ ∑ k ∈ Finset.range T, + (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + k ∈ R.goodPos q T hq A z).card := by + refine Finset.sum_le_sum_of_subset ?_ + intro i hi + simp only [Finset.mem_range] at hi ⊢ + omega + _ = ∑ z : R.graph.V × R.KLabels q T, (R.goodPos q T hq A z).card := + (R.sum_card_goodPos_eq q T hq A).symm + _ = ∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card := + Finset.sum_congr rfl fun z _ => R.card_goodPos q T hq A z + +/-- **The first moment, bounded by the crossing count.** The counts summed by +`sum_dart_lower` never exceed the total number of good crossings. -/ +theorem sum_Cd_le_sum_goodCrossings (A : (R.killedPow q T hq).Assignment) {H : ℕ} + (hHT : H + 1 ≤ T) (Cd : R.Dart → ℕ → ℕ → ℕ) + (hCd : ∀ p ∈ R.unsatDarts (R.kDecode q T hq A), ∀ i ∈ Finset.range (H + 1), + ∀ j ∈ Finset.range (H + 1), ∀ (hij : i + j + 1 < T) (hiT : i ≤ T) + (hjT : (i + j + 1) - (i + 1) ≤ T), + Cd p i j = (R.crossingSet q T hq A p.1 p.2 hij hiT hjT).card) + (hsq : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), i + j + 1 < T) : + ∑ p ∈ R.unsatDarts (R.kDecode q T hq A), ∑ i ∈ Finset.range (H + 1), + ∑ j ∈ Finset.range (H + 1), Cd p i j + ≤ ∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card := by + classical + have hreorder : ∑ p ∈ R.unsatDarts (R.kDecode q T hq A), ∑ i ∈ Finset.range (H + 1), + ∑ j ∈ Finset.range (H + 1), Cd p i j + = ∑ i ∈ Finset.range (H + 1), ∑ j ∈ Finset.range (H + 1), + ∑ p ∈ R.unsatDarts (R.kDecode q T hq A), Cd p i j := by + rw [Finset.sum_comm] + exact Finset.sum_congr rfl fun i _ => Finset.sum_comm + rw [hreorder] + refine le_trans (Finset.sum_le_sum fun i hi => Finset.sum_le_sum fun j hj => ?_) + (R.sum_len_pos_le q T hq A hHT) + have hij : i + j + 1 < T := hsq i hi j hj + have hiT : i ≤ T := by + simp only [Finset.mem_range] at hi + omega + have hjT : (i + j + 1) - (i + 1) ≤ T := by omega + calc ∑ p ∈ R.unsatDarts (R.kDecode q T hq A), Cd p i j + = ∑ p ∈ R.unsatDarts (R.kDecode q T hq A), + (R.crossingSet q T hq A p.1 p.2 hij hiT hjT).card := + Finset.sum_congr rfl fun p hp => hCd p hp i hi j hj hij hiT hjT + _ ≤ (Finset.univ.filter fun z : R.graph.V × R.KLabels q T => + stopAt z.2.2 = i + j + 1 ∧ i ∈ R.goodPos q T hq A z).card := + R.sum_crossingSet_le q T hq A hij hiT hjT + +/-! ### Powering soundness -/ + +/-- **The second-moment bound on unsatisfied constraints.** Given a lower bound +on the first moment of the crossing count and an upper bound on its second +moment, at least `Alb ^ 2 / Bub` of the powered constraints are unsatisfied. -/ +theorem card_unsatDarts_ge (A : (R.killedPow q T hq).Assignment) {Alb Bub : ℝ} + (hA0 : 0 ≤ Alb) + (hA : Alb ≤ ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + (hB : ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) ^ 2 + ≤ Bub) (hB0 : 0 < Bub) : + Alb ^ 2 / Bub ≤ (((R.killedPow q T hq).unsatDarts A).card : ℝ) := by + classical + refine card_ge_of_moments (fun z => ((R.goodCrossings q T hq A z).card : ℝ)) + ((R.killedPow q T hq).unsatDarts A) ?_ hA0 hA hB hB0 + intro z hz + have hcard : (R.goodCrossings q T hq A z).card ≠ 0 := by + intro h + apply hz + show ((R.goodCrossings q T hq A z).card : ℝ) = 0 + rw [h] + norm_num + exact R.mem_unsatDarts_of_goodCrossings_nonempty q T hq A z + (Finset.card_pos.mp (Nat.pos_of_ne_zero hcard)) + +/-- The crossing count as a total function of the two lengths, so that it can be +summed without carrying the side conditions. -/ +noncomputable def crossCount (A : (R.killedPow q T hq).Assignment) (p : R.Dart) + (i j : ℕ) : ℕ := + if h : i + j + 1 < T then + (R.crossingSet q T hq A p.1 p.2 h (by omega) (by omega)).card + else 0 + +theorem crossCount_eq_card (A : (R.killedPow q T hq).Assignment) (p : R.Dart) + {i j : ℕ} (hij : i + j + 1 < T) (hiT : i ≤ T) (hjT : (i + j + 1) - (i + 1) ≤ T) : + R.crossCount q T hq A p i j = (R.crossingSet q T hq A p.1 p.2 hij hiT hjT).card := by + rw [crossCount, dif_pos hij] + +theorem crossCount_eq_prod (A : (R.killedPow q T hq).Assignment) (p : R.Dart) + {i j : ℕ} (hij : i + j + 1 < T) : + R.crossCount q T hq A p i j + = R.truthCount q T hq A p.1 i * R.truthCount q T hq A (R.graph.nbr p.1 p.2) j + * (R.graph.deg ^ (T - (i + j + 1)) + * ((q - 1) ^ (i + j + 1) * q ^ (T - (i + j + 1) - 1))) := by + rw [R.crossCount_eq_card q T hq A p hij (by omega) (by omega), + R.card_crossingSet q T hq A p.1 p.2 hij (by omega) (by omega)] + +/-- **The first moment, in closed form.** Combining the per-dart bound with the +fact that the counted crossings are good crossings. -/ +theorem sum_goodCrossings_ge (A : (R.killedPow q T hq).Assignment) {H : ℕ} + (hH : 2 * H + 1 < T) (hHT : H + 1 ≤ T) + (hsq : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), i + j + 1 < T) : + (((R.unsatDarts (R.kDecode q T hq A)).card + * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) : ℕ) : ℝ) + ≤ ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) + * ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) := by + classical + have h1 := R.sum_dart_lower q T hq A (R.unsatDarts (R.kDecode q T hq A)) hH hHT + (R.crossCount q T hq A) + (fun p _ i hi j hj => R.crossCount_eq_prod q T hq A p (hsq i hi j hj)) + have h2 := R.sum_Cd_le_sum_goodCrossings q T hq A hHT (R.crossCount q T hq A) + (fun p _ i _ j _ hij hiT hjT => R.crossCount_eq_card q T hq A p hij hiT hjT) hsq + have h3 : (R.unsatDarts (R.kDecode q T hq A)).card + * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) + ≤ Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) + * ∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card := by + refine le_trans h1 ?_ + have hmul : (∑ p ∈ R.unsatDarts (R.kDecode q T hq A), ∑ i ∈ Finset.range (H + 1), + ∑ j ∈ Finset.range (H + 1), R.crossCount q T hq A p i j) + * (R.graph.deg ^ (T + 1) * q ^ T) + ≤ (∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card) + * (R.graph.deg ^ (T + 1) * q ^ T) := + Nat.mul_le_mul_right _ h2 + calc Fintype.card α ^ 2 + * ((∑ p ∈ R.unsatDarts (R.kDecode q T hq A), ∑ i ∈ Finset.range (H + 1), + ∑ j ∈ Finset.range (H + 1), R.crossCount q T hq A p i j) + * (R.graph.deg ^ (T + 1) * q ^ T)) + ≤ Fintype.card α ^ 2 + * ((∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card) + * (R.graph.deg ^ (T + 1) * q ^ T)) := Nat.mul_le_mul_left _ hmul + _ = Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) + * ∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card := by ring + have h4 : (((R.unsatDarts (R.kDecode q T hq A)).card + * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) : ℕ) : ℝ) + ≤ ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) + * ∑ z : R.graph.V × R.KLabels q T, (R.goodCrossings q T hq A z).card : ℕ) : ℝ) := by + exact_mod_cast h3 + refine le_trans h4 ?_ + push_cast + exact le_refl _ + +/-- **Soundness of the killed powering step.** Combining the first moment +(`sum_goodCrossings_ge`) with the second (`sum_sq_goodCrossings_le`) through +Paley–Zygmund: a constant fraction of the powered constraints fail, the constant +being the ratio of the squared first moment to the second. + +The first moment is proportional to the number of darts the decoded assignment +fails, so this is the amplification: the powered system's value is bounded below +in terms of the original's. -/ +theorem powering_soundness (A : (R.killedPow q T hq).Assignment) {H : ℕ} + (hH : 2 * H + 1 < T) (hHT : H + 1 ≤ T) + (hsq : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), i + j + 1 < T) + {lam : ℝ} (hlam0 : 0 ≤ lam) (hlam1 : lam < 1) (hspec : R.graph.SpectralBound lam) + (hn : 0 < R.graph.order) + (hBub : 0 < (∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + + 2 * ((q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ((T : ℝ) * (T : ℝ) * (((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) / (R.graph.order : ℝ)) + + (T : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ)))))) : + ((((R.unsatDarts (R.kDecode q T hq A)).card + * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) : ℕ) : ℝ) + / ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ)) ^ 2 + / ((∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + + 2 * ((q : ℝ) ^ T * ((R.graph.deg : ℝ) ^ (T - 2) + * ((T : ℝ) * (T : ℝ) * (((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) / (R.graph.order : ℝ)) + + (T : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) + * ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ)))))) + ≤ (((R.killedPow q T hq).unsatDarts A).card : ℝ) := by + classical + have hK : (0 : ℝ) < ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) := by + have hα : 0 < Fintype.card α := Fintype.card_pos + have hd : 0 < R.graph.deg := R.graph.deg_pos + have : 0 < Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) := by positivity + exact_mod_cast this + have hA0 : (0 : ℝ) ≤ (((R.unsatDarts (R.kDecode q T hq A)).card + * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) : ℕ) : ℝ) + / ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) := by positivity + have hA : (((R.unsatDarts (R.kDecode q T hq A)).card + * ((q - 1) * ((R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H) + * (R.graph.deg ^ T * q ^ T + - Fintype.card α * pluralityLoss R.graph.deg q T H))) : ℕ) : ℝ) + / ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) + ≤ ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) := by + rw [div_le_iff₀ hK] + have h := R.sum_goodCrossings_ge q T hq A hH hHT hsq + linarith [h] + exact R.card_unsatDarts_ge q T hq A hA0 hA + (R.sum_sq_goodCrossings_le q T hq A hlam0 hlam1 hspec hn) hBub + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- The powered system's constraint count. -/ +theorem card_dart_killedPow : + ((R.killedPow q T hq).graph.order * (R.killedPow q T hq).graph.deg : ℕ) + = R.graph.order * (R.graph.deg ^ T * q ^ T) := by + show ((R.graph.killedPower q T hq).order * (R.graph.killedPower q T hq).deg : ℕ) = _ + rw [R.graph.order_killedPower, R.graph.deg_killedPower] + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- A lower bound on the unsatisfied constraints becomes one on the unsatisfied +*fraction*, which is what `unsatVal` and the amplification bookkeeping use. -/ +theorem unsatFrac_killedPow_ge (A : (R.killedPow q T hq).Assignment) {LB : ℝ} + (hLB : LB ≤ (((R.killedPow q T hq).unsatDarts A).card : ℝ)) (hn : 0 < R.graph.order) : + LB / ((R.graph.order * (R.graph.deg ^ T * q ^ T) : ℕ) : ℝ) + ≤ (((R.killedPow q T hq).unsatFrac A : ℚ) : ℝ) := by + have hpos : (0 : ℝ) < ((R.graph.order * (R.graph.deg ^ T * q ^ T) : ℕ) : ℝ) := by + have hd : 0 < R.graph.deg := R.graph.deg_pos + have : 0 < R.graph.order * (R.graph.deg ^ T * q ^ T) := by positivity + exact_mod_cast this + have hfrac : (((R.killedPow q T hq).unsatFrac A : ℚ) : ℝ) + = (((R.killedPow q T hq).unsatDarts A).card : ℝ) + / ((R.graph.order * (R.graph.deg ^ T * q ^ T) : ℕ) : ℝ) := by + rw [RegCSP.unsatFrac, R.card_dart_killedPow q T hq] + push_cast + ring + rw [hfrac] + gcongr + +omit [DecidableEq α] in +/-- A bound holding for every assignment holds for the value. -/ +theorem le_unsatVal_killedPow {LB : ℝ} + (h : ∀ A : (R.killedPow q T hq).Assignment, + LB ≤ (((R.killedPow q T hq).unsatFrac A : ℚ) : ℝ)) : + LB ≤ (((R.killedPow q T hq).unsatVal : ℚ) : ℝ) := by + obtain ⟨A, hA⟩ := (R.killedPow q T hq).exists_assignment_unsatFrac_eq_unsatVal + rw [← hA] + exact h A + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/KilledPlurality.lean b/Complexitylib/Classes/PCP/Internal/KilledPlurality.lean new file mode 100644 index 00000000..d7f3eadf --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/KilledPlurality.lean @@ -0,0 +1,290 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.KilledCSP +public import Complexitylib.Classes.PCP.Internal.FinsetPlurality + +/-! +# Decoding a killed-power assignment + +An assignment of the killed power labels each vertex with opinions that need not +be consistent with one another. Soundness decodes it into a single assignment of +the original system, by plurality, and counts the failed walk constraints against +that. + +The opinion about `v` that a killed walk out of `v` reports is the one its far +end holds, read at the reversed walk — the walk that leads back from that end to +`v`. Letting the killed walk range over all `deg ^ T * q ^ T` labels gives a +multiset of opinions about `v`, and `kPlurality` picks a most frequent one. + +This is the distribution the soundness argument needs, and the reason for the +killed walk law: conditioned on a walk crossing a given dart, its prefix and its +suffix are *independent* killed walks out of that dart's two ends, each governed +by exactly this law. So the plurality bound applies to both ends at once, and +the two bounds multiply. + +## Main definitions + +- `RegCSP.kOpinionAbout` — what the far end of a killed walk says about its start +- `RegCSP.kOpinionCount`, `RegCSP.kPlurality` — the decoded assignment +- `RegCSP.opinionOf` — the report as a function of the effective walk alone +- `RegCSP.card_fibre_opinion` — the reports of one effective length, counted as + walks times the fibre weight +- `RegCSP.kOpinionCount_eq_sum` — the reports split by effective length +- `RegCSP.truthCount`, `RegCSP.card_le_mul_sum_truthCount` — plurality restated + as a weighted sum over the walks out of a vertex + +## Main results + +- `RegCSP.card_le_card_mul_kOpinionCount` — the plurality is reported by at + least a `1 / |α|` fraction of the killed walks out of a vertex +-/ + +@[expose] public section + +namespace Complexity + +namespace RegCSP + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] +variable (R : RegCSP α) (q T : ℕ) (hq : 0 < q) + +/-- The label sequences of the killed power. -/ +abbrev KLabels (R : RegCSP α) (q T : ℕ) : Type := + (Fin T → R.graph.D) × (Fin T → Fin q) + +/-- What the far end of the killed walk `x` out of `v` says about `v`: its +opinion read at the reversed walk, which leads from that end back to `v`. -/ +def kOpinionAbout (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (x : R.KLabels q T) : α := + A (R.graph.killedEnd v x.1 x.2) + ⟨⟨R.graph.kLen x, by have := R.graph.kLen_le x; omega⟩, + R.graph.revWalk v (R.graph.kWalk x)⟩ + +/-- The opinion reported by a killed walk, as a function of its effective length +and effective walk alone. Everything the report depends on — where the walk ends +and the reversed walk it is read at — is determined by those two, so the labels +past the stopping index are free. That is what makes each effective walk carry +the weight `card_killed_fibre` computes. -/ +def opinionOf (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) {m : ℕ} (hm : m ≤ T) + (w : Fin m → R.graph.D) : α := + A (R.graph.walkEnd m v w) ⟨⟨m, by omega⟩, R.graph.revWalk v w⟩ + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +theorem kOpinionAbout_eq_opinionOf (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (x : R.KLabels q T) : + R.kOpinionAbout q T hq A v x + = R.opinionOf q T hq A v (stopAt_le x.2) (R.graph.preWalk x.1 (stopAt_le x.2)) := rfl + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- Two effective walks of the same length with the same labels give the same +report. Stated with the length as a hypothesis rather than by rewriting, since +the walk's type mentions it: `subst` does the transport that `rw` cannot. -/ +theorem opinionOf_congr (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + {m m' : ℕ} (hm : m ≤ T) (hm' : m' ≤ T) (hmm : m = m') + (w : Fin m → R.graph.D) (w' : Fin m' → R.graph.D) + (hw : ∀ (j : ℕ) (hj : j < m) (hj' : j < m'), w ⟨j, hj⟩ = w' ⟨j, hj'⟩) : + R.opinionOf q T hq A v hm w = R.opinionOf q T hq A v hm' w' := by + subst hmm + have hww : w = w' := by + funext j + exact hw j.val j.isLt j.isLt + subst hww + rfl + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- On the fibre of effective length `m`, the report is the one determined by +the length-`m` prefix. -/ +theorem kOpinionAbout_eq_of_stopAt (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (x : R.KLabels q T) {m : ℕ} (hm : m ≤ T) (h : stopAt x.2 = m) : + R.kOpinionAbout q T hq A v x + = R.opinionOf q T hq A v hm (R.graph.preWalk x.1 hm) := by + rw [kOpinionAbout_eq_opinionOf] + exact R.opinionOf_congr q T hq A v (stopAt_le x.2) hm h _ _ fun j hj hj' => rfl + +/-- How many killed walks out of `v` ascribe the value `a` to it. -/ +noncomputable def kOpinionCount (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (a : α) : ℕ := + (Finset.univ.filter fun x : R.KLabels q T => R.kOpinionAbout q T hq A v x = a).card + +omit [Fintype α] [Nonempty α] in +/-- **The fibre partition.** Among the killed walks of effective length `m`, +those reporting `val` are exactly the ones whose effective walk reports `val`, +each carrying the same weight. So the count splits into a count of *walks* times +that weight. -/ +theorem card_fibre_opinion (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (val : α) {m : ℕ} (hm : m < T) : + (Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = val).card + = (Finset.univ.filter fun w : Fin m → R.graph.D => + R.opinionOf q T hq A v (le_of_lt hm) w = val).card + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) := by + classical + have hmaps : ∀ x ∈ (Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = val), + R.graph.preWalk x.1 (le_of_lt hm) ∈ (Finset.univ.filter + fun w : Fin m → R.graph.D => R.opinionOf q T hq A v (le_of_lt hm) w = val) := by + intro x hx + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx ⊢ + rw [← R.kOpinionAbout_eq_of_stopAt q T hq A v x (le_of_lt hm) hx.1] + exact hx.2 + rw [Finset.card_eq_sum_card_fiberwise hmaps] + have hfib : ∀ w ∈ (Finset.univ.filter fun w : Fin m → R.graph.D => + R.opinionOf q T hq A v (le_of_lt hm) w = val), + ((Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = val).filter + fun x => R.graph.preWalk x.1 (le_of_lt hm) = w).card + = R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1)) := by + intro w hw + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hw + have hset : ((Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = val).filter + fun x => R.graph.preWalk x.1 (le_of_lt hm) = w) + = Finset.univ.filter fun x : R.KLabels q T => + R.graph.preWalk x.1 (le_of_lt hm) = w ∧ stopAt x.2 = m := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · rintro ⟨⟨hlen, -⟩, hpre⟩ + exact ⟨hpre, hlen⟩ + · rintro ⟨hpre, hlen⟩ + refine ⟨⟨hlen, ?_⟩, hpre⟩ + rw [R.kOpinionAbout_eq_of_stopAt q T hq A v x (le_of_lt hm) hlen, hpre] + exact hw + rw [hset, R.graph.card_killed_fibre hq hm w] + rw [Finset.sum_congr rfl hfib, Finset.sum_const, smul_eq_mul] + +/-- The plurality decoding: every vertex is given a value that the ends of the +killed walks out of it ascribe to it most often. -/ +noncomputable def kPlurality (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) : α := + Classical.choose (exists_plurality (Finset.univ : Finset (R.KLabels q T)) + (R.kOpinionAbout q T hq A v)) + +/-- **Pigeonhole.** At least a `1 / |α|` fraction of the killed walks out of `v` +report the decoded value. -/ +theorem card_le_card_mul_kOpinionCount (A : (R.killedPow q T hq).Assignment) + (v : R.graph.V) : + Fintype.card (R.KLabels q T) + ≤ Fintype.card α * R.kOpinionCount q T hq A v (R.kPlurality q T hq A v) := by + have h := Classical.choose_spec (exists_plurality (Finset.univ : Finset (R.KLabels q T)) + (R.kOpinionAbout q T hq A v)) + exact h + +omit [Fintype α] [Nonempty α] in +/-- The reports split by effective length. -/ +theorem kOpinionCount_eq_sum (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (val : α) : + R.kOpinionCount q T hq A v val + = ∑ m ∈ Finset.range (T + 1), + (Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = val).card := by + classical + have hmaps : ∀ x ∈ (Finset.univ.filter fun x : R.KLabels q T => + R.kOpinionAbout q T hq A v x = val), stopAt x.2 ∈ Finset.range (T + 1) := by + intro x _ + simp only [Finset.mem_range] + have := stopAt_le x.2 + omega + rw [kOpinionCount, Finset.card_eq_sum_card_fiberwise hmaps] + refine Finset.sum_congr rfl fun m _ => ?_ + congr 1 + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + tauto + +/-- How many length-`m` walks out of `v` have a far end reporting the decoded +value. Total in `m`, so that sums over lengths need no side conditions. -/ +noncomputable def truthCount (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + (m : ℕ) : ℕ := + if hm : m ≤ T then + (Finset.univ.filter fun w : Fin m → R.graph.D => + R.opinionOf q T hq A v hm w = R.kPlurality q T hq A v).card + else 0 + +theorem card_fibre_truth (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) + {m : ℕ} (hm : m < T) : + (Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = R.kPlurality q T hq A v).card + = R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) := by + rw [R.card_fibre_opinion q T hq A v _ hm, truthCount, dif_pos (le_of_lt hm)] + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +theorem card_KLabels : Fintype.card (R.KLabels q T) = R.graph.deg ^ T * q ^ T := by + rw [Fintype.card_prod, Fintype.card_fun, Fintype.card_fun, Fintype.card_fin, + Fintype.card_fin] + rfl + +omit [Fintype α] [DecidableEq α] [Nonempty α] in +/-- The killed walks that never stop. This is the truncation term, and it is an +exponentially small fraction `((q-1)/q) ^ T` of all labels. -/ +theorem card_stopAt_eq_top : + (Finset.univ.filter fun x : R.KLabels q T => stopAt x.2 = T).card + = R.graph.deg ^ T * (q - 1) ^ T := by + classical + have hsig : (Finset.univ.filter fun c : Fin T → Fin q => stopAt c = T).card + = (q - 1) ^ T := by + have hsame : (Finset.univ.filter fun c : Fin T → Fin q => stopAt c = T) + = (Finset.univ.filter fun c : Fin T → Fin q => T ≤ stopAt c) := by + ext c + have := stopAt_le c + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + omega + rw [hsame, card_le_stopAt (le_refl T)] + simp + have hset : (Finset.univ.filter fun x : R.KLabels q T => stopAt x.2 = T) + = (Finset.univ : Finset (Fin T → R.graph.D)) + ×ˢ (Finset.univ.filter fun c : Fin T → Fin q => stopAt c = T) := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_product] + rw [hset, Finset.card_product, hsig, Finset.card_univ, Fintype.card_fun, + Fintype.card_fin] + rfl + +/-- **Plurality, in terms of walks.** At least a `1 / |α|` fraction of all +killed-walk labels report the decoded value, and splitting that count by +effective length turns it into a statement about the *walks* out of `v`: the +weighted sum of `truthCount` is large, up to the exponentially small truncation +term of walks that never stop. + +This is the form the first moment consumes, since the crossing decomposition +produces exactly these weighted sums — one for the prefix and one for the +suffix, with independent lengths. -/ +theorem card_le_mul_sum_truthCount (A : (R.killedPow q T hq).Assignment) + (v : R.graph.V) : + R.graph.deg ^ T * q ^ T + ≤ Fintype.card α * ((∑ m ∈ Finset.range T, + R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1)))) + + R.graph.deg ^ T * (q - 1) ^ T) := by + classical + have h1 := R.card_le_card_mul_kOpinionCount q T hq A v + rw [R.card_KLabels q T, R.kOpinionCount_eq_sum q T hq A v, Finset.sum_range_succ] at h1 + have h2 : ∀ m ∈ Finset.range T, + (Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = m ∧ R.kOpinionAbout q T hq A v x = R.kPlurality q T hq A v).card + = R.truthCount q T hq A v m + * (R.graph.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1))) := by + intro m hm + exact R.card_fibre_truth q T hq A v (Finset.mem_range.mp hm) + rw [Finset.sum_congr rfl h2] at h1 + have h3 : (Finset.univ.filter fun x : R.KLabels q T => + stopAt x.2 = T ∧ R.kOpinionAbout q T hq A v x = R.kPlurality q T hq A v).card + ≤ R.graph.deg ^ T * (q - 1) ^ T := by + rw [← R.card_stopAt_eq_top q T] + refine Finset.card_le_card ?_ + intro x hx + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx ⊢ + exact hx.1 + exact le_trans h1 (Nat.mul_le_mul_left _ (Nat.add_le_add_left h3 _)) + +/-- The decoded assignment of the original system. -/ +noncomputable def kDecode (A : (R.killedPow q T hq).Assignment) : R.Assignment := + fun v => R.kPlurality q T hq A v + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/KilledWalk.lean b/Complexitylib/Classes/PCP/Internal/KilledWalk.lean new file mode 100644 index 00000000..9fcc3930 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/KilledWalk.lean @@ -0,0 +1,404 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Power + +/-! +# Killed walks + +The walk law Dinur's powering step actually needs: at every step the walk stops +with probability `1 / q`, so its length is geometric rather than fixed. + +A dart label is a pair of sequences: `T` edge labels and `T` stop signals. The +walk follows the edge labels until the first signal equal to `0` — the +**stopping index** — and its endpoint is where it stopped. Uniform labels +therefore realise a geometric length exactly, truncated at `T`, with the labels +past the stopping index carrying multiplicity but no meaning. + +## Why geometric and not fixed length + +Soundness decodes an assignment of the powered system by plurality and needs the +opinions at the two ends of a checked step to be truthful. Summed over the +checked steps that amounts to `∑ a_i · b_j` over the prefix length `i` and the +suffix length `j`. With walks of *fixed* length those are tied by `i + j = t - 1` +and the sum can vanish, as `PowerCSP`'s module docstring explains. Killing makes +`i` and `j` **independent**, so the sum factorises into a product of two +plurality bounds. That factorisation is the whole reason for this construction. + +## Reversal + +Reversing a killed walk reverses only its effective prefix and leaves both the +tail and the stop signals alone. Since the signals are untouched, the reversed +walk stops at the same index, which is what makes reversal an involution — the +requirement for the powered graph to be an undirected regular graph at all. + +## Main definitions + +- `stopAt` — the stopping index of a signal sequence +- `RegGraph.preWalk`, `RegGraph.extWalk` — the effective prefix, and + overwriting it +- `RegGraph.killedEnd`, `RegGraph.killedRev` — the endpoint and the reversal +- `RegGraph.killedPower` — the resulting regular graph + +## Main results + +- `signal_ne_zero_of_lt`, `signal_eq_zero_of_stopAt_lt`, `stopAt_eq_of` — what + the stopping index means +- `lt_stopAt_iff` — reaching step `i` depends only on the first `i + 1` signals +- `card_lt_stopAt`, `card_le_stopAt`, `card_stopAt_eq` — how many signal + sequences run for a given number of steps +- `RegGraph.card_preWalk_eq`, `RegGraph.card_killed_fibre` — the weight an + effective walk carries +- `RegGraph.killedEnd_killedRev`, `RegGraph.killedRev_killedRev` — reversal + undoes itself +- `RegGraph.deg_killedPower` — the degree is `deg ^ T * q ^ T` +-/ + +@[expose] public section + +namespace Complexity + +/-- The step at which a killed walk stops: the first index carrying the signal +`0`, or `T` if there is none. -/ +def stopAt {T q : ℕ} (c : Fin T → Fin q) : ℕ := + (List.finRange T).findIdx fun i => (c i).val == 0 + +theorem stopAt_le {T q : ℕ} (c : Fin T → Fin q) : stopAt c ≤ T := by + have h := List.findIdx_le_length (p := fun i : Fin T => (c i).val == 0) + (xs := List.finRange T) + simpa using h + +/-- Before the stopping index every signal is nonzero. -/ +theorem signal_ne_zero_of_lt {T q : ℕ} (c : Fin T → Fin q) {j : ℕ} (hj : j < stopAt c) : + (c ⟨j, lt_of_lt_of_le hj (stopAt_le c)⟩).val ≠ 0 := by + have h := List.not_of_lt_findIdx (p := fun i : Fin T => (c i).val == 0) + (xs := List.finRange T) hj + rw [List.getElem_finRange] at h + simpa using h + +/-- At the stopping index, if it is reached, the signal is zero. -/ +theorem signal_eq_zero_of_stopAt_lt {T q : ℕ} (c : Fin T → Fin q) (h : stopAt c < T) : + (c ⟨stopAt c, h⟩).val = 0 := by + have hlen : stopAt c < (List.finRange T).length := by simpa using h + have hg := List.findIdx_getElem (p := fun i : Fin T => (c i).val == 0) + (xs := List.finRange T) (w := hlen) + rw [List.getElem_finRange] at hg + simpa using hg + +/-- The stopping index is pinned down by the two properties above. -/ +theorem stopAt_eq_of {T q : ℕ} (c : Fin T → Fin q) {m : ℕ} (hm : m ≤ T) + (hlt : ∀ (j : ℕ) (hj : j < m), (c ⟨j, lt_of_lt_of_le hj hm⟩).val ≠ 0) + (hat : ∀ h : m < T, (c ⟨m, h⟩).val = 0) : stopAt c = m := by + rcases lt_trichotomy (stopAt c) m with hlt' | heq | hgt + · have hsT : stopAt c < T := lt_of_lt_of_le hlt' hm + exact absurd (signal_eq_zero_of_stopAt_lt c hsT) (hlt (stopAt c) hlt') + · exact heq + · have hmT : m < T := lt_of_lt_of_le hgt (stopAt_le c) + exact absurd (hat hmT) (signal_ne_zero_of_lt c hgt) + +/-- The walk is still running at step `i` exactly when the first `i + 1` +signals are all nonzero. This is the form the crossing decomposition needs: the +event "the walk reaches step `i`" depends only on the first `i + 1` signal +coordinates, so it splits off as a factor. -/ +theorem lt_stopAt_iff {T q : ℕ} (c : Fin T → Fin q) {i : ℕ} (hi : i < T) : + i < stopAt c ↔ ∀ (j : ℕ) (hj : j ≤ i), (c ⟨j, lt_of_le_of_lt hj hi⟩).val ≠ 0 := by + constructor + · intro h j hj + exact signal_ne_zero_of_lt c (lt_of_le_of_lt hj h) + · intro h + by_contra hcon + have hle : stopAt c ≤ i := by omega + have hsT : stopAt c < T := lt_of_le_of_lt hle hi + exact h (stopAt c) hle (signal_eq_zero_of_stopAt_lt c hsT) + +/-- **The signal count.** The walks still running at step `i` are exactly those +whose first `i + 1` signals are all nonzero, and those coordinates are free of +one another, so they number `(q-1) ^ (i+1) * q ^ (T-i-1)`. This is the factor +that the crossing decomposition peels off. -/ +theorem card_lt_stopAt {T q : ℕ} {i : ℕ} (hi : i < T) : + (Finset.univ.filter fun c : Fin T → Fin q => i < stopAt c).card + = (q - 1) ^ (i + 1) * q ^ (T - i - 1) := by + classical + have hset : (Finset.univ.filter fun c : Fin T → Fin q => i < stopAt c) + = Fintype.piFinset fun j : Fin T => + if j.val ≤ i then Finset.univ.filter (fun x : Fin q => x.val ≠ 0) + else Finset.univ := by + ext c + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Fintype.mem_piFinset] + rw [lt_stopAt_iff c hi] + constructor + · intro h j + by_cases hj : j.val ≤ i + · simp only [hj, if_true, Finset.mem_filter, Finset.mem_univ, true_and] + simpa using h j.val hj + · simp [hj] + · intro h j hj + have hmem := h ⟨j, lt_of_le_of_lt hj hi⟩ + simp only [hj, if_true, Finset.mem_filter, Finset.mem_univ, true_and] at hmem + exact hmem + have hnz : (Finset.univ.filter (fun x : Fin q => x.val ≠ 0)).card = q - 1 := by + rcases Nat.eq_zero_or_pos q with hq0 | hq0 + · subst hq0 + simp + · have hcompl : (Finset.univ.filter (fun x : Fin q => x.val ≠ 0)).card + + (Finset.univ.filter (fun x : Fin q => ¬ x.val ≠ 0)).card = q := by + rw [Finset.card_filter_add_card_filter_not] + simp + have hone : (Finset.univ.filter (fun x : Fin q => ¬ x.val ≠ 0)).card = 1 := by + have hsingle : (Finset.univ.filter (fun x : Fin q => ¬ x.val ≠ 0)) = {⟨0, hq0⟩} := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, not_not, + Finset.mem_singleton] + constructor + · intro hx; exact Fin.ext hx + · intro hx; rw [hx] + rw [hsingle, Finset.card_singleton] + omega + have hle : (Finset.univ.filter fun j : Fin T => j.val ≤ i).card = i + 1 := by + have himg : (Finset.univ.filter fun j : Fin T => j.val ≤ i).image Fin.val + = Finset.range (i + 1) := by + ext n + simp only [Finset.mem_image, Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_range] + constructor + · rintro ⟨j, hj, rfl⟩; omega + · intro hn + exact ⟨⟨n, by omega⟩, by simpa using by omega, rfl⟩ + have hcard := congrArg Finset.card himg + rw [Finset.card_image_of_injective _ Fin.val_injective, Finset.card_range] at hcard + exact hcard + have hgt : (Finset.univ.filter fun j : Fin T => ¬ j.val ≤ i).card = T - i - 1 := by + have hsum : (Finset.univ.filter fun j : Fin T => j.val ≤ i).card + + (Finset.univ.filter fun j : Fin T => ¬ j.val ≤ i).card = T := by + rw [Finset.card_filter_add_card_filter_not] + simp + omega + rw [hset, Fintype.card_piFinset] + simp only [apply_ite Finset.card, hnz, Finset.card_univ, Fintype.card_fin] + rw [Finset.prod_ite, Finset.prod_const, Finset.prod_const, hle, hgt] + +/-- The walks that are still running *at* step `m`, i.e. run for at least `m` +steps. -/ +theorem card_le_stopAt {T q : ℕ} {m : ℕ} (hm : m ≤ T) : + (Finset.univ.filter fun c : Fin T → Fin q => m ≤ stopAt c).card + = (q - 1) ^ m * q ^ (T - m) := by + cases m with + | zero => + have huniv : (Finset.univ.filter fun c : Fin T → Fin q => 0 ≤ stopAt c) + = Finset.univ := by + ext c + simp + rw [huniv] + simp + | succ k => + have hk : k < T := by omega + have hsame : (Finset.univ.filter fun c : Fin T → Fin q => k + 1 ≤ stopAt c) + = (Finset.univ.filter fun c : Fin T → Fin q => k < stopAt c) := by + ext c + simp + rw [hsame, card_lt_stopAt hk] + congr 1 + +/-- **The exact-length signal count.** The walks of effective length exactly `m` +number `(q-1) ^ m * q ^ (T-m-1)`: the first `m` signals are nonzero, the `m`-th +is zero, and the rest are free. -/ +theorem card_stopAt_eq {T q : ℕ} (hq : 0 < q) {m : ℕ} (hm : m < T) : + (Finset.univ.filter fun c : Fin T → Fin q => stopAt c = m).card + = (q - 1) ^ m * q ^ (T - m - 1) := by + classical + have hsub : (Finset.univ.filter fun c : Fin T → Fin q => m < stopAt c) + ⊆ (Finset.univ.filter fun c : Fin T → Fin q => m ≤ stopAt c) := by + intro c hc + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hc ⊢ + omega + have hdiff : (Finset.univ.filter fun c : Fin T → Fin q => stopAt c = m) + = (Finset.univ.filter fun c : Fin T → Fin q => m ≤ stopAt c) + \ (Finset.univ.filter fun c : Fin T → Fin q => m < stopAt c) := by + ext c + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_sdiff, not_lt] + omega + rw [hdiff, Finset.card_sdiff, Finset.inter_eq_left.mpr hsub, + card_le_stopAt (le_of_lt hm), card_lt_stopAt hm] + have hsplit : q ^ (T - m) = q * q ^ (T - m - 1) := by + rw [← pow_succ'] + congr 1 + omega + rw [hsplit, pow_succ] + cases q with + | zero => omega + | succ p => + have hone : p + 1 - 1 = p := by omega + rw [hone] + refine Nat.sub_eq_of_eq_add ?_ + ring + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Prefixes -/ + +/-- The first `ℓ` labels of a length-`T` sequence. -/ +def preWalk {T : ℕ} (s : Fin T → G.D) {ℓ : ℕ} (h : ℓ ≤ T) : Fin ℓ → G.D := + fun j => s ⟨j.val, lt_of_lt_of_le j.isLt h⟩ + +/-- Overwrite the first `ℓ` labels of a sequence. -/ +def extWalk {T ℓ : ℕ} (r : Fin ℓ → G.D) (s : Fin T → G.D) : Fin T → G.D := + fun i => if h : i.val < ℓ then r ⟨i.val, h⟩ else s i + +theorem preWalk_extWalk {T ℓ : ℕ} (h : ℓ ≤ T) (r : Fin ℓ → G.D) (s : Fin T → G.D) : + G.preWalk (G.extWalk r s) h = r := by + funext j + simp [preWalk, extWalk, j.isLt] + +theorem extWalk_extWalk {T ℓ : ℕ} (r r' : Fin ℓ → G.D) (s : Fin T → G.D) : + G.extWalk r' (G.extWalk r s) = G.extWalk r' s := by + funext i + by_cases hi : i.val < ℓ <;> simp [extWalk, hi] + +theorem extWalk_preWalk {T ℓ : ℕ} (h : ℓ ≤ T) (s : Fin T → G.D) : + G.extWalk (G.preWalk s h) s = s := by + funext i + by_cases hi : i.val < ℓ <;> simp [extWalk, preWalk, hi] + +/-- How many label sequences begin with a prescribed length-`m` walk: the first +`m` coordinates are pinned and the rest are free. -/ +theorem card_preWalk_eq {T m : ℕ} (hm : m ≤ T) (w : Fin m → G.D) : + (Finset.univ.filter fun s : Fin T → G.D => G.preWalk s hm = w).card + = G.deg ^ (T - m) := by + classical + have hset : (Finset.univ.filter fun s : Fin T → G.D => G.preWalk s hm = w) + = Fintype.piFinset fun j : Fin T => + if hj : j.val < m then {w ⟨j.val, hj⟩} else Finset.univ := by + ext s + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Fintype.mem_piFinset] + constructor + · intro h j + by_cases hj : j.val < m + · simp only [hj, dif_pos, Finset.mem_singleton] + have hval := congrFun h ⟨j.val, hj⟩ + simpa [preWalk] using hval + · simp [hj] + · intro h + funext j + have hmem := h ⟨j.val, lt_of_lt_of_le j.isLt hm⟩ + simp only [j.isLt, dif_pos, Finset.mem_singleton] at hmem + simpa [preWalk] using hmem + have hlt : (Finset.univ.filter fun j : Fin T => j.val < m).card = m := by + have himg : (Finset.univ.filter fun j : Fin T => j.val < m).image Fin.val + = Finset.range m := by + ext n + simp only [Finset.mem_image, Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_range] + constructor + · rintro ⟨j, hj, rfl⟩; exact hj + · intro hn + exact ⟨⟨n, by omega⟩, by simpa using hn, rfl⟩ + have hcard := congrArg Finset.card himg + rw [Finset.card_image_of_injective _ Fin.val_injective, Finset.card_range] at hcard + exact hcard + have hge : (Finset.univ.filter fun j : Fin T => ¬ j.val < m).card = T - m := by + have hsum : (Finset.univ.filter fun j : Fin T => j.val < m).card + + (Finset.univ.filter fun j : Fin T => ¬ j.val < m).card = T := by + rw [Finset.card_filter_add_card_filter_not] + simp + omega + rw [hset, Fintype.card_piFinset] + simp only [apply_dite Finset.card, Finset.card_singleton, Finset.card_univ, + dite_eq_ite] + rw [Finset.prod_ite, Finset.prod_const, Finset.prod_const, hlt, hge] + simp + +/-- **The fibre count.** The killed-walk labels whose effective walk is exactly +a prescribed length-`m` walk number `deg ^ (T-m) * (q-1) ^ m * q ^ (T-m-1)`: the +two conditions constrain the edge labels and the signals separately, so the +counts multiply. This is the weight each effective walk carries, and it is +geometric in `m` — the law both the plurality and the conditional prefix and +suffix follow. -/ +theorem card_killed_fibre {T q m : ℕ} (hq : 0 < q) (hm : m < T) (w : Fin m → G.D) : + (Finset.univ.filter fun x : (Fin T → G.D) × (Fin T → Fin q) => + G.preWalk x.1 (le_of_lt hm) = w ∧ stopAt x.2 = m).card + = G.deg ^ (T - m) * ((q - 1) ^ m * q ^ (T - m - 1)) := by + classical + have hset : (Finset.univ.filter fun x : (Fin T → G.D) × (Fin T → Fin q) => + G.preWalk x.1 (le_of_lt hm) = w ∧ stopAt x.2 = m) + = (Finset.univ.filter fun s : Fin T → G.D => G.preWalk s (le_of_lt hm) = w) + ×ˢ (Finset.univ.filter fun c : Fin T → Fin q => stopAt c = m) := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_product] + rw [hset, Finset.card_product, G.card_preWalk_eq (le_of_lt hm) w, card_stopAt_eq hq hm] + +/-! ### Killed walks -/ + +/-- Where a killed walk ends: it follows the edge labels up to the stopping +index. -/ +def killedEnd {T q : ℕ} (v : G.V) (s : Fin T → G.D) (c : Fin T → Fin q) : G.V := + G.walkEnd (stopAt c) v (G.preWalk s (stopAt_le c)) + +/-- A killed walk reversed: the effective prefix is reversed, the tail and the +stop signals are left alone. -/ +def killedRev {T q : ℕ} (v : G.V) (s : Fin T → G.D) (c : Fin T → Fin q) : Fin T → G.D := + G.extWalk (G.revWalk v (G.preWalk s (stopAt_le c))) s + +theorem killedEnd_killedRev {T q : ℕ} (v : G.V) (s : Fin T → G.D) (c : Fin T → Fin q) : + G.killedEnd (G.killedEnd v s c) (G.killedRev v s c) c = v := by + rw [killedEnd, killedRev, killedEnd, G.preWalk_extWalk (stopAt_le c)] + exact G.walkEnd_revWalk v (G.preWalk s (stopAt_le c)) + +theorem killedRev_killedRev {T q : ℕ} (v : G.V) (s : Fin T → G.D) (c : Fin T → Fin q) : + G.killedRev (G.killedEnd v s c) (G.killedRev v s c) c = s := by + rw [killedRev, killedRev, G.preWalk_extWalk (stopAt_le c), killedEnd, + G.revWalk_revWalk, G.extWalk_extWalk, G.extWalk_preWalk] + +/-! ### The killed power graph -/ + +/-- The killed power of `G`: a dart label is `T` edge labels together with `T` +stop signals, and the neighbour is where the walk stops. -/ +def killedPower (G : RegGraph) (q T : ℕ) (hq : 0 < q) : RegGraph where + V := G.V + D := (Fin T → G.D) × (Fin T → Fin q) + decEqV := G.decEqV + decEqD := by + haveI := G.decEqD + infer_instance + fintypeV := G.fintypeV + fintypeD := by + haveI := G.fintypeD + haveI := G.decEqD + infer_instance + nonemptyD := by + haveI := G.nonemptyD + haveI : Nonempty (Fin q) := ⟨⟨0, hq⟩⟩ + infer_instance + rot x := (G.killedEnd x.1 x.2.1 x.2.2, (G.killedRev x.1 x.2.1 x.2.2, x.2.2)) + rot_involutive := by + rintro ⟨v, s, c⟩ + dsimp only + rw [G.killedEnd_killedRev, G.killedRev_killedRev] + +@[simp] theorem V_killedPower (q T : ℕ) (hq : 0 < q) : (G.killedPower q T hq).V = G.V := rfl + +@[simp] theorem order_killedPower (q T : ℕ) (hq : 0 < q) : + (G.killedPower q T hq).order = G.order := rfl + +theorem nbr_killedPower (q T : ℕ) (hq : 0 < q) (v : G.V) + (x : (Fin T → G.D) × (Fin T → Fin q)) : + (G.killedPower q T hq).nbr v x = G.killedEnd v x.1 x.2 := rfl + +/-- The killed power is regular of degree `deg ^ T * q ^ T`. -/ +theorem deg_killedPower (q T : ℕ) (hq : 0 < q) : + (G.killedPower q T hq).deg = G.deg ^ T * q ^ T := by + have h : Fintype.card ((Fin T → G.D) × (Fin T → Fin q)) = G.deg ^ T * q ^ T := by + rw [Fintype.card_prod, Fintype.card_fun, Fintype.card_fun, Fintype.card_fin, + Fintype.card_fin] + rfl + calc (G.killedPower q T hq).deg + = Fintype.card ((Fin T → G.D) × (Fin T → Fin q)) := Fintype.card_congr (Equiv.refl _) + _ = G.deg ^ T * q ^ T := h + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/LengthMod.lean b/Complexitylib/Classes/PCP/Internal/LengthMod.lean new file mode 100644 index 00000000..dfbb66f4 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/LengthMod.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal +public import Complexitylib.Classes.P.FinsetDomain +public import Complexitylib.Classes.P.UnaryLength +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.P.DecisionFn +public import Complexitylib.Classes.Containments.Internal.FPBridge + +/-! +# Counting an input's length modulo four + +A single polynomial-time language, built because the analysis of the `PCP` +statement needs one concrete verdict that depends on the length of its input: +the strings whose length is divisible by four. + +The construction is the obvious one, assembled from the existing toolkit rather +than from a machine. A counter with four states is a *finite* function, so +`ite_mem_finset_mem_FP` puts one step of it in `FP`; `unaryLength_mem_FP` +supplies one tick per input bit; and `iterate_mem_FP` runs the ticks. + +## Main definitions + +- `Complexity.ctrStep` — one step of a counter modulo four +- `Complexity.lenMod4` — the language of lengths divisible by four + +## Main results + +- `Complexity.lenMod4_mem_P` — it is polynomial-time decidable +-/ + +@[expose] public section + +namespace Complexity + +/-- The four states of the counter, as unary strings. -/ +def ctrVals : Finset (List Bool) := {[], [true], [true, true], [true, true, true]} + +/-- One step of a counter modulo four. Outside the four states it resets, which +keeps the function total without leaving the finite table. -/ +def ctrStep (s : List Bool) : List Bool := + if s ∈ ctrVals then (if s.length = 3 then [] else s ++ [true]) else [] + +theorem ctrStep_mem_FP : ctrStep ∈ FP := + ite_mem_finset_mem_FP (fun s => if s.length = 3 then [] else s ++ [true]) ctrVals + +theorem replicate_mem_ctrVals {k : ℕ} (hk : k < 4) : + List.replicate k true ∈ ctrVals := by + match k, hk with + | 0, _ => decide + | 1, _ => decide + | 2, _ => decide + | 3, _ => decide + +/-- **The counter counts.** -/ +theorem ctrStep_iterate (n : ℕ) : ctrStep^[n] [] = List.replicate (n % 4) true := by + induction n with + | zero => rfl + | succ m ih => + rw [Function.iterate_succ_apply', ih, ctrStep, + if_pos (replicate_mem_ctrVals (Nat.mod_lt _ (by norm_num)))] + have hlen : (List.replicate (m % 4) true).length = m % 4 := List.length_replicate + rw [hlen] + by_cases h3 : m % 4 = 3 + · rw [if_pos h3] + have : (m + 1) % 4 = 0 := by omega + rw [this] + rfl + · rw [if_neg h3] + have hm : (m + 1) % 4 = m % 4 + 1 := by + have := Nat.mod_lt m (show 0 < 4 by norm_num) + omega + rw [hm, List.replicate_succ'] + +theorem length_ctrStep_iterate_le (n : ℕ) : (ctrStep^[n] []).length ≤ 3 := by + rw [ctrStep_iterate, List.length_replicate] + omega + +/-- The counter, run once per input bit. -/ +def lenCtr (z : List Bool) : List Bool := ctrStep^[z.length] [] + +theorem lenCtr_mem_FP : lenCtr ∈ FP := by + have hiter := Cobham.iterate_mem_FP (F := ctrStep) (init := fun _ : List Bool => []) + (ruler := fun z : List Bool => List.replicate z.length true) + (width := fun _ : List Bool => [true, true, true]) + ctrStep_mem_FP (constFn_mem_FP []) unaryLength_mem_FP + (constFn_mem_FP [true, true, true]) + (fun z n _ => by + have := length_ctrStep_iterate_le n + simpa using this) + refine mem_FP_of_eq hiter fun z => ?_ + rw [lenCtr, List.length_replicate] + +/-- Reading the counter: it is zero exactly on the multiples of four. -/ +def ctrIsZero (s : List Bool) : List Bool := + if s ∈ ctrVals then (if s = [] then [true] else [false]) else [] + +theorem ctrIsZero_mem_FP : ctrIsZero ∈ FP := + ite_mem_finset_mem_FP (fun s => if s = [] then [true] else [false]) ctrVals + +/-- **The language of lengths divisible by four.** -/ +def lenMod4 : Language := {z | z.length % 4 = 0} + +theorem lenMod4_mem_P : lenMod4 ∈ P := by + refine mem_P_of_decisionFn_bool (g := fun z => decide (z.length % 4 = 0)) ?_ ?_ + · refine mem_FP_of_eq (mem_FP_comp lenCtr_mem_FP ctrIsZero_mem_FP) fun z => ?_ + show ctrIsZero (lenCtr z) = _ + rw [lenCtr, ctrStep_iterate, ctrIsZero, + if_pos (replicate_mem_ctrVals (Nat.mod_lt _ (by norm_num)))] + by_cases h : z.length % 4 = 0 + · rw [h] + simp [h] + · rw [if_neg (by + intro hnil + exact h (by + have := congrArg List.length hnil + rw [List.length_replicate] at this + simpa using this))] + simp [h] + · intro z + show z ∈ lenMod4 ↔ _ + rw [lenMod4] + simp + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ListEncode.lean b/Complexitylib/Classes/PCP/Internal/ListEncode.lean new file mode 100644 index 00000000..c419e439 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ListEncode.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.NatEncode + +/-! +# Writing out a list of encoded entries + +The encoding of a list is its entries' encodings run together inside one pair of +brackets. So a machine that can produce each entry's encoding can produce the +list's, by accumulating them in a loop. + +The loop is `iterate_mem_FP`, and the state carries the accumulated bits, the +counter, and the input the entries are read from. + +## Main definitions + +- `Complexity.listStep` — append the next entry's encoding + +## Main results + +- `Complexity.listStep_iterate` — what the loop accumulates +- `Complexity.bitstringEncode_of_entries` — the accumulation is the encoding +- `Complexity.listEncFn_mem_FP`, `Complexity.listEncFn_eq` — the loop is + polynomial time and writes the encoding +-/ + +@[expose] public section + +namespace Complexity + +/-- One step: append the next entry's encoding and advance the counter. The +state is `pair (pair accumulated counter) input`. -/ +def listStep (E : List Bool → List Bool) (st : List Bool) : List Bool := + pair (pair (Cobham.fstBlock (Cobham.fstBlock st) + ++ E (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) + (true :: Cobham.sndBlock (Cobham.fstBlock st))) (Cobham.sndBlock st) + +theorem listStep_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : listStep E ∈ FP := by + have hacc : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hctr : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hx : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hE' : (fun st : List Bool => + E (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP hx hctr) hE + simpa [Function.comp] using this + exact Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hacc hE') + (mem_FP_comp hctr (Cobham.cons_mem_FP true))) hx + +/-- The bits the loop has accumulated after `n` steps. -/ +def entryCat (E : List Bool → List Bool) (x : List Bool) (n : ℕ) : List Bool := + (List.range n).flatMap fun i => E (pair x (List.replicate i true)) + +@[simp] theorem entryCat_zero (E : List Bool → List Bool) (x : List Bool) : + entryCat E x 0 = [] := by + rw [entryCat] + simp + +theorem entryCat_succ (E : List Bool → List Bool) (x : List Bool) (n : ℕ) : + entryCat E x (n + 1) = entryCat E x n ++ E (pair x (List.replicate n true)) := by + rw [entryCat, entryCat, List.range_succ, List.flatMap_append] + simp + +/-- **What the loop accumulates.** -/ +theorem listStep_iterate (E : List Bool → List Bool) (x : List Bool) : + ∀ n : ℕ, (listStep E)^[n] (pair (pair [] []) x) + = pair (pair (entryCat E x n) (List.replicate n true)) x := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply', ih, listStep, Cobham.fstBlock_pair, + Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + entryCat_succ, List.replicate_succ] + +/-- **The accumulation is the encoding.** If each step writes the encoding of +the corresponding entry, the loop writes the inner part of the list's own +encoding. -/ +theorem bitstringEncode_of_entries {α : Type} [DataEncode α] + {E : List Bool → List Bool} {x : List Bool} (l : List α) + (h : ∀ i, ∀ hi : i < l.length, + E (pair x (List.replicate i true)) = DataEncode.bitstringEncode (l[i]'hi)) : + DataEncode.bitstringEncode l = false :: entryCat E x l.length ++ [true] := by + have hcat : entryCat E x l.length = (l.map DataEncode.bitstringEncode).flatten := by + rw [entryCat] + have : (List.range l.length).map (fun i => E (pair x (List.replicate i true))) + = l.map DataEncode.bitstringEncode := by + refine List.ext_getElem (by simp) fun i h1 h2 => ?_ + have hi : i < l.length := by simpa using h2 + rw [List.getElem_map, List.getElem_map, List.getElem_range] + exact h i hi + rw [List.flatMap_def, this] + rw [hcat, DataEncode.bitstringEncode_def, + show DataEncode.encode l = Data.l (l.map DataEncode.encode) from rfl, + Data.toBits_l, List.map_map] + congr 2 + +theorem length_entryCat_le (E : List Bool → List Bool) (x : List Bool) (b : ℕ) : + ∀ n, (∀ i < n, (E (pair x (List.replicate i true))).length ≤ b) → + (entryCat E x n).length ≤ n * b := by + intro n + induction n with + | zero => intro _; simp + | succ n ih => + intro h + have hih := ih fun i hi => h i (by omega) + rw [entryCat_succ, List.length_append] + have hn := h n (by omega) + have hexp : (n + 1) * b = n * b + b := by ring + omega + +/-! ### The loop as one function -/ + +/-- **The list encoder**, on `pair (unary count) input`. -/ +noncomputable def listEncFn (E : List Bool → List Bool) (z : List Bool) : List Bool := + false :: Cobham.fstBlock (Cobham.fstBlock + ((listStep E)^[(Cobham.fstBlock z).length] (pair (pair [] []) (Cobham.sndBlock z)))) + ++ [true] + +theorem listEncFn_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) (p : Polynomial ℕ) + (hbound : ∀ z : List Bool, ∀ k ≤ (Cobham.fstBlock z).length, + ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z))).length + ≤ p.eval z.length) : + listEncFn E ∈ FP := by + have hinit : (fun z : List Bool => pair (pair [] []) (Cobham.sndBlock z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP (pair [] [])) Cobham.sndBlock_mem_FP + have hwidth : (fun z : List Bool => polyRuler p (id z)) ∈ FP := + polyRulerFn_mem_FP p id_mem_FP + have hbound' : ∀ z : List Bool, ∀ k ≤ (Cobham.fstBlock z).length, + ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z))).length + ≤ (polyRuler p (id z)).length := by + intro z k hk + rw [polyRuler_length] + exact hbound z k hk + have hiter := Cobham.iterate_mem_FP (listStep_mem_FP hE) hinit + Cobham.fstBlock_mem_FP hwidth hbound' + have hproj := mem_FP_comp (mem_FP_comp hiter Cobham.fstBlock_mem_FP) + Cobham.fstBlock_mem_FP + have hcons := mem_FP_comp hproj (Cobham.cons_mem_FP false) + have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) + refine mem_FP_of_eq this fun z => ?_ + rw [listEncFn] + simp [Function.comp] + +theorem listEncFn_eq (E : List Bool → List Bool) (z : List Bool) : + listEncFn E z + = false :: entryCat E (Cobham.sndBlock z) (Cobham.fstBlock z).length ++ [true] := by + rw [listEncFn, listStep_iterate, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + +/-- **The loop writes the list's encoding.** -/ +theorem listEncFn_eq_bitstringEncode {α : Type} [DataEncode α] + {E : List Bool → List Bool} {z : List Bool} (l : List α) + (hn : (Cobham.fstBlock z).length = l.length) + (h : ∀ i, ∀ hi : i < l.length, + E (pair (Cobham.sndBlock z) (List.replicate i true)) + = DataEncode.bitstringEncode (l[i]'hi)) : + listEncFn E z = DataEncode.bitstringEncode l := by + rw [listEncFn_eq, hn, ← bitstringEncode_of_entries l h] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/LocalTest.lean b/Complexitylib/Classes/PCP/Internal/LocalTest.lean new file mode 100644 index 00000000..bc721642 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/LocalTest.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph +public import Complexitylib.Classes.PCP.Internal.CubeBlocks +public import Complexitylib.Classes.PCP.Internal.NumEnc + +/-! +# From a many-query test to a binary constraint graph + +An assignment tester reads a handful of positions of its proof per random +string, but a constraint graph checks *two* vertices per edge. The standard +repair is to add a vertex for each random string, labelled by the answers the +tester expects to see, and to connect it to each position it reads: the edge +checks that the claimed answer matches the position's actual bit and that the +claimed answers together pass the test. A rejecting random string then has at +least one of its `q` edges violated — either the claimed answers fail the test +outright, or they pass and so must disagree with the proof somewhere. + +This module carries out that transformation for a **family** of tests indexed by +a type `E` — one per edge of the outer graph, in the composition — over a shared +set of positions. The edges of the result are the triples `(e, z, i)`: test `e`, +random string `z`, read `i`. + +## Main definitions + +- `Complexity.MultiTest` — a family of many-query tests on a shared proof +- `Complexity.MultiTest.toGraph` — the binary constraint graph + +## Main results + +- `Complexity.MultiTest.card_rejects_le_card_unsatEdges` — every rejecting + random string accounts for a distinct violated edge +- `Complexity.MultiTest.satisfiable_toGraph` — a proof accepted everywhere + gives a satisfying assignment +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +/-- A family of tests, indexed by `E`, reading a shared proof over positions +`Pos`. A test uses `R` random bits, reads `q` positions chosen from its random +string, and decides from the bits it read. -/ +structure MultiTest (Pos E Q : Type) where + /-- The number of random bits. -/ + R : ℕ + /-- The positions read, indexed by `Q`, as a function of the test and its + random string. -/ + pos : E → Cube R → Q → Pos + /-- The verdict, as a function of the bits read. -/ + check : E → Cube R → (Q → ZMod 2) → Bool + +namespace MultiTest + +variable {Pos E Q : Type} (M : MultiTest Pos E Q) + +/-- A proof: one bit per position. -/ +abbrev Table (Pos : Type) : Type := Pos → ZMod 2 + +/-- Test `e` accepts the proof `T` on random string `z`. -/ +def accepts (T : Table Pos) (e : E) (z : Cube M.R) : Bool := + M.check e z fun i => T (M.pos e z i) + +/-- The random strings on which test `e` rejects `T`. -/ +def rejects (T : Table Pos) (e : E) : Finset (Cube M.R) := + Finset.univ.filter fun z => M.accepts T e z = false + +/-! ### The binary graph -/ + +/-- The vertices of the binary graph: the positions, and one vertex per +(test, random string). -/ +abbrev Vert : Type := Pos ⊕ (E × Cube M.R) + +/-- The edges: one per (test, random string, read). -/ +abbrev Edge : Type := E × Cube M.R × Q + +/-- The alphabet: a bit (used at positions) paired with a tuple of claimed +answers (used at test vertices). -/ +abbrev Alpha (Q : Type) : Type := ZMod 2 × (Q → ZMod 2) + +/-- A random string is numbered by its own enumeration: the number of random +bits is a constant, so this is a lookup on a bounded key. -/ +noncomputable instance (priority := 2000) instNumEncCube (n : ℕ) : NumEnc (Cube n) := + NumEnc.ofFintype _ + +section Graph + +variable [Fintype Pos] [Fintype E] [Fintype Q] [NumEnc Pos] [NumEnc E] [NumEnc Q] + +/-- The edge a `Fin` index stands for. -/ +noncomputable def edgeOf (k : Fin (Fintype.card M.Edge)) : M.Edge := + (NumEnc.equivFinCard M.Edge).symm k + +/-- The `Fin` index of a vertex. -/ +noncomputable def vertIdx (v : M.Vert) : Fin (Fintype.card M.Vert) := + NumEnc.equivFinCard M.Vert v + +/-- **The binary constraint graph.** Edge `(e, z, i)` runs from the test vertex +`(e, z)` to the position `pos e z i`, and holds when the test vertex's claimed +answers pass test `e` on `z` and its `i`-th claimed answer is the position's +bit. -/ +noncomputable def toGraph : ConstraintGraph (Alpha Q) where + numVerts := Fintype.card M.Vert + numEdges := Fintype.card M.Edge + tail := fun k => M.vertIdx (Sum.inr ((M.edgeOf k).1, (M.edgeOf k).2.1)) + head := fun k => M.vertIdx (Sum.inl (M.pos (M.edgeOf k).1 (M.edgeOf k).2.1 (M.edgeOf k).2.2)) + rel := fun k l₁ l₂ => + decide (M.check (M.edgeOf k).1 (M.edgeOf k).2.1 l₁.2 = true + ∧ l₁.2 (M.edgeOf k).2.2 = l₂.1) + +/-- The proof an assignment of the binary graph carries at its positions. -/ +noncomputable def tableOf (A : M.toGraph.Assignment) : Table Pos := + fun p => (A (M.vertIdx (Sum.inl p))).1 + +/-- The constraint of edge `(e, z, i)`, spelled out. -/ +theorem satisfies_toGraph_iff (A : M.toGraph.Assignment) (k : Fin (Fintype.card M.Edge)) : + M.toGraph.Satisfies A k ↔ + (M.check (M.edgeOf k).1 (M.edgeOf k).2.1 + (A (M.vertIdx (Sum.inr ((M.edgeOf k).1, (M.edgeOf k).2.1)))).2 = true + ∧ (A (M.vertIdx (Sum.inr ((M.edgeOf k).1, (M.edgeOf k).2.1)))).2 (M.edgeOf k).2.2 + = M.tableOf A (M.pos (M.edgeOf k).1 (M.edgeOf k).2.1 (M.edgeOf k).2.2)) := by + show decide _ = true ↔ _ + rw [decide_eq_true_iff] + rfl + +/-- The `Fin` index of an edge. -/ +noncomputable def edgeIdx (x : M.Edge) : Fin (Fintype.card M.Edge) := + NumEnc.equivFinCard M.Edge x + +omit [Fintype Pos] [NumEnc Pos] in +@[simp] theorem edgeOf_edgeIdx (x : M.Edge) : M.edgeOf (M.edgeIdx x) = x := + Equiv.symm_apply_apply _ _ + +/-- **A rejecting random string has a violated edge.** Either the claimed +answers fail the test, so every edge of the string is violated, or they pass and +therefore differ from the proof at some read. (With no reads there would be no +edges, so the test must read at least once.) -/ +theorem exists_unsat_of_rejects [Nonempty Q] (A : M.toGraph.Assignment) (e : E) + (z : Cube M.R) (hz : z ∈ M.rejects (M.tableOf A) e) : + ∃ i : Q, ¬ M.toGraph.Satisfies A (M.edgeIdx (e, z, i)) := by + classical + simp only [rejects, Finset.mem_filter, Finset.mem_univ, true_and] at hz + by_contra hall + push Not at hall + have hq' : ∀ i, (A (M.vertIdx (Sum.inr (e, z)))).2 i = M.tableOf A (M.pos e z i) := + fun i => by + have h := (M.satisfies_toGraph_iff A (M.edgeIdx (e, z, i))).1 (hall i) + simp only [edgeOf_edgeIdx] at h + exact h.2 + obtain ⟨i₀⟩ := ‹Nonempty Q› + have h := (M.satisfies_toGraph_iff A (M.edgeIdx (e, z, i₀))).1 (hall i₀) + simp only [edgeOf_edgeIdx] at h + have hcheck : M.check e z (A (M.vertIdx (Sum.inr (e, z)))).2 = true := h.1 + rw [funext hq'] at hcheck + have hz' : M.check e z (fun i => M.tableOf A (M.pos e z i)) = false := hz + rw [hz'] at hcheck + exact Bool.false_ne_true hcheck + +/-- A violated edge chosen for each rejecting string. -/ +noncomputable def witnessEdge [Nonempty Q] (A : M.toGraph.Assignment) + (x : E × Cube M.R) : Fin (Fintype.card M.Edge) := + if h : x.2 ∈ M.rejects (M.tableOf A) x.1 then + M.edgeIdx (x.1, x.2, Classical.choose (M.exists_unsat_of_rejects A x.1 x.2 h)) + else M.edgeIdx (x.1, x.2, Classical.arbitrary Q) + +theorem witnessEdge_mem [Nonempty Q] (A : M.toGraph.Assignment) (x : E × Cube M.R) + (hx : x.2 ∈ M.rejects (M.tableOf A) x.1) : + M.witnessEdge A x ∈ M.toGraph.unsatEdges A := by + classical + rw [witnessEdge, dif_pos hx] + exact Finset.mem_filter.2 + ⟨Finset.mem_univ _, Classical.choose_spec (M.exists_unsat_of_rejects A x.1 x.2 hx)⟩ + +theorem witnessEdge_injective [Nonempty Q] (A : M.toGraph.Assignment) : + Function.Injective (M.witnessEdge A) := by + intro x y hxy + have hx : M.edgeOf (M.witnessEdge A x) = M.edgeOf (M.witnessEdge A y) := by rw [hxy] + simp only [witnessEdge] at hx + split_ifs at hx <;> simp only [edgeOf_edgeIdx, Prod.mk.injEq] at hx <;> + exact Prod.ext hx.1 hx.2.1 + +/-- The set of rejecting (test, random string) pairs. -/ +def rejectPairs (T : Table Pos) : Finset (E × Cube M.R) := + Finset.univ.filter fun x => x.2 ∈ M.rejects T x.1 + +omit [Fintype Pos] [Fintype Q] [NumEnc Pos] [NumEnc E] [NumEnc Q] in +theorem card_rejectPairs (T : Table Pos) : + (M.rejectPairs T).card = ∑ e : E, (M.rejects T e).card := by + classical + rw [rejectPairs, Finset.card_filter, Fintype.sum_prod_type] + refine Finset.sum_congr rfl fun e _ => ?_ + rw [Finset.card_eq_sum_ones, ← Finset.sum_filter] + congr 1 + ext z + simp + +/-- **Rejections are counted by violated edges.** -/ +theorem card_rejects_le_card_unsatEdges [Nonempty Q] (A : M.toGraph.Assignment) : + ∑ e : E, (M.rejects (M.tableOf A) e).card ≤ (M.toGraph.unsatEdges A).card := by + classical + rw [← card_rejectPairs] + refine Finset.card_le_card_of_injOn (M.witnessEdge A) ?_ + (M.witnessEdge_injective A).injOn + intro x hx + have hx' : x.2 ∈ M.rejects (M.tableOf A) x.1 := by + have := Finset.mem_coe.1 hx + simpa [rejectPairs] using this + exact M.witnessEdge_mem A x hx' + +theorem numEdges_toGraph : M.toGraph.numEdges = Fintype.card E * 2 ^ M.R * Fintype.card Q := by + show Fintype.card (E × Cube M.R × Q) = _ + rw [Fintype.card_prod, Fintype.card_prod] + have hc : Fintype.card (Cube M.R) = 2 ^ M.R := by + show Fintype.card (Fin M.R → ZMod 2) = 2 ^ M.R + rw [Fintype.card_fun, ZMod.card, Fintype.card_fin] + rw [hc, mul_assoc] + +/-- **Soundness of the transformation.** The violated fraction of the binary +graph is at least the average rejection probability of the tests, divided by +the number of reads. -/ +theorem unsatFrac_toGraph_ge [Nonempty Q] (A : M.toGraph.Assignment) : + (∑ e : E, ((M.rejects (M.tableOf A) e).card : ℚ)) + / ((Fintype.card E : ℚ) * 2 ^ M.R * Fintype.card Q) + ≤ M.toGraph.unsatFrac A := by + classical + have h := M.card_rejects_le_card_unsatEdges A + have hE : (M.toGraph.numEdges : ℚ) + = (Fintype.card E : ℚ) * 2 ^ M.R * Fintype.card Q := by + rw [numEdges_toGraph]; push_cast; ring + rw [ConstraintGraph.unsatFrac, hE] + gcongr + exact_mod_cast h + +/-! ### Completeness -/ + +/-- The honest assignment: positions carry the proof, test vertices carry the +answers the proof gives. -/ +noncomputable def honest (T : Table Pos) : M.toGraph.Assignment := fun v => + match (NumEnc.equivFinCard M.Vert).symm v with + | Sum.inl p => (T p, fun _ => 0) + | Sum.inr (e, z) => (0, fun i => T (M.pos e z i)) + +theorem honest_inl (T : Table Pos) (p : Pos) : + M.honest T (M.vertIdx (Sum.inl p)) = (T p, fun _ => 0) := by + simp [honest, vertIdx] + +theorem honest_inr (T : Table Pos) (x : E × Cube M.R) : + M.honest T (M.vertIdx (Sum.inr x)) = (0, fun i => T (M.pos x.1 x.2 i)) := by + simp [honest, vertIdx] + +/-- **Completeness.** A proof accepted by every test on every random string +gives a satisfying assignment of the binary graph. -/ +theorem satisfiable_toGraph (T : Table Pos) (h : ∀ e z, M.accepts T e z = true) : + M.toGraph.Satisfiable := by + classical + refine ⟨M.honest T, fun k => ?_⟩ + rw [satisfies_toGraph_iff] + refine ⟨?_, ?_⟩ + · rw [honest_inr] + exact h _ _ + · rw [honest_inr] + show T _ = (M.honest T (M.vertIdx (Sum.inl _))).1 + rw [honest_inl] + +end Graph + +/-- The acceptance probability of a test, as a count of rejections. -/ +theorem prob_accepts_eq (T : Table Pos) (e : E) : + Pr[fun z : Cube M.R => M.accepts T e z = true] + = 1 - ((M.rejects T e).card : ℝ) / 2 ^ M.R := by + classical + rw [prob_eq_card_div] + have hsplit := Finset.card_filter_add_card_filter_not + (s := (Finset.univ : Finset (Cube M.R))) (fun z => M.accepts T e z = true) + have hrej : (M.rejects T e).card + = (Finset.univ.filter fun z => ¬ (M.accepts T e z = true)).card := by + congr 1 + ext z + simp [rejects] + rw [hrej] + have hcard : (Finset.univ : Finset (Cube M.R)).card = 2 ^ M.R := by + rw [Finset.card_univ] + show Fintype.card (Fin M.R → ZMod 2) = 2 ^ M.R + rw [Fintype.card_fun, ZMod.card, Fintype.card_fin] + rw [hcard] at hsplit + have hpos : (0 : ℝ) < 2 ^ M.R := by positivity + rw [eq_sub_iff_add_eq, ← add_div, div_eq_one_iff_eq hpos.ne'] + exact_mod_cast hsplit + +end MultiTest + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Margulis.lean b/Complexitylib/Classes/PCP/Internal/Margulis.lean new file mode 100644 index 00000000..c22eb7a5 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Margulis.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ExpanderAssemble +public import Mathlib.Data.ZMod.Basic + +/-! +# The Margulis generators + +The Margulis–Gabber–Galil graph on `ZMod m × ZMod m` is eight-regular: a vertex +`(x, y)` is joined to the images of eight explicit affine maps. The maps come in +four inverse pairs, which is what makes the rotation map an involution — the +edge leaving by generator `i` arrives by its partner. + +This module sets up the generators and that pairing. The spectral bound is +elsewhere. + +## Main definitions + +- `Complexity.margGen` — the eight generators +- `Complexity.margPair` — the pairing of a generator with its inverse +- `Complexity.margEquiv` — `Fin (m * m)` as `ZMod m × ZMod m` +- `Complexity.margRot` — the resulting rotation map + +## Main results + +- `Complexity.margGen_pair` — partnered generators undo each other +- `Complexity.margRot_involutive` — the rotation map is an involution +-/ + +@[expose] public section + +namespace Complexity + +variable {m : ℕ} + +/-- The eight Margulis generators of `ZMod m × ZMod m`. -/ +def margGen (i : Fin 8) (v : ZMod m × ZMod m) : ZMod m × ZMod m := + ![(v.1 + v.2, v.2), (v.1 - v.2, v.2), + (v.1, v.2 + v.1), (v.1, v.2 - v.1), + (v.1 + v.2 + 1, v.2), (v.1 - v.2 - 1, v.2), + (v.1, v.2 + v.1 + 1), (v.1, v.2 - v.1 - 1)] i + +/-- The generator that undoes a given one. -/ +def margPair (i : Fin 8) : Fin 8 := ![1, 0, 3, 2, 5, 4, 7, 6] i + +@[simp] theorem margPair_pair (i : Fin 8) : margPair (margPair i) = i := by + fin_cases i <;> rfl + +/-- **Partnered generators undo each other.** -/ +theorem margGen_pair (i : Fin 8) (v : ZMod m × ZMod m) : + margGen (margPair i) (margGen i v) = v := by + fin_cases i <;> simp [margGen, margPair, Prod.ext_iff] <;> ring + +/-! ### The rotation map -/ + +/-- `Fin (m * m)` viewed as the group `ZMod m × ZMod m`. -/ +def margEquiv (m : ℕ) [NeZero m] : Fin (m * m) ≃ ZMod m × ZMod m := + finProdFinEquiv.symm.trans ((ZMod.finEquiv m).toEquiv.prodCongr (ZMod.finEquiv m).toEquiv) + +/-- The Margulis rotation map: leave by generator `i`, arrive by its partner. +On the empty vertex set (`m = 0`) it is the identity. -/ +def margRot (m : ℕ) (p : Fin (m * m) × Fin 8) : Fin (m * m) × Fin 8 := + if h : m = 0 then p else + haveI : NeZero m := ⟨h⟩ + ((margEquiv m).symm (margGen p.2 (margEquiv m p.1)), margPair p.2) + +/-- **The Margulis rotation map is an involution.** -/ +theorem margRot_involutive (m : ℕ) : Function.Involutive (margRot m) := by + intro p + by_cases h : m = 0 + · simp [margRot, h] + · haveI : NeZero m := ⟨h⟩ + simp only [margRot, dif_neg h, Equiv.apply_symm_apply, margGen_pair, margPair_pair, + Equiv.symm_apply_apply] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Materialize.lean b/Complexitylib/Classes/PCP/Internal/Materialize.lean new file mode 100644 index 00000000..64fdbfe1 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Materialize.lean @@ -0,0 +1,281 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.UnaryList +public import Complexitylib.Classes.PCP.Internal.ListEncode +public import Complexitylib.Classes.PCP.Internal.PositionsFP + +/-! +# Writing out a table + +Every stage of an algorithmic reduction writes a list: the edges of a graph, the +entries of a rotation table, the records of a gadget. `ListEncode` runs the loop +that does it, but asks for a bound on the loop's own state; this module +discharges that bound from the rule alone, since a polynomial-time rule has +polynomially bounded output and the loop runs no more often than its argument is +long. + +## Main results + +- `Complexity.materialize_mem_FP` — a record rule makes the list encoder + polynomial time +- `Complexity.materialize_eq` — and it writes the list it is meant to +- `Complexity.countOver`, `Complexity.length_countOver` — the same loop used to + add up a rule's outputs, which is how a bounded count is taken +- `Complexity.findFirst`, `Complexity.length_findFirst` — and, run twice, how a + bounded search is made +- `Complexity.ifEqLen`, `Complexity.ifLtLen` — comparing two unary numbers, and + branching on the answer +- `Complexity.length_findFirst_eq` — the search returns the least index the rule + answers at +-/ + +@[expose] public section + +namespace Complexity + +/-- **A record rule materializes a list in polynomial time.** No bound need be +supplied: a polynomial-time rule already has polynomially bounded output, and +the loop runs only as many times as its own argument is long. -/ +theorem materialize_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : listEncFn E ∈ FP := by + obtain ⟨q, hq⟩ := Cobham.output_length_poly_of_mem_FP hE + set Q : Polynomial ℕ := q.comp (3 * Polynomial.X + Polynomial.C 2) with hQ + refine listEncFn_mem_FP hE + (4 * Polynomial.X * Q + 3 * Polynomial.X + Polynomial.C 6) fun z k hk => ?_ + have hfz : (Cobham.fstBlock z).length ≤ z.length := fstBlock_length_le z + have hsz : (Cobham.sndBlock z).length ≤ z.length := sndBlock_length_le z + have hkz : k ≤ z.length := le_trans hk hfz + have hrec : ∀ i < k, (E (pair (Cobham.sndBlock z) (List.replicate i true))).length + ≤ Q.eval z.length := by + intro i hi + refine le_trans (hq _) ?_ + have hlen : (pair (Cobham.sndBlock z) (List.replicate i true)).length + ≤ 3 * z.length + 2 := by + rw [pair_length, List.length_replicate] + omega + have := polynomial_eval_mono_nat q hlen + rw [hQ, Polynomial.eval_comp] + simpa using this + have hcat : (entryCat E (Cobham.sndBlock z) k).length ≤ k * Q.eval z.length := + length_entryCat_le E _ _ k hrec + have hstate : ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z))).length + = 2 * (2 * (entryCat E (Cobham.sndBlock z) k).length + 2 + k) + 2 + + (Cobham.sndBlock z).length := by + rw [listStep_iterate, pair_length, pair_length, List.length_replicate] + have heval : (4 * Polynomial.X * Q + 3 * Polynomial.X + Polynomial.C 6).eval z.length + = 4 * (z.length * Q.eval z.length) + 3 * z.length + 6 := by + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_ofNat, + Polynomial.eval_X, Polynomial.eval_C] + ring + have hC : (entryCat E (Cobham.sndBlock z) k).length ≤ z.length * Q.eval z.length := + le_trans hcat (Nat.mul_le_mul_right _ hkz) + rw [hstate, heval] + set A := z.length * Q.eval z.length with hA + omega + +/-- **The list encoder writes the list.** -/ +theorem materialize_eq {α : Type} [DataEncode α] {E : List Bool → List Bool} + (l : List α) (x : List Bool) + (h : ∀ i, ∀ hi : i < l.length, + E (pair x (List.replicate i true)) = DataEncode.bitstringEncode (l[i]'hi)) : + listEncFn E (pair (List.replicate l.length true) x) = DataEncode.bitstringEncode l := + listEncFn_eq_bitstringEncode l (by rw [Cobham.fstBlock_pair, List.length_replicate]) + (by rw [Cobham.sndBlock_pair]; exact h) + +/-! ### Adding up -/ + +theorem length_entryCat (E : List Bool → List Bool) (x : List Bool) (n : ℕ) : + (entryCat E x n).length + = ∑ i ∈ Finset.range n, (E (pair x (List.replicate i true))).length := by + induction n with + | zero => simp + | succ n ih => + rw [entryCat_succ, List.length_append, ih, Finset.sum_range_succ] + +/-- The total length of a rule's outputs over a range, in unary. Running the +rule for its length alone is how a loop counts: a rule that answers `[true]` or +`[]` counts the indices where it says yes. -/ +noncomputable def countOver (E : List Bool → List Bool) (z : List Bool) : List Bool := + marks (dropOne (dropOne (listEncFn E z))) + +theorem countOver_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : countOver E ∈ FP := + marks_mem_FP (dropOneFn_mem_FP (dropOneFn_mem_FP (materialize_mem_FP hE))) + +theorem length_countOver (E : List Bool → List Bool) (x : List Bool) (n : ℕ) : + (countOver E (pair (List.replicate n true) x)).length + = ∑ i ∈ Finset.range n, (E (pair x (List.replicate i true))).length := by + rw [countOver, marks_eq, List.length_replicate, dropOne, dropOne, List.length_drop, + List.length_drop, listEncFn_eq, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + List.length_replicate, List.length_append, List.length_cons, length_entryCat] + simp + +/-! ### Comparing -/ + +/-- `x` when the two strings have the same length, `y` otherwise. -/ +noncomputable def ifEqLen (a b x y : List Bool) : List Bool := + Cobham.selectHead (Cobham.emptyFlag (b.drop a.length ++ a.drop b.length)) x y + +theorem ifEqLen_pos {a b : List Bool} (h : a.length = b.length) (x y : List Bool) : + ifEqLen a b x y = x := by + have hb : b.drop a.length = [] := by + refine List.eq_nil_of_length_eq_zero ?_ + rw [List.length_drop, h] + omega + have ha : a.drop b.length = [] := by + refine List.eq_nil_of_length_eq_zero ?_ + rw [List.length_drop, h] + omega + rw [ifEqLen, hb, ha, List.append_nil, Cobham.selectHead_emptyFlag_nil] + +theorem ifEqLen_neg {a b : List Bool} (h : a.length ≠ b.length) (x y : List Bool) : + ifEqLen a b x y = y := by + have hne : b.drop a.length ++ a.drop b.length ≠ [] := by + intro hnil + have h1 := List.append_eq_nil_iff.mp hnil + have hb : (b.drop a.length).length = 0 := by rw [h1.1]; rfl + have ha : (a.drop b.length).length = 0 := by rw [h1.2]; rfl + rw [List.length_drop] at ha hb + omega + obtain ⟨c, t, hct⟩ : ∃ c t, b.drop a.length ++ a.drop b.length = c :: t := by + cases hcase : b.drop a.length ++ a.drop b.length with + | nil => exact absurd hcase hne + | cons c t => exact ⟨c, t, rfl⟩ + rw [ifEqLen, hct, Cobham.selectHead_emptyFlag_cons] + +theorem ifEqLen_mem_FP {a b x y : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (hx : x ∈ FP) (hy : y ∈ FP) : (fun z => ifEqLen (a z) (b z) (x z) (y z)) ∈ FP := by + have hd1 := dropLenFn_mem_FP ha hb + have hd2 := dropLenFn_mem_FP hb ha + exact Cobham.selectHeadFn_mem_FP + (Cobham.emptyFlag_mem_FP (Cobham.appendFn_mem_FP hd1 hd2)) hx hy + +/-- `x` when the first string is shorter than the second, `y` otherwise. -/ +noncomputable def ifLtLen (a b x y : List Bool) : List Bool := + Cobham.selectHead (Cobham.emptyFlag (b.drop a.length)) y x + +theorem ifLtLen_pos {a b : List Bool} (h : a.length < b.length) (x y : List Bool) : + ifLtLen a b x y = x := by + obtain ⟨c, t, hct⟩ : ∃ c t, b.drop a.length = c :: t := by + cases hcase : b.drop a.length with + | nil => + have : (b.drop a.length).length = 0 := by rw [hcase]; rfl + rw [List.length_drop] at this + omega + | cons c t => exact ⟨c, t, rfl⟩ + rw [ifLtLen, hct, Cobham.selectHead_emptyFlag_cons] + +theorem ifLtLen_neg {a b : List Bool} (h : ¬ a.length < b.length) (x y : List Bool) : + ifLtLen a b x y = y := by + have hb : b.drop a.length = [] := by + refine List.eq_nil_of_length_eq_zero ?_ + rw [List.length_drop] + omega + rw [ifLtLen, hb, Cobham.selectHead_emptyFlag_nil] + +theorem ifLtLen_mem_FP {a b x y : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (hx : x ∈ FP) (hy : y ∈ FP) : (fun z => ifLtLen (a z) (b z) (x z) (y z)) ∈ FP := + Cobham.selectHeadFn_mem_FP + (Cobham.emptyFlag_mem_FP (dropLenFn_mem_FP ha hb)) hy hx + +/-- The count is written in marks. -/ +theorem countOver_eq_replicate (E : List Bool → List Bool) (z : List Bool) : + countOver E z = List.replicate (countOver E z).length true := by + conv_lhs => rw [countOver, marks_eq] + rw [countOver, marks_eq, List.length_replicate] + +/-! ### Searching -/ + +/-- One mark when the string is empty, none otherwise. -/ +noncomputable def isEmptyMark (s : List Bool) : List Bool := + Cobham.selectHead (Cobham.emptyFlag s) [true] [] + +@[simp] theorem isEmptyMark_nil : isEmptyMark [] = [true] := + Cobham.selectHead_emptyFlag_nil _ _ + +@[simp] theorem isEmptyMark_cons (b : Bool) (t : List Bool) : isEmptyMark (b :: t) = [] := + Cobham.selectHead_emptyFlag_cons _ _ _ _ + +theorem length_isEmptyMark (s : List Bool) : + (isEmptyMark s).length = if s = [] then 1 else 0 := by + cases s with + | nil => simp + | cons b t => simp + +theorem isEmptyMark_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : + (fun z => isEmptyMark (f z)) ∈ FP := + Cobham.selectHeadFn_mem_FP (Cobham.emptyFlag_mem_FP hf) (constFn_mem_FP [true]) + (constFn_mem_FP []) + +/-- The least index below the bound at which the rule answers something, or the +bound itself when it never does: count the indices no answer has been seen up +to. -/ +noncomputable def findFirst (E : List Bool → List Bool) (z : List Bool) : List Bool := + countOver (fun w => + isEmptyMark (countOver E (pair (Cobham.sndBlock w ++ [true]) (Cobham.fstBlock w)))) z + +theorem findFirst_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : findFirst E ∈ FP := by + have harg := Cobham.pairFn_mem_FP + (Cobham.appendFn_mem_FP Cobham.sndBlock_mem_FP (constFn_mem_FP [true])) + Cobham.fstBlock_mem_FP + have hcount : countOver E ∈ FP := countOver_mem_FP hE + have hcomp : (fun w : List Bool => + countOver E (pair (Cobham.sndBlock w ++ [true]) (Cobham.fstBlock w))) ∈ FP := + mem_FP_of_eq (mem_FP_comp harg hcount) fun _ => rfl + exact countOver_mem_FP (isEmptyMark_mem_FP hcomp) + +/-- The search's answer is written in marks. -/ +theorem findFirst_eq_replicate (E : List Bool → List Bool) (z : List Bool) : + findFirst E z = List.replicate (findFirst E z).length true := by + conv_lhs => rw [findFirst, countOver_eq_replicate] + rw [← findFirst] + +theorem length_findFirst (E : List Bool → List Bool) (x : List Bool) (n : ℕ) : + (findFirst E (pair (List.replicate n true) x)).length + = ∑ j ∈ Finset.range n, + if (∑ k ∈ Finset.range (j + 1), (E (pair x (List.replicate k true))).length) = 0 + then 1 else 0 := by + rw [findFirst, length_countOver] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [Cobham.sndBlock_pair, Cobham.fstBlock_pair, ← List.replicate_succ', + length_isEmptyMark] + by_cases h : (∑ k ∈ Finset.range (j + 1), (E (pair x (List.replicate k true))).length) = 0 + · rw [if_pos h, if_pos] + have := length_countOver E x (j + 1) + exact List.eq_nil_of_length_eq_zero (by rw [this, h]) + · rw [if_neg h, if_neg] + intro hnil + exact h (by rw [← length_countOver E x (j + 1), hnil, List.length_nil]) + +/-- **The search returns the least index the rule answers at.** -/ +theorem length_findFirst_eq {E : List Bool → List Bool} {x : List Bool} {n c : ℕ} + (hc : c < n) (hhit : (E (pair x (List.replicate c true))).length ≠ 0) + (hmin : ∀ k < c, (E (pair x (List.replicate k true))).length = 0) : + (findFirst E (pair (List.replicate n true) x)).length = c := by + classical + rw [length_findFirst] + have hterm : ∀ j ∈ Finset.range n, + (if (∑ k ∈ Finset.range (j + 1), (E (pair x (List.replicate k true))).length) = 0 + then 1 else 0) + = (if j < c then 1 else 0) := by + intro j _ + by_cases hj : j < c + · rw [if_pos hj, if_pos] + refine Finset.sum_eq_zero fun k hk => ?_ + rw [Finset.mem_range] at hk + exact hmin k (by omega) + · rw [if_neg hj, if_neg] + intro hzero + refine hhit ?_ + have hcm : c ∈ Finset.range (j + 1) := Finset.mem_range.mpr (by omega) + exact (Finset.sum_eq_zero_iff.mp hzero) c hcm + rw [Finset.sum_congr rfl hterm, ← Finset.card_filter] + have hfilter : (Finset.range n).filter (fun j => j < c) = Finset.range c := by + ext j + simp only [Finset.mem_filter, Finset.mem_range] + omega + rw [hfilter, Finset.card_range] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/MaxLoop.lean b/Complexitylib/Classes/PCP/Internal/MaxLoop.lean new file mode 100644 index 00000000..fa79952d --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/MaxLoop.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.UnaryDivMod +public import Complexitylib.Classes.PCP.Internal.PositionsFP + +/-! +# The largest of polynomially many values + +An algorithm reading a formula has to know how many variables it mentions, which +is the largest index any literal names. More generally: given a rule that +computes a value for each index, take the largest over a bounded range. + +Values are carried in unary, so "largest" is "longest", and the comparison is +the length test already in the toolkit. + +## Main definitions + +- `Complexity.maxStep` — one step of the running maximum +- `Complexity.maxOver` — the value it computes + +## Main results + +- `Complexity.maxStep_iterate` — the loop takes the maximum +- `Complexity.maxFn_mem_FP`, `Complexity.maxFn_eq` — the packaged loop +- `Complexity.le_maxOver`, `Complexity.maxOver_attained` — it is the maximum +-/ + +@[expose] public section + +namespace Complexity + +/-- The largest of the first `n` values, as a length. -/ +def maxOver (f : List Bool → List Bool) (z : List Bool) : ℕ → ℕ + | 0 => 0 + | n + 1 => max (maxOver f z n) (f (pair z (List.replicate n true))).length + +/-- One step of the running maximum. The state is +`pair (pair largest counter) input`. -/ +def maxStep (f : List Bool → List Bool) (st : List Bool) : List Bool := + pair + (pair + (Cobham.selectHead + (Cobham.lenLeFlag (Cobham.fstBlock (Cobham.fstBlock st)) + (f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st))))) + (Cobham.fstBlock (Cobham.fstBlock st)) + (f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st))))) + (true :: Cobham.sndBlock (Cobham.fstBlock st))) + (Cobham.sndBlock st) + +theorem maxStep_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxStep f ∈ FP := by + have hm : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hi : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hz : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hv : (fun st : List Bool => + f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP hz hi) hf + simpa [Function.comp] using this + exact Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hm hv) hm hv) + (mem_FP_comp hi (Cobham.cons_mem_FP true))) hz + +/-- **The loop takes the maximum.** -/ +theorem maxStep_iterate (f : List Bool → List Bool) (z : List Bool) : ∀ n : ℕ, + ∃ M, (maxStep f)^[n] (pair (pair [] []) z) + = pair (pair M (List.replicate n true)) z + ∧ M.length = maxOver f z n := by + intro n + induction n with + | zero => exact ⟨[], rfl, rfl⟩ + | succ n ih => + obtain ⟨M, hM, hlen⟩ := ih + rw [Function.iterate_succ_apply', hM, maxStep, Cobham.fstBlock_pair, + Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + set v := f (pair z (List.replicate n true)) with hv + rcases Cobham.lenLeFlag_flag M v with hf | hf + · rw [hf, selectHead_cons_true] + refine ⟨M, by rw [List.replicate_succ], ?_⟩ + rw [Cobham.lenLeFlag_eq_true_iff] at hf + rw [maxOver, ← hlen, ← hv] + omega + · rw [hf, selectHead_cons_false] + refine ⟨v, by rw [List.replicate_succ], ?_⟩ + have hgt : M.length < v.length := by + by_contra hcon + have : Cobham.lenLeFlag M v = [true] := + (Cobham.lenLeFlag_eq_true_iff M v).mpr (by omega) + rw [hf] at this + simp at this + rw [maxOver, ← hlen, ← hv] + omega + +/-- Every value is at most the maximum. -/ +theorem le_maxOver {f : List Bool → List Bool} {z : List Bool} : + ∀ (n i : ℕ), i < n → (f (pair z (List.replicate i true))).length ≤ maxOver f z n := by + intro n + induction n with + | zero => intro i hi; omega + | succ n ih => + intro i hi + rw [maxOver] + rcases Nat.lt_or_ge i n with h | h + · exact le_trans (ih i h) (le_max_left _ _) + · have : i = n := by omega + subst this + exact le_max_right _ _ + +/-- The maximum is attained, when there is anything to maximise over. -/ +theorem maxOver_attained {f : List Bool → List Bool} {z : List Bool} : + ∀ n : ℕ, 0 < n → + ∃ i < n, (f (pair z (List.replicate i true))).length = maxOver f z n := by + intro n + induction n with + | zero => intro h; omega + | succ n ih => + intro _ + rcases Nat.eq_zero_or_pos n with hn | hn + · subst hn + refine ⟨0, by omega, ?_⟩ + rw [maxOver, maxOver] + simp + · obtain ⟨i, hi, hval⟩ := ih hn + rw [maxOver] + rcases Nat.lt_or_ge (maxOver f z n) (f (pair z (List.replicate n true))).length with h | h + · refine ⟨n, by omega, ?_⟩ + rw [max_eq_right (le_of_lt h)] + · refine ⟨i, by omega, ?_⟩ + rw [hval, max_eq_left h] + +theorem maxOver_le {f : List Bool → List Bool} {z : List Bool} {B : ℕ} : + ∀ n, (∀ i < n, (f (pair z (List.replicate i true))).length ≤ B) → maxOver f z n ≤ B := by + intro n + induction n with + | zero => intro _; simp [maxOver] + | succ n ih => + intro h + rw [maxOver, max_le_iff] + exact ⟨ih fun i hi => h i (by omega), h n (by omega)⟩ + +/-- **The packaged loop**, on `pair (unary count) input`. -/ +noncomputable def maxFn (f : List Bool → List Bool) (w : List Bool) : List Bool := + Cobham.fstBlock (Cobham.fstBlock ((maxStep f)^[(Cobham.fstBlock w).length] + (pair (pair [] []) (Cobham.sndBlock w)))) + +theorem maxFn_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxFn f ∈ FP := by + obtain ⟨pf, hpf⟩ := Cobham.output_length_poly_of_mem_FP hf + have hinit : (fun w : List Bool => pair (pair [] []) (Cobham.sndBlock w)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP _) Cobham.sndBlock_mem_FP + set q : Polynomial ℕ := + Polynomial.C 4 * (pf.comp (Polynomial.C 3 * Polynomial.X + Polynomial.C 2)) + + Polynomial.C 3 * Polynomial.X + Polynomial.C 6 with hq + have hwidth : (fun w : List Bool => polyRuler q (id w)) ∈ FP := + polyRulerFn_mem_FP q id_mem_FP + have hbound : ∀ w : List Bool, ∀ k ≤ (Cobham.fstBlock w).length, + ((maxStep f)^[k] (pair (pair [] []) (Cobham.sndBlock w))).length + ≤ (polyRuler q (id w)).length := by + intro w k hk + obtain ⟨M, hM, hlen⟩ := maxStep_iterate f (Cobham.sndBlock w) k + have hfw : (Cobham.fstBlock w).length ≤ w.length := fstBlock_length_le w + have hzw : (Cobham.sndBlock w).length ≤ w.length := sndBlock_length_le w + have hMB : M.length ≤ pf.eval (3 * w.length + 2) := by + rw [hlen] + refine maxOver_le k fun i hi => ?_ + refine le_trans (hpf _) (polynomial_eval_mono_nat pf ?_) + rw [pair_length, List.length_replicate] + omega + rw [hM, pair_length, pair_length, polyRuler_length, List.length_replicate, hq] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, Polynomial.eval_comp, id] + omega + have hiter := Cobham.iterate_mem_FP (maxStep_mem_FP hf) hinit + Cobham.fstBlock_mem_FP hwidth hbound + have := mem_FP_comp (mem_FP_comp hiter Cobham.fstBlock_mem_FP) Cobham.fstBlock_mem_FP + simpa [Function.comp, maxFn] using this + +theorem maxFn_eq (f : List Bool → List Bool) {n : ℕ} {z : List Bool} : + (maxFn f (pair (List.replicate n true) z)).length = maxOver f z n := by + obtain ⟨M, hM, hlen⟩ := maxStep_iterate f z n + rw [maxFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, hM, + Cobham.fstBlock_pair, Cobham.fstBlock_pair, hlen] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/MergeGen.lean b/Complexitylib/Classes/PCP/Internal/MergeGen.lean new file mode 100644 index 00000000..8f1f4cf5 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/MergeGen.lean @@ -0,0 +1,486 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ExpanderMerge + +/-! +# Merging at an arbitrary width + +`ExpanderMerge` folds `N ≤ 3 n` vertices onto `n`. The zig-zag tower produces +sizes far more widely spaced than that, so the fold has to work at any width: +`N` vertices onto `n`, with `(m - 1) n ≤ N ≤ m n`. + +What keeps the estimate under control at every width is that the fibres stay +balanced — `ExpanderMerge.card_liftN_none_le_one` — so however large `m` is, +each new vertex needs at most one padding loop. + +This module carries the combinatorial layer: the rotation map and the graph. + +## Main definitions + +- `Complexity.RegGraph.mergeRotN` — the rotation map of the wide merge +- `Complexity.RegGraph.mergedN` — the merged graph + +## Main results + +- `Complexity.RegGraph.mergeRotN_involutive` +- `Complexity.RegGraph.order_mergedN`, `Complexity.RegGraph.deg_mergedN` +- `Complexity.RegGraph.step_mergedN` — the merged walk averages the `m` slots +- `Complexity.RegGraph.sq_step_mergedN_le` — and Jensen bounds its square +- `Complexity.RegGraph.sum_over_liftN` — the filled slots enumerate the old + vertices +- `Complexity.RegGraph.sum_sq_termN_le` — the split into old steps and padding +- `Complexity.RegGraph.spectralBound_mergedN` — **the spectral bound at any + width** +- `Complexity.mergeWidth` — a width that always works +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable {N d n m : ℕ} + +/-- The new vertex an old one folds onto. -/ +def projN (n : ℕ) (hn : 0 < n) (u : Fin N) : Fin n := ⟨u.val % n, Nat.mod_lt _ hn⟩ + +/-- Which slot of its fibre an old vertex occupies. -/ +def slotN (n m : ℕ) (hN : N ≤ m * n) (u : Fin N) : Fin m := + ⟨u.val / n, by + rcases Nat.eq_zero_or_pos n with h0 | h0 + · subst h0 + have := u.isLt + omega + · have := u.isLt + rw [Nat.div_lt_iff_lt_mul h0] + omega⟩ + +theorem liftN_projN_slotN (hn : 0 < n) (hN : N ≤ m * n) (u : Fin N) : + liftN N n (projN n hn u) (slotN n m hN u).val = some u := by + rw [liftN, projN, slotN] + have h : u.val % n + u.val / n * n = u.val := by + rw [mul_comm] + exact Nat.mod_add_div u.val n + rw [dif_pos (by rw [h]; exact u.isLt)] + congr 1 + exact Fin.ext h + +theorem projN_liftN (hn : 0 < n) (v : Fin n) (i : ℕ) (u : Fin N) + (h : liftN N n v i = some u) : projN n hn u = v := by + rw [liftN] at h + split_ifs at h with hlt + · simp only [Option.some.injEq] at h + rw [← h, projN] + apply Fin.ext + show (v.val + i * n) % n = v.val + rw [Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt v.isLt] + +theorem slotN_liftN (hn : 0 < n) (hN : N ≤ m * n) (v : Fin n) (i : ℕ) (u : Fin N) + (h : liftN N n v i = some u) : (slotN n m hN u).val = i := by + rw [liftN] at h + split_ifs at h with hlt + · simp only [Option.some.injEq] at h + rw [← h, slotN] + show (v.val + i * n) / n = i + rw [Nat.add_mul_div_right _ _ hn, Nat.div_eq_of_lt v.isLt, zero_add] + +/-- The rotation map of the wide merge. -/ +def mergeRotN (hn : 0 < n) (hN : N ≤ m * n) (rot : Fin N × Fin d → Fin N × Fin d) + (x : Fin n × (Fin m × Fin d)) : Fin n × (Fin m × Fin d) := + match liftN N n x.1 x.2.1.val with + | some u => + let y := rot (u, x.2.2) + (projN n hn y.1, (slotN n m hN y.1, y.2)) + | none => x + +theorem mergeRotN_involutive (hn : 0 < n) (hN : N ≤ m * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : + Function.Involutive (mergeRotN hn hN rot) := by + intro x + obtain ⟨v, i, s⟩ := x + simp only [mergeRotN] + cases hl : liftN N n v i.val with + | none => simp [hl] + | some u => + simp only + have hs : (slotN n m hN u).val = i.val := slotN_liftN hn hN v i.val u hl + have hslot : slotN n m hN u = i := Fin.ext hs + rw [liftN_projN_slotN hn hN] + simp only + rcases hrs : rot (u, s) with ⟨u', s'⟩ + have hy : rot (u', s') = (u, s) := by + rw [← hrs] + exact hrot (u, s) + simp only [hy, Prod.mk.injEq] + exact ⟨projN_liftN hn v i.val u hl, hslot, trivial⟩ + +/-- **The wide merge.** -/ +def mergedN (hn : 0 < n) (hd : 0 < d) (hm : 0 < m) (hN : N ≤ m * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : RegGraph where + V := Fin n + D := Fin m × Fin d + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨(⟨0, hm⟩, ⟨0, hd⟩)⟩ + rot := mergeRotN hn hN rot + rot_involutive := mergeRotN_involutive hn hN rot hrot + +@[simp] theorem order_mergedN (hn : 0 < n) (hd : 0 < d) (hm : 0 < m) (hN : N ≤ m * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : + (mergedN hn hd hm hN rot hrot).order = n := Fintype.card_fin n + +@[simp] theorem deg_mergedN (hn : 0 < n) (hd : 0 < d) (hm : 0 < m) (hN : N ≤ m * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : + (mergedN hn hd hm hN rot hrot).deg = m * d := by + show Fintype.card (Fin m × Fin d) = m * d + rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] + +/-! ### The walk of the wide merge -/ + +/-- A term of the merged step at `v`: the old step at the vertex in slot `i`, or +`f v` where the slot is empty. -/ +noncomputable def termN (hn : 0 < n) (hd : 0 < d) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + (f : Fin n → ℝ) (v : Fin n) (i : ℕ) : ℝ := + match liftN N n v i with + | some u => (base hd rot hrot).step (fun w => f (projN n hn w)) u + | none => f v + +/-- **The merged walk is the average over the slots.** -/ +theorem step_mergedN (hn : 0 < n) (hd : 0 < d) (hm : 0 < m) (hN : N ≤ m * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + (f : Fin n → ℝ) (v : Fin n) : + (mergedN hn hd hm hN rot hrot).step f v + = (∑ i ∈ Finset.range m, termN hn hd rot hrot f v i) / (m : ℝ) := by + have hd' : (d : ℝ) ≠ 0 := by + have : (0 : ℝ) < d := by exact_mod_cast hd + exact ne_of_gt this + have hm' : (m : ℝ) ≠ 0 := by + have : (0 : ℝ) < m := by exact_mod_cast hm + exact ne_of_gt this + have hdeg : ((mergedN hn hd hm hN rot hrot).deg : ℝ) = (m : ℝ) * (d : ℝ) := by + rw [deg_mergedN] + push_cast + ring + have hsum : (∑ x : (mergedN hn hd hm hN rot hrot).D, + f ((mergedN hn hd hm hN rot hrot).nbr v x)) + = ∑ i : Fin m, ∑ s : Fin d, f ((mergeRotN hn hN rot (v, (i, s))).1) := + Fintype.sum_prod_type + (f := fun x : Fin m × Fin d => f ((mergeRotN hn hN rot (v, x)).1)) + rw [RegGraph.step, hdeg, hsum] + have hinner : ∀ i : Fin m, ∑ s : Fin d, f ((mergeRotN hn hN rot (v, (i, s))).1) + = (d : ℝ) * termN hn hd rot hrot f v i.val := by + intro i + rw [termN] + simp only [mergeRotN] + cases hl : liftN N n v i.val with + | none => + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + | some u => + simp only + rw [RegGraph.step, deg_ofRot] + show _ = (d : ℝ) * ((∑ j : Fin d, f (projN n hn (rot (u, j)).1)) / (d : ℝ)) + field_simp + rw [Finset.sum_congr rfl fun i _ => hinner i, ← Finset.mul_sum] + rw [Fin.sum_univ_eq_sum_range (fun i => termN hn hd rot hrot f v i) m] + field_simp + +/-- **Jensen**: the square of the average is at most the average of the +squares. -/ +theorem sq_step_mergedN_le (hn : 0 < n) (hd : 0 < d) (hm : 0 < m) (hN : N ≤ m * n) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + (f : Fin n → ℝ) (v : Fin n) : + ((mergedN hn hd hm hN rot hrot).step f v) ^ 2 + ≤ (∑ i ∈ Finset.range m, (termN hn hd rot hrot f v i) ^ 2) / (m : ℝ) := by + have hm' : (0 : ℝ) < m := by exact_mod_cast hm + rw [step_mergedN, div_pow] + have h := sq_sum_le_card_mul_sum_sq (s := Finset.range m) + (f := fun i => termN hn hd rot hrot f v i) + rw [Finset.card_range] at h + rw [div_le_div_iff₀ (by positivity) hm'] + nlinarith [h, hm'] + +/-! ### Summing over the slots -/ + +/-- **The filled slots are exactly the old vertices.** -/ +theorem sum_over_liftN (hn : 0 < n) (hN : N ≤ m * n) (g : Fin N → ℝ) : + ∑ p : Fin n × Fin m, + (match liftN N n p.1 p.2.val with | some u => g u | none => 0) + = ∑ u : Fin N, g u := by + classical + have hinj : Function.Injective fun u : Fin N => (projN n hn u, slotN n m hN u) := by + intro u u' h + have h1 := liftN_projN_slotN hn hN u + have h2 := liftN_projN_slotN hn hN u' + simp only [Prod.mk.injEq] at h + rw [h.1, h.2, h2] at h1 + exact (Option.some.inj h1).symm + symm + calc ∑ u : Fin N, g u + = ∑ u : Fin N, (match liftN N n (projN n hn u) (slotN n m hN u).val with + | some u' => g u' | none => 0) := by + refine Finset.sum_congr rfl fun u _ => ?_ + rw [liftN_projN_slotN hn hN] + _ = ∑ p ∈ Finset.univ.image (fun u : Fin N => (projN n hn u, slotN n m hN u)), + (match liftN N n p.1 p.2.val with | some u' => g u' | none => 0) := by + rw [Finset.sum_image (fun u _ u' _ h => hinj h)] + _ = ∑ p : Fin n × Fin m, + (match liftN N n p.1 p.2.val with | some u' => g u' | none => 0) := by + refine Finset.sum_subset (Finset.subset_univ _) fun p _ hp => ?_ + cases hl : liftN N n p.1 p.2.val with + | none => rfl + | some u => + exfalso + apply hp + rw [Finset.mem_image] + refine ⟨u, Finset.mem_univ _, ?_⟩ + have h1 := projN_liftN hn p.1 p.2.val u hl + have h2 := slotN_liftN hn hN p.1 p.2.val u hl + exact Prod.ext h1 (Fin.ext h2) + +/-- **Splitting the slot terms**: the old steps, plus at most one padding per +vertex — this is where balance of the fibres is used. -/ +theorem sum_sq_termN_le (hn : 0 < n) (hd : 0 < d) (hN : N ≤ m * n) + (hm1 : (m - 1) * n ≤ N) (rot : Fin N × Fin d → Fin N × Fin d) + (hrot : Function.Involutive rot) (f : Fin n → ℝ) : + ∑ v : Fin n, ∑ i : Fin m, (termN hn hd rot hrot f v i.val) ^ 2 + ≤ (∑ u : Fin N, ((base hd rot hrot).step (fun w => f (projN n hn w)) u) ^ 2) + + ∑ v : Fin n, (f v) ^ 2 := by + classical + have hsplit : ∀ (v : Fin n) (i : Fin m), (termN hn hd rot hrot f v i.val) ^ 2 + = (match liftN N n v i.val with + | some u => ((base hd rot hrot).step (fun w => f (projN n hn w)) u) ^ 2 + | none => 0) + + (match liftN N n v i.val with | some _ => 0 | none => (f v) ^ 2) := by + intro v i + simp only [termN] + cases liftN N n v i.val <;> simp + simp_rw [hsplit, Finset.sum_add_distrib] + rw [← Fintype.sum_prod_type', sum_over_liftN hn hN] + refine add_le_add le_rfl (Finset.sum_le_sum fun v _ => ?_) + -- at most one empty slot per vertex + have hone : ∑ i : Fin m, + (match liftN N n v i.val with | some _ => (0 : ℝ) | none => (f v) ^ 2) + ≤ (f v) ^ 2 := by + have hcard := card_liftN_none_le_one (N := N) (n := n) (m := m) hm1 v + have hstep : ∑ i : Fin m, + (match liftN N n v i.val with | some _ => (0 : ℝ) | none => (f v) ^ 2) + = ∑ i ∈ (Finset.range m).filter fun i => liftN N n v i = none, (f v) ^ 2 := by + have hconv : ∑ i : Fin m, + (match liftN N n v i.val with | some _ => (0 : ℝ) | none => (f v) ^ 2) + = ∑ i ∈ Finset.range m, + (match liftN N n v i with | some _ => (0 : ℝ) | none => (f v) ^ 2) := + Fin.sum_univ_eq_sum_range + (fun i => (match liftN N n v i with | some _ => (0 : ℝ) | none => (f v) ^ 2)) m + rw [hconv, Finset.sum_filter] + refine Finset.sum_congr rfl fun i _ => ?_ + cases liftN N n v i <;> simp + rw [hstep, Finset.sum_const, nsmul_eq_mul] + have hc : ((((Finset.range m).filter fun i => liftN N n v i = none).card : ℕ) : ℝ) ≤ 1 := by + exact_mod_cast hcard + nlinarith [hc, sq_nonneg (f v)] + exact hone + +/-! ### The spectral bound at any width -/ + +/-- The wide projection is the one `ExpanderMerge` already used. -/ +theorem projN_eq_proj (hn : 0 < n) : projN (N := N) n hn = proj n hn := rfl + +theorem sum_sq_liftN_le (hn : 0 < n) (hN : N ≤ m * n) (f : Fin n → ℝ) : + ∑ u : Fin N, (f (projN n hn u)) ^ 2 ≤ (m : ℝ) * ∑ v : Fin n, (f v) ^ 2 := by + classical + rw [← sum_over_liftN hn hN (fun u => (f (projN n hn u)) ^ 2), Fintype.sum_prod_type, + Finset.mul_sum] + refine Finset.sum_le_sum fun v _ => ?_ + have hterm : ∀ i : Fin m, + (match liftN N n v i.val with | some u => (f (projN n hn u)) ^ 2 | none => 0) + ≤ (f v) ^ 2 := by + intro i + cases hl : liftN N n v i.val with + | none => show (0 : ℝ) ≤ (f v) ^ 2; exact sq_nonneg _ + | some u => + show (f (projN n hn u)) ^ 2 ≤ (f v) ^ 2 + rw [projN_liftN hn v i.val u hl] + calc ∑ i : Fin m, + (match liftN N n v i.val with | some u => (f (projN n hn u)) ^ 2 | none => 0) + ≤ ∑ _i : Fin m, (f v) ^ 2 := Finset.sum_le_sum fun i _ => hterm i + _ = (m : ℝ) * (f v) ^ 2 := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + +/-- **The lift's total**, for a mean-zero `f`: only the last slot survives. -/ +theorem sum_liftN_eq (hn : 0 < n) (hN : N ≤ m * n) (hm1 : (m - 1) * n ≤ N) (hm : 0 < m) + (f : Fin n → ℝ) (hf : ∑ v : Fin n, f v = 0) : + ∑ u : Fin N, f (projN n hn u) + = ∑ v : Fin n, (match liftN N n v (m - 1) with | some _ => f v | none => 0) := by + classical + rw [← sum_over_liftN hn hN (fun u => f (projN n hn u)), Fintype.sum_prod_type] + have hv : ∀ v : Fin n, ∑ i : Fin m, + (match liftN N n v i.val with | some u => f (projN n hn u) | none => 0) + = ((m : ℝ) - 1) * f v + + (match liftN N n v (m - 1) with | some _ => f v | none => 0) := by + intro v + have hval : ∀ i : Fin m, + (match liftN N n v i.val with | some u => f (projN n hn u) | none => 0) + = (match liftN N n v i.val with | some _ => f v | none => 0) := by + intro i + cases hl : liftN N n v i.val with + | none => rfl + | some u => + show f (projN n hn u) = f v + rw [projN_liftN hn v i.val u hl] + rw [Finset.sum_congr rfl fun i _ => hval i] + have hsplit : ∀ i : Fin m, + (match liftN N n v i.val with | some _ => f v | none => 0) + = f v - (match liftN N n v i.val with | some _ => 0 | none => f v) := by + intro i + cases liftN N n v i.val <;> simp + rw [Finset.sum_congr rfl fun i _ => hsplit i, Finset.sum_sub_distrib, + Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + have hnone : ∑ i : Fin m, + (match liftN N n v i.val with | some _ => (0 : ℝ) | none => f v) + = (match liftN N n v (m - 1) with | some _ => (0 : ℝ) | none => f v) := by + have hconv : ∑ i : Fin m, + (match liftN N n v i.val with | some _ => (0 : ℝ) | none => f v) + = ∑ i ∈ Finset.range m, + (match liftN N n v i with | some _ => (0 : ℝ) | none => f v) := + Fin.sum_univ_eq_sum_range + (fun i => (match liftN N n v i with | some _ => (0 : ℝ) | none => f v)) m + rw [hconv] + rw [Finset.sum_eq_single (m - 1)] + · intro b hb hbne + rw [Finset.mem_range] at hb + have : b + 1 < m := by omega + have hsome := liftN_isSome hm1 v this + cases hl : liftN N n v b with + | none => rw [hl] at hsome; exact absurd hsome (by simp) + | some _ => rfl + · intro hcon + exact absurd (Finset.mem_range.2 (by omega)) hcon + rw [hnone] + cases liftN N n v (m - 1) <;> · simp; ring + rw [Finset.sum_congr rfl fun v _ => hv v, Finset.sum_add_distrib, ← Finset.mul_sum, hf, + mul_zero, zero_add] + +/-- **The mean of the lift is small.** -/ +theorem sq_sum_liftN_le (hn : 0 < n) (hN : N ≤ m * n) (hm1 : (m - 1) * n ≤ N) (hm : 0 < m) + (f : Fin n → ℝ) (hf : ∑ v : Fin n, f v = 0) : + (∑ u : Fin N, f (projN n hn u)) ^ 2 ≤ (n : ℝ) * ∑ v : Fin n, (f v) ^ 2 := by + classical + rw [sum_liftN_eq hn hN hm1 hm f hf] + set Hv : Finset (Fin n) := + Finset.univ.filter fun v => (liftN N n v (m - 1)).isSome with hH + have hsum : ∑ v : Fin n, (match liftN N n v (m - 1) with | some _ => f v | none => 0) + = ∑ v ∈ Hv, f v := by + rw [hH, Finset.sum_filter] + refine Finset.sum_congr rfl fun v _ => ?_ + cases liftN N n v (m - 1) <;> simp + rw [hsum] + have hcs := sq_sum_le_card_mul_sum_sq (s := Hv) (f := f) + have hcard : (Hv.card : ℝ) ≤ (n : ℝ) := by + have : Hv.card ≤ Fintype.card (Fin n) := Finset.card_le_univ Hv + rw [Fintype.card_fin] at this + exact_mod_cast this + have hsub : ∑ v ∈ Hv, (f v) ^ 2 ≤ ∑ v : Fin n, (f v) ^ 2 := + Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) fun v _ _ => sq_nonneg _ + have h0 : 0 ≤ ∑ v ∈ Hv, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ + calc (∑ v ∈ Hv, f v) ^ 2 ≤ Hv.card * ∑ v ∈ Hv, (f v) ^ 2 := hcs + _ ≤ (n : ℝ) * ∑ v : Fin n, (f v) ^ 2 := by + exact mul_le_mul hcard hsub h0 (by positivity) + +/-- **The spectral bound of the wide merge.** The width enters only through the +`1 / m` terms, so the bound stays below one however far apart the sizes are. -/ +theorem spectralBound_mergedN (hn : 0 < n) (hd : 0 < d) (hm : 0 < m) (hN : N ≤ m * n) + (hm1 : (m - 1) * n ≤ N) (h2 : 2 * n ≤ N) + (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) + {lam : ℝ} (hlam : lam ^ 2 ≤ 1) (hspec : (base hd rot hrot).SpectralBound lam) : + (mergedN hn hd hm hN rot hrot).SpectralBound + (Real.sqrt (lam ^ 2 + (1 - lam ^ 2) / (2 * m) + 1 / m)) := by + intro f hf + have hN0 : 0 < N := by omega + have hN' : (0 : ℝ) < N := by exact_mod_cast hN0 + have hm' : (0 : ℝ) < m := by exact_mod_cast hm + have hl1 : 0 ≤ 1 - lam ^ 2 := by linarith + have hl0 : 0 ≤ lam ^ 2 := sq_nonneg _ + have hsq : Real.sqrt (lam ^ 2 + (1 - lam ^ 2) / (2 * m) + 1 / m) ^ 2 + = lam ^ 2 + (1 - lam ^ 2) / (2 * m) + 1 / m := + Real.sq_sqrt (by positivity) + rw [hsq] + have hf' : ∑ v : Fin n, f v = 0 := hf + have hS : 0 ≤ ∑ v : Fin n, (f v) ^ 2 := Finset.sum_nonneg fun _ _ => sq_nonneg _ + have hjensen : ∑ v : Fin n, ((mergedN hn hd hm hN rot hrot).step f v) ^ 2 + ≤ (∑ v : Fin n, ∑ i ∈ Finset.range m, (termN hn hd rot hrot f v i) ^ 2) / (m : ℝ) := by + rw [Finset.sum_div] + exact Finset.sum_le_sum fun v _ => sq_step_mergedN_le hn hd hm hN rot hrot f v + have hconv : ∀ v : Fin n, ∑ i ∈ Finset.range m, (termN hn hd rot hrot f v i) ^ 2 + = ∑ i : Fin m, (termN hn hd rot hrot f v i.val) ^ 2 := fun v => + (Fin.sum_univ_eq_sum_range (fun i => (termN hn hd rot hrot f v i) ^ 2) m).symm + rw [Finset.sum_congr rfl fun v _ => hconv v] at hjensen + have hterms := sum_sq_termN_le hn hd hN hm1 rot hrot f + have hold := sum_sq_step_lift_le hn hd rot hrot hspec hN0 f + rw [← projN_eq_proj hn] at hold + have hlift := sum_sq_liftN_le hn hN f + have hmean := sq_sum_liftN_le hn hN hm1 hm f hf' + have hmeanN : (∑ u : Fin N, f (projN n hn u)) ^ 2 / (N : ℝ) + ≤ (1 / 2) * ∑ v : Fin n, (f v) ^ 2 := by + rw [div_le_iff₀ hN'] + have h2' : (2 : ℝ) * n ≤ N := by exact_mod_cast h2 + nlinarith [hmean, h2', hS] + have hA := mul_le_mul_of_nonneg_left hlift hl0 + have hB := mul_le_mul_of_nonneg_left hmeanN hl1 + have hT : ∑ v : Fin n, ∑ i : Fin m, (termN hn hd rot hrot f v i.val) ^ 2 + ≤ (lam ^ 2 * (m : ℝ) + (1 - lam ^ 2) / 2 + 1) * ∑ v : Fin n, (f v) ^ 2 := by + nlinarith [hterms, hold, hA, hB, hS] + have hfin : (∑ v : Fin n, ∑ i : Fin m, (termN hn hd rot hrot f v i.val) ^ 2) / (m : ℝ) + ≤ (lam ^ 2 + (1 - lam ^ 2) / (2 * m) + 1 / m) * ∑ v : Fin n, (f v) ^ 2 := by + rw [div_le_iff₀ hm'] + have hexp : (lam ^ 2 + (1 - lam ^ 2) / (2 * m) + 1 / m) + * (∑ v : Fin n, (f v) ^ 2) * (m : ℝ) + = (lam ^ 2 * (m : ℝ) + (1 - lam ^ 2) / 2 + 1) * ∑ v : Fin n, (f v) ^ 2 := by + field_simp + rw [hexp] + exact hT + show ∑ v : Fin n, ((mergedN hn hd hm hN rot hrot).step f v) ^ 2 ≤ _ + exact le_trans hjensen hfin + +/-! ### Choosing the width -/ + +/-- A width that always works for folding `N ≥ 2 n` vertices onto `n`. -/ +def mergeWidth (N n : ℕ) : ℕ := N / n + 1 + +theorem le_mergeWidth_mul (N : ℕ) {n : ℕ} (hn : 0 < n) : N ≤ mergeWidth N n * n := by + rw [mergeWidth] + have h := Nat.div_add_mod N n + have hlt := Nat.mod_lt N hn + calc N = n * (N / n) + N % n := h.symm + _ ≤ n * (N / n) + n := by omega + _ = (N / n + 1) * n := by ring + +theorem mergeWidth_sub_one_mul_le (N n : ℕ) : (mergeWidth N n - 1) * n ≤ N := by + rw [mergeWidth, Nat.add_sub_cancel] + exact Nat.div_mul_le_self N n + +theorem three_le_mergeWidth {N n : ℕ} (hn : 0 < n) (h2 : 2 * n ≤ N) : + 3 ≤ mergeWidth N n := by + rw [mergeWidth] + have h : 2 ≤ N / n := (Nat.le_div_iff_mul_le hn).2 (by omega) + omega + +/-- The width is bounded whenever the overshoot is. -/ +theorem mergeWidth_le {N n C : ℕ} (hn : 0 < n) (h : N ≤ C * n) : + mergeWidth N n ≤ C + 1 := by + rw [mergeWidth] + have : N / n ≤ C := (Nat.div_le_iff_le_mul_add_pred hn).2 (by + have : C * n = n * C := by ring + omega) + omega + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Mixing.lean b/Complexitylib/Classes/PCP/Internal/Mixing.lean new file mode 100644 index 00000000..ba5c1bdb --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Mixing.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.RegularGraph + +/-! +# The expander mixing lemma for `t`-step walks + +The quantitative heart of every expander argument, in the square-norm form set +up in `RegularGraph`: on a graph with `SpectralBound lam`, the correlation +between a function `f` at the start of a `t`-step walk and a function `g` at its +end is what independence would predict, up to `lam ^ t` times the two standard +deviations. + +Stated with everything squared, so no `Real.sqrt` appears: + +`(⟪f, Aᵗ g⟫ - (∑ f)(∑ g)/n) ^ 2 ≤ lam ^ (2t) · Var f · Var g` + +where `Var f = ∑ f² - (∑ f)²/n` is the (unnormalised) variance. Specialised to +indicator functions of vertex sets this is the usual expander mixing lemma, and +it is the estimate Dinur's powering step applies to the sets of vertices whose +walk-labels disagree with a global assignment. + +## Main definitions + +- `RegGraph.mean`, `RegGraph.center` — the mean of a function and its + mean-zero part + +## Main results + +- `RegGraph.step_const`, `RegGraph.step_add`, `RegGraph.stepIter_const`, + `RegGraph.stepIter_add` — the walk operator is affine-linear and fixes + constants +- `RegGraph.sum_center`, `RegGraph.sum_sq_center` — the Pythagoras identity + splitting a function into its mean and its mean-zero part +- `RegGraph.inner_stepIter_eq` — the correlation splits into the independent + part and a mean-zero correlation +- `RegGraph.mixing_sq` — the mixing lemma +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Linearity of the walk operator -/ + +@[simp] theorem step_const (c : ℝ) (v : G.V) : G.step (fun _ => c) v = c := by + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + simp only [step, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, card_eq_deg] + field_simp + +theorem step_add (f g : G.V → ℝ) (v : G.V) : + G.step (fun w => f w + g w) v = G.step f v + G.step g v := by + simp only [step] + rw [← add_div, Finset.sum_add_distrib] + +theorem stepIter_const (t : ℕ) (c : ℝ) : G.stepIter t (fun _ => c) = fun _ => c := by + induction t with + | zero => rfl + | succ t ih => rw [stepIter_succ, ih]; funext v; exact G.step_const c v + +theorem stepIter_add (t : ℕ) (f g : G.V → ℝ) : + G.stepIter t (fun w => f w + g w) = fun v => G.stepIter t f v + G.stepIter t g v := by + induction t with + | zero => rfl + | succ t ih => + rw [stepIter_succ, ih] + funext v + rw [G.step_add, ← stepIter_succ, ← stepIter_succ] + +/-! ### Centering -/ + +/-- The mean of a function on the vertices. -/ +noncomputable def mean (f : G.V → ℝ) : ℝ := (∑ v : G.V, f v) / (G.order : ℝ) + +/-- The mean-zero part of a function. -/ +noncomputable def center (f : G.V → ℝ) : G.V → ℝ := fun v => f v - G.mean f + +theorem eq_mean_add_center (f : G.V → ℝ) : f = fun v => G.mean f + G.center f v := by + funext v; simp [center] + +theorem sum_center (hn : 0 < G.order) (f : G.V → ℝ) : ∑ v : G.V, G.center f v = 0 := by + have hnq : (G.order : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne' + simp only [center, Finset.sum_sub_distrib, Finset.sum_const, Finset.card_univ, + nsmul_eq_mul, mean, card_eq_order] + field_simp + ring + +theorem sum_sq_center (hn : 0 < G.order) (f : G.V → ℝ) : + ∑ v : G.V, (G.center f v) ^ 2 + = (∑ v : G.V, (f v) ^ 2) - (∑ v : G.V, f v) ^ 2 / (G.order : ℝ) := by + have hnq : (G.order : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne' + have expand : ∀ v : G.V, (G.center f v) ^ 2 + = (f v) ^ 2 - 2 * G.mean f * f v + (G.mean f) ^ 2 := by + intro v; simp only [center]; ring + calc ∑ v : G.V, (G.center f v) ^ 2 + = ∑ v : G.V, ((f v) ^ 2 - 2 * G.mean f * f v + (G.mean f) ^ 2) := + Finset.sum_congr rfl fun v _ => expand v + _ = (∑ v : G.V, (f v) ^ 2) - 2 * G.mean f * (∑ v : G.V, f v) + + (G.order : ℝ) * (G.mean f) ^ 2 := by + rw [Finset.sum_add_distrib, Finset.sum_sub_distrib, ← Finset.mul_sum] + simp [mul_comm] + _ = (∑ v : G.V, (f v) ^ 2) - (∑ v : G.V, f v) ^ 2 / (G.order : ℝ) := by + simp only [mean] + field_simp + ring + +theorem sum_sq_center_nonneg (f : G.V → ℝ) : 0 ≤ ∑ v : G.V, (G.center f v) ^ 2 := + Finset.sum_nonneg fun _ _ => sq_nonneg _ + +/-! ### The mixing lemma -/ + +/-- The correlation between `f` at the start of a `t`-step walk and `g` at its +end splits into the product of averages plus the correlation of the mean-zero +parts. -/ +theorem inner_stepIter_eq (hn : 0 < G.order) (t : ℕ) (f g : G.V → ℝ) : + ∑ v : G.V, f v * G.stepIter t g v + = (∑ v : G.V, f v) * (∑ v : G.V, g v) / (G.order : ℝ) + + ∑ v : G.V, G.center f v * G.stepIter t (G.center g) v := by + have hnq : (G.order : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne' + have hsumS : ∑ v : G.V, G.stepIter t (G.center g) v = 0 := by + rw [G.sum_stepIter, G.sum_center hn] + have hsumF : ∑ v : G.V, G.center f v = 0 := G.sum_center hn f + have hg : G.stepIter t g = fun v => G.mean g + G.stepIter t (G.center g) v := by + conv_lhs => rw [G.eq_mean_add_center g] + rw [G.stepIter_add, G.stepIter_const] + have hf : ∀ v : G.V, f v = G.mean f + G.center f v := fun v => by + simp [center] + calc ∑ v : G.V, f v * G.stepIter t g v + = ∑ v : G.V, (G.mean f + G.center f v) + * (G.mean g + G.stepIter t (G.center g) v) := by + rw [hg] + exact Finset.sum_congr rfl fun v _ => by rw [hf v] + _ = ∑ v : G.V, (G.mean f * G.mean g + + (G.mean f * G.stepIter t (G.center g) v + + (G.mean g * G.center f v + + G.center f v * G.stepIter t (G.center g) v))) := + Finset.sum_congr rfl fun v _ => by ring + _ = (G.order : ℝ) * (G.mean f * G.mean g) + + (G.mean f * (∑ v : G.V, G.stepIter t (G.center g) v) + + (G.mean g * (∑ v : G.V, G.center f v) + + ∑ v : G.V, G.center f v * G.stepIter t (G.center g) v)) := by + simp only [Finset.sum_add_distrib, ← Finset.mul_sum, Finset.sum_const, + Finset.card_univ, nsmul_eq_mul, card_eq_order] + ring + _ = (G.order : ℝ) * (G.mean f * G.mean g) + + ∑ v : G.V, G.center f v * G.stepIter t (G.center g) v := by + rw [hsumS, hsumF]; ring + _ = (∑ v : G.V, f v) * (∑ v : G.V, g v) / (G.order : ℝ) + + ∑ v : G.V, G.center f v * G.stepIter t (G.center g) v := by + simp only [mean] + field_simp + +/-- **The expander mixing lemma for `t`-step walks.** -/ +theorem mixing_sq {lam : ℝ} (h : G.SpectralBound lam) (hn : 0 < G.order) (t : ℕ) + (f g : G.V → ℝ) : + (∑ v : G.V, f v * G.stepIter t g v + - (∑ v : G.V, f v) * (∑ v : G.V, g v) / (G.order : ℝ)) ^ 2 + ≤ lam ^ (2 * t) * ((∑ v : G.V, (f v) ^ 2) - (∑ v : G.V, f v) ^ 2 / (G.order : ℝ)) + * ((∑ v : G.V, (g v) ^ 2) - (∑ v : G.V, g v) ^ 2 / (G.order : ℝ)) := by + have hcorr : ∑ v : G.V, f v * G.stepIter t g v + - (∑ v : G.V, f v) * (∑ v : G.V, g v) / (G.order : ℝ) + = ∑ v : G.V, G.center f v * G.stepIter t (G.center g) v := by + rw [G.inner_stepIter_eq hn t f g]; ring + rw [hcorr, ← G.sum_sq_center hn f, ← G.sum_sq_center hn g] + have hcs : (∑ v : G.V, G.center f v * G.stepIter t (G.center g) v) ^ 2 + ≤ (∑ v : G.V, (G.center f v) ^ 2) + * ∑ v : G.V, (G.stepIter t (G.center g) v) ^ 2 := + Finset.sum_mul_sq_le_sq_mul_sq _ _ _ + have hspec : ∑ v : G.V, (G.stepIter t (G.center g) v) ^ 2 + ≤ lam ^ (2 * t) * ∑ v : G.V, (G.center g v) ^ 2 := + G.sum_sq_stepIter_le h t (G.center g) (G.sum_center hn g) + calc (∑ v : G.V, G.center f v * G.stepIter t (G.center g) v) ^ 2 + ≤ (∑ v : G.V, (G.center f v) ^ 2) + * ∑ v : G.V, (G.stepIter t (G.center g) v) ^ 2 := hcs + _ ≤ (∑ v : G.V, (G.center f v) ^ 2) + * (lam ^ (2 * t) * ∑ v : G.V, (G.center g v) ^ 2) := by + exact mul_le_mul_of_nonneg_left hspec (G.sum_sq_center_nonneg f) + _ = lam ^ (2 * t) * (∑ v : G.V, (G.center f v) ^ 2) + * ∑ v : G.V, (G.center g v) ^ 2 := by ring + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/NatEncode.lean b/Complexitylib/Classes/PCP/Internal/NatEncode.lean new file mode 100644 index 00000000..7682d3d9 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/NatEncode.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.StripTrailing +public import Complexitylib.Classes.PCP.Internal.PosScan + +/-! +# Writing out an encoded bit list + +`DataEncode` serializes a list of booleans as a substitution cipher inside one +pair of brackets: `false` becomes `01` and `true` becomes `0011`. Producing that +is a fold over the list, which `recFoldClamp` runs in polynomial time. + +Since a natural number is encoded *as* its `Nat.bits`, this is also the last +step of encoding a number: count the value out in binary, drop the trailing +zeros, and run the cipher. + +## Main definitions + +- `Complexity.boolBits` — the two-symbol cipher + +## Main results + +- `Complexity.bitstringEncode_list` — the cipher describes the encoding +- `Complexity.flatBitsFn_mem_FP` — running it is polynomial time +- `Complexity.natEncodeFn_eq` — a number's encoding, from its value in unary +-/ + +@[expose] public section + +namespace Complexity + +/-- The serialization of a single boolean. -/ +def boolBits (b : Bool) : List Bool := if b then [false, false, true, true] else [false, true] + +theorem boolBits_eq (b : Bool) : boolBits b = (DataEncode.encode b).toBits := by + cases b + · show [false, true] = (Data.l []).toBits + rw [Data.toBits_l] + simp + · show [false, false, true, true] = (Data.l [Data.l []]).toBits + rw [Data.toBits_l] + simp only [List.map_cons, List.map_nil, List.flatten_cons, List.flatten_nil] + rw [show (Data.l ([] : List Data)).toBits = [false, true] from by + rw [Data.toBits_l]; simp] + simp + +@[simp] theorem length_boolBits (b : Bool) : (boolBits b).length ≤ 4 := by + cases b <;> simp [boolBits] + +/-- **The cipher describes the encoding.** -/ +theorem bitstringEncode_list (l : List Bool) : + DataEncode.bitstringEncode l = false :: (l.flatMap boolBits) ++ [true] := by + rw [DataEncode.bitstringEncode_def, + show DataEncode.encode l = Data.l (l.map DataEncode.encode) from rfl, Data.toBits_l, + List.map_map] + congr 2 + rw [List.flatMap_def] + congr 1 + refine List.map_congr_left fun b _ => ?_ + rw [Function.comp_apply, boolBits_eq] + +/-! ### Running the cipher -/ + +/-- The fold step on a zero. -/ +def blitZero (z : List Bool) : List Bool := + [false, true] ++ Cobham.sndBlock (Cobham.fstBlock z) + +/-- The fold step on a one. -/ +def blitOne (z : List Bool) : List Bool := + [false, false, true, true] ++ Cobham.sndBlock (Cobham.fstBlock z) + +theorem blitZero_mem_FP : blitZero ∈ FP := by + have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact Cobham.appendFn_mem_FP (constFn_mem_FP [false, true]) h + +theorem blitOne_mem_FP : blitOne ∈ FP := by + have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact Cobham.appendFn_mem_FP (constFn_mem_FP [false, false, true, true]) h + +theorem length_flatMap_boolBits (l : List Bool) : + (l.flatMap boolBits).length ≤ 4 * l.length := by + induction l with + | nil => simp + | cons b t ih => + rw [List.flatMap_cons, List.length_append, List.length_cons] + have := length_boolBits b + omega + +theorem recFoldClamp_flatBits (bound : ℕ) (W : List Bool) : + ∀ l : List Bool, 4 * l.length ≤ bound → + Cobham.recFoldClamp blitZero blitOne bound [] W l = l.flatMap boolBits := by + intro l + induction l with + | nil => + intro _ + rw [Cobham.recFoldClamp] + simp + | cons b t ih => + intro hb + have hb' : 4 * t.length ≤ bound := by + simp only [List.length_cons] at hb + omega + rw [Cobham.recFoldClamp, ih hb'] + have hstate : Cobham.sndBlock (Cobham.fstBlock + (pair (pair W (t.flatMap boolBits)) t)) = t.flatMap boolBits := by + rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hlt := length_flatMap_boolBits t + cases b + · show (blitZero _).take bound = _ + rw [blitZero, hstate, List.flatMap_cons, + show boolBits false = [false, true] from rfl] + refine List.take_of_length_le ?_ + rw [List.length_append] + simp only [List.length_cons, List.length_nil, List.length_cons] at hb ⊢ + omega + · show (blitOne _).take bound = _ + rw [blitOne, hstate, List.flatMap_cons, + show boolBits true = [false, false, true, true] from rfl] + refine List.take_of_length_le ?_ + rw [List.length_append] + simp only [List.length_cons, List.length_nil, List.length_cons] at hb ⊢ + omega + +/-- The cipher applied to `sndBlock z`. -/ +def flatBitsFn (z : List Bool) : List Bool := + Cobham.recFoldClamp blitZero blitOne (4 * z.length) [] (Cobham.fstBlock z) + (Cobham.sndBlock z) + +theorem flatBitsFn_mem_FP : flatBitsFn ∈ FP := by + have := Cobham.recFoldClamp_mem_FP blitZero_mem_FP blitOne_mem_FP + (constFn_mem_FP []) (Polynomial.C 4 * Polynomial.X) + refine mem_FP_of_eq this fun z => ?_ + rw [flatBitsFn] + simp + +theorem flatBitsFn_eq (z : List Bool) : + flatBitsFn z = (Cobham.sndBlock z).flatMap boolBits := by + refine recFoldClamp_flatBits _ _ _ ?_ + have := sndBlock_length_le z + omega + +/-- **The encoding of a bit list, in polynomial time.** -/ +def encodeListFn (z : List Bool) : List Bool := false :: flatBitsFn z ++ [true] + +theorem encodeListFn_mem_FP : encodeListFn ∈ FP := by + have hcons := mem_FP_comp flatBitsFn_mem_FP (Cobham.cons_mem_FP false) + have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) + refine mem_FP_of_eq this fun z => ?_ + rw [encodeListFn] + simp [Function.comp] + +theorem encodeListFn_eq (z : List Bool) : + encodeListFn z = DataEncode.bitstringEncode (Cobham.sndBlock z) := by + rw [encodeListFn, flatBitsFn_eq, bitstringEncode_list] + +/-! ### A number's own encoding -/ + +/-- **The encoding of a natural number**, from a width and a value both given in +unary. -/ +noncomputable def natEncodeFn (z : List Bool) : List Bool := + encodeListFn (pair [] (stripFn (pair [] + (coinStr (Cobham.fstBlock z).length (Cobham.sndBlock z).length)))) + +theorem natEncodeFn_mem_FP : natEncodeFn ∈ FP := by + have hw : (fun z : List Bool => + List.replicate (Cobham.fstBlock z).length true) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP unaryLength_mem_FP + simpa [Function.comp] using this + have hv : (fun z : List Bool => + List.replicate (Cobham.sndBlock z).length true) ∈ FP := by + have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP + simpa [Function.comp] using this + have hcoin := coinStr_mem_FP hw hv + have h1 : (fun z => pair [] (coinStr (Cobham.fstBlock z).length + (Cobham.sndBlock z).length)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP []) hcoin + have h2 := mem_FP_comp h1 stripFn_mem_FP + have h3 : (fun z => pair [] (stripFn (pair [] + (coinStr (Cobham.fstBlock z).length (Cobham.sndBlock z).length)))) ∈ FP := by + refine Cobham.pairFn_mem_FP (constFn_mem_FP []) ?_ + simpa [Function.comp] using h2 + have := mem_FP_comp h3 encodeListFn_mem_FP + simpa [Function.comp, natEncodeFn] using this + +/-- **It really is the number's encoding**, whenever the width holds the +value. -/ +theorem natEncodeFn_eq {z : List Bool} + (h : (Cobham.sndBlock z).length < 2 ^ (Cobham.fstBlock z).length) : + natEncodeFn z = DataEncode.bitstringEncode ((Cobham.sndBlock z).length) := by + rw [natEncodeFn, encodeListFn_eq, Cobham.sndBlock_pair, stripFn_eq, Cobham.sndBlock_pair, + coinStr_eq h, stripTrailing_eq_bits, binValLE_bitsOfLenLE _ _ h] + rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/NumEnc.lean b/Complexitylib/Classes/PCP/Internal/NumEnc.lean new file mode 100644 index 00000000..45ee519b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/NumEnc.lean @@ -0,0 +1,350 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Data.Fintype.Card +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Fintype.Sum +public import Mathlib.Tactic.NormNum +public import Mathlib.Tactic.Ring + +/-! +# Numbering a structured index + +The index types of Dinur's construction are built from a few formers: a pair of +indices, a choice between two, an optional one, a tuple. `Fintype` numbers such +a type too, but by an enumeration no algorithm can follow. This module numbers +them explicitly instead: a pair is numbered by mixed radix, a choice by +offsetting the second summand, a tuple by its digits. + +The decoding is partial — a number out of range names nothing — which is what +makes the numbering compose without needing any type to be inhabited. + +## Main definitions + +- `Complexity.NumEnc` — an explicit numbering of a finite type + +## Main results + +- the instances for `Fin`, `Bool`, `Unit`, products, sums, options and tuples +-/ + +@[expose] public section + +namespace Complexity + +/-- An explicit numbering of a finite type: every value has a number below +`card`, and every number below `card` names a value. -/ +class NumEnc (α : Type) where + /-- How many values there are. -/ + card : ℕ + /-- The number of a value. -/ + enc : α → ℕ + /-- The value a number names, if any. -/ + dec : ℕ → Option α + /-- Numbers are below the count. -/ + enc_lt : ∀ a, enc a < card + /-- Decoding a number back gives the value. -/ + dec_enc : ∀ a, dec (enc a) = some a + /-- And a number in range is the number of what it names. -/ + enc_dec : ∀ i a, dec i = some a → enc a = i + /-- Every number below the count names something. -/ + dec_isSome : ∀ i, i < card → (dec i).isSome + +namespace NumEnc + +open NumEnc (card enc dec) + +variable {α β : Type} + +theorem enc_injective [NumEnc α] : Function.Injective (enc : α → ℕ) := by + intro a b h + have ha := dec_enc a + rw [h, dec_enc b] at ha + exact (Option.some_injective _ ha).symm + +theorem dec_eq_none_of_le [NumEnc α] {i : ℕ} (h : card α ≤ i) : dec i = (none : Option α) := by + cases hd : (dec i : Option α) with + | none => rfl + | some a => + have := enc_dec i a hd + have := enc_lt a + omega + +/-- The value a number in range names. -/ +def get [NumEnc α] {i : ℕ} (h : i < card α) : α := (dec i).get (dec_isSome i h) + +@[simp] theorem dec_get [NumEnc α] {i : ℕ} (h : i < card α) : dec (α := α) i = some (get h) := + (Option.some_get _).symm + +@[simp] theorem enc_get [NumEnc α] {i : ℕ} (h : i < card α) : enc (get h) = i := + enc_dec i _ (dec_get h) + +@[simp] theorem get_enc [NumEnc α] (a : α) : get (enc_lt a) = a := by + have h := dec_get (enc_lt a) + rw [dec_enc a] at h + exact (Option.some_injective _ h).symm + +/-- **The count is the number of values.** -/ +theorem card_eq_fintype_card (α : Type) [Fintype α] [NumEnc α] : + card α = Fintype.card α := by + have hbij : Function.Bijective (fun i : Fin (card α) => get i.isLt) := by + constructor + · intro i j h + have hi : enc (get i.isLt) = i.val := enc_get i.isLt + have hj : enc (get j.isLt) = j.val := enc_get j.isLt + have hij : enc (get i.isLt) = enc (get j.isLt) := congrArg enc h + rw [hi, hj] at hij + exact Fin.ext hij + · intro a + exact ⟨⟨enc a, enc_lt a⟩, get_enc a⟩ + have := Fintype.card_of_bijective hbij + rw [Fintype.card_fin] at this + exact this + +/-- The numbering, as an equivalence with an initial segment. -/ +def equivFin (α : Type) [NumEnc α] : α ≃ Fin (card α) where + toFun a := ⟨enc a, enc_lt a⟩ + invFun i := get i.isLt + left_inv a := by simp + right_inv i := Fin.ext (enc_get i.isLt) + +/-- The numbering, as an equivalence with `Fin` of the type's own cardinality — +a drop-in replacement for `Fintype.equivFin` that an algorithm can follow. -/ +noncomputable def equivFinCard (α : Type) [Fintype α] [NumEnc α] : α ≃ Fin (Fintype.card α) := + (equivFin α).trans (finCongr (card_eq_fintype_card α)) + +@[simp] theorem val_equivFinCard (α : Type) [Fintype α] [NumEnc α] (a : α) : + (equivFinCard α a).val = enc a := rfl + +/-! ### The formers -/ + +instance instFin (n : ℕ) : NumEnc (Fin n) where + card := n + enc i := i.val + dec i := if h : i < n then some ⟨i, h⟩ else none + enc_lt i := i.isLt + dec_enc i := by rw [dif_pos i.isLt] + enc_dec i a h := by + by_cases hi : i < n + · rw [dif_pos hi] at h + exact congrArg Fin.val (Option.some_injective _ h).symm + · rw [dif_neg hi] at h + exact absurd h (by simp) + dec_isSome i hi := by rw [dif_pos hi]; rfl + +instance instBool : NumEnc Bool where + card := 2 + enc b := if b then 0 else 1 + dec i := if i = 0 then some true else if i = 1 then some false else none + enc_lt b := by cases b <;> norm_num + dec_enc b := by cases b <;> norm_num + enc_dec i a h := by + by_cases h0 : i = 0 + · subst h0 + simp at h + subst h + norm_num + · by_cases h1 : i = 1 + · subst h1 + simp at h + subst h + norm_num + · rw [if_neg h0, if_neg h1] at h + exact absurd h (by simp) + dec_isSome i hi := by + by_cases h0 : i = 0 + · subst h0; rfl + · have h1 : i = 1 := by omega + subst h1; rfl + +instance instUnit : NumEnc Unit where + card := 1 + enc _ := 0 + dec i := if i = 0 then some () else none + enc_lt _ := by norm_num + dec_enc _ := by norm_num + enc_dec i a h := by + by_cases h0 : i = 0 + · subst h0; rfl + · rw [if_neg h0] at h + exact absurd h (by simp) + dec_isSome i hi := by + have h0 : i = 0 := by omega + subst h0 + rfl + +theorem prod_lt [NumEnc α] [NumEnc β] (a : α) (b : β) : + enc a * card β + enc b < card α * card β := by + have h1 := enc_lt a + have h2 := enc_lt b + calc enc a * card β + enc b < enc a * card β + card β := by omega + _ = (enc a + 1) * card β := by ring + _ ≤ card α * card β := Nat.mul_le_mul_right _ h1 + +theorem prod_div [NumEnc α] [NumEnc β] (a : α) (b : β) : + (enc a * card β + enc b) / card β = enc a := by + have h2 := enc_lt b + have hb : 0 < card β := by omega + rw [show enc a * card β + enc b = enc b + card β * enc a by ring, + Nat.add_mul_div_left _ _ hb, Nat.div_eq_of_lt h2, Nat.zero_add] + +theorem prod_mod [NumEnc α] [NumEnc β] (a : α) (b : β) : + (enc a * card β + enc b) % card β = enc b := by + have h2 := enc_lt b + rw [show enc a * card β + enc b = enc b + card β * enc a by ring, + Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt h2] + +instance instProd [NumEnc α] [NumEnc β] : NumEnc (α × β) where + card := card α * card β + enc p := enc p.1 * card β + enc p.2 + dec i := + if i < card α * card β then + (dec (i / card β)).bind fun a => (dec (i % card β)).map fun b => (a, b) + else none + enc_lt p := prod_lt p.1 p.2 + dec_enc p := by + rw [if_pos (prod_lt p.1 p.2), prod_div, prod_mod, dec_enc, dec_enc] + rfl + enc_dec i p h := by + by_cases hlt : i < card α * card β + · rw [if_pos hlt] at h + rw [Option.bind_eq_some_iff] at h + obtain ⟨a, ha, hb⟩ := h + rw [Option.map_eq_some_iff] at hb + obtain ⟨b, hbb, hp⟩ := hb + have hea := enc_dec _ a ha + have heb := enc_dec _ b hbb + have hcb : 0 < card β := by + have := enc_lt b + omega + show enc p.1 * card β + enc p.2 = i + rw [← hp] + show enc a * card β + enc b = i + rw [hea, heb, Nat.mul_comm] + exact Nat.div_add_mod i (card β) + · rw [if_neg hlt] at h + exact absurd h (by simp) + + dec_isSome i hi := by + have hb : 0 < card β := by + rcases Nat.eq_zero_or_pos (card β) with h | h + · rw [h, Nat.mul_zero] at hi; omega + · exact h + have hia : i / card β < card α := (Nat.div_lt_iff_lt_mul hb).mpr hi + have him : i % card β < card β := Nat.mod_lt _ hb + obtain ⟨a, ha⟩ := Option.isSome_iff_exists.mp (dec_isSome _ hia) + obtain ⟨b, hbb⟩ := Option.isSome_iff_exists.mp (dec_isSome _ him) + rw [if_pos hi, ha, hbb] + rfl + +instance instSum [NumEnc α] [NumEnc β] : NumEnc (α ⊕ β) where + card := card α + card β + enc := Sum.elim enc fun b => card α + enc b + dec i := if i < card α then (dec i).map Sum.inl else (dec (i - card α)).map Sum.inr + enc_lt x := by + cases x with + | inl a => have := enc_lt a; simpa using by omega + | inr b => have := enc_lt b; simpa using by omega + dec_enc x := by + cases x with + | inl a => + have ha := enc_lt a + show (if enc a < card α then _ else _) = _ + simp only [Sum.elim_inl] + rw [if_pos ha, dec_enc] + rfl + | inr b => + have hb : ¬ card α + enc b < card α := by omega + show (if card α + enc b < card α then _ else _) = _ + simp only [Sum.elim_inr] + rw [if_neg hb, Nat.add_sub_cancel_left, dec_enc] + rfl + enc_dec i x h := by + by_cases hi : i < card α + · rw [if_pos hi, Option.map_eq_some_iff] at h + obtain ⟨a, ha, hx⟩ := h + have := enc_dec _ a ha + rw [← hx] + show enc a = i + exact this + · rw [if_neg hi, Option.map_eq_some_iff] at h + obtain ⟨b, hb, hx⟩ := h + have := enc_dec _ b hb + rw [← hx] + show card α + enc b = i + omega + + dec_isSome i hi := by + by_cases h : i < card α + · obtain ⟨a, ha⟩ := Option.isSome_iff_exists.mp (dec_isSome (α := α) _ h) + rw [if_pos h, ha] + rfl + · have hb : i - card α < card β := by omega + obtain ⟨b, hbb⟩ := Option.isSome_iff_exists.mp (dec_isSome (α := β) _ hb) + rw [if_neg h, hbb] + rfl + +instance instOption [NumEnc α] : NumEnc (Option α) where + card := card α + 1 + enc o := match o with | none => 0 | some a => 1 + enc a + dec i := if i = 0 then some none else (dec (i - 1)).map some + enc_lt o := by + cases o with + | none => show 0 < card α + 1; omega + | some a => have := enc_lt a; show 1 + enc a < _; omega + dec_enc o := by + cases o with + | none => show (if (0 : ℕ) = 0 then _ else _) = _; rw [if_pos rfl] + | some a => + show (if 1 + enc a = 0 then _ else _) = _ + rw [if_neg (by omega), show 1 + enc a - 1 = enc a by omega, dec_enc] + rfl + enc_dec i o h := by + by_cases h0 : i = 0 + · rw [if_pos h0] at h + rw [← Option.some_injective _ h] + show 0 = i + omega + · rw [if_neg h0, Option.map_eq_some_iff] at h + obtain ⟨a, ha, ho⟩ := h + have := enc_dec _ a ha + rw [← ho] + show 1 + enc a = i + omega + dec_isSome i hi := by + by_cases h0 : i = 0 + · rw [if_pos h0] + rfl + · have hb : i - 1 < card α := by omega + obtain ⟨a, ha⟩ := Option.isSome_iff_exists.mp (dec_isSome (α := α) _ hb) + rw [if_neg h0, ha] + rfl + +/-- Any finite type is numbered by its own enumeration. For a type whose size +is a constant, that is all an algorithm needs: the numbering is a lookup on a +bounded key. -/ +@[reducible] noncomputable def ofFintype (α : Type) [Fintype α] : NumEnc α where + card := Fintype.card α + enc a := (Fintype.equivFin α a).val + dec i := if h : i < Fintype.card α then some ((Fintype.equivFin α).symm ⟨i, h⟩) else none + enc_lt a := (Fintype.equivFin α a).isLt + dec_enc a := by + rw [dif_pos (Fintype.equivFin α a).isLt] + simp + enc_dec i a h := by + by_cases hi : i < Fintype.card α + · rw [dif_pos hi] at h + rw [← Option.some_injective _ h] + simp + · rw [dif_neg hi] at h + exact absurd h (by simp) + dec_isSome i hi := by + rw [dif_pos hi] + rfl + +end NumEnc + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/NumEncPi.lean b/Complexitylib/Classes/PCP/Internal/NumEncPi.lean new file mode 100644 index 00000000..20a1a5c2 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/NumEncPi.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.NumEnc +public import Mathlib.Algebra.BigOperators.Fin + +/-! +# Numbering a tuple + +A walk is a tuple of darts, and a coin sequence is a tuple of coins. This module +numbers such a tuple the way a numeral works: the `j`-th entry contributes its +own number times the base to the `j`-th power. Reading an entry back is dividing +by that power and taking the remainder, which is what an algorithm does. + +## Main results + +- `Complexity.NumEnc.instPi` — the `NumEnc` instance for `Fin n → α` +- `Complexity.NumEnc.digit_sum`, `Complexity.NumEnc.sum_digits` — reading a + digit, and reassembling a number from its digits +-/ + +@[expose] public section + +namespace Complexity + +namespace NumEnc + +open NumEnc (card enc dec) + +variable {α : Type} + +/-! ### Digits -/ + +theorem sum_lt_pow {c n : ℕ} (g : ℕ → ℕ) (hg : ∀ i < n, g i < c) : + ∑ i ∈ Finset.range n, g i * c ^ i < c ^ n := by + induction n with + | zero => simp + | succ n ih => + rw [Finset.sum_range_succ, pow_succ] + have h1 : ∑ i ∈ Finset.range n, g i * c ^ i < c ^ n := ih fun i hi => hg i (by omega) + have h2 : g n < c := hg n (by omega) + calc (∑ i ∈ Finset.range n, g i * c ^ i) + g n * c ^ n + < c ^ n + g n * c ^ n := by omega + _ = (g n + 1) * c ^ n := by ring + _ ≤ c * c ^ n := Nat.mul_le_mul_right _ (by omega) + _ = c ^ n * c := by ring + +theorem digit_sum {c : ℕ} (hc : 0 < c) (g : ℕ → ℕ) : + ∀ {n j : ℕ}, j < n → (∀ i < n, g i < c) → + (∑ i ∈ Finset.range n, g i * c ^ i) / c ^ j % c = g j := by + intro n + induction n with + | zero => intro j hj; omega + | succ n ih => + intro j hj hg + rcases Nat.lt_or_ge j n with hjn | hjn + · have hstep : (∑ i ∈ Finset.range (n + 1), g i * c ^ i) / c ^ j % c + = (∑ i ∈ Finset.range n, g i * c ^ i) / c ^ j % c := by + rw [Finset.sum_range_succ] + have hpow : c ^ n = c ^ j * c ^ (n - j) := by + rw [← pow_add] + congr 1 + omega + have hdvd : c ∣ c ^ (n - j) := dvd_pow_self c (by omega) + obtain ⟨t, ht⟩ := hdvd + rw [hpow, ht] + rw [show g n * (c ^ j * (c * t)) = c ^ j * (g n * (c * t)) by ring, + Nat.add_mul_div_left _ _ (Nat.pow_pos hc), + show g n * (c * t) = (g n * t) * c by ring, Nat.add_mul_mod_self_right] + rw [hstep] + exact ih hjn fun i hi => hg i (by omega) + · have hjeq : j = n := by omega + subst hjeq + rw [Finset.sum_range_succ] + have hlt : ∑ i ∈ Finset.range j, g i * c ^ i < c ^ j := + sum_lt_pow g fun i hi => hg i (by omega) + rw [show g j * c ^ j = c ^ j * g j by ring, + Nat.add_mul_div_left _ _ (Nat.pow_pos hc), Nat.div_eq_of_lt hlt, + Nat.zero_add, Nat.mod_eq_of_lt (hg j (by omega))] + +theorem sum_digits {c : ℕ} : + ∀ {n i : ℕ}, i < c ^ n → ∑ j ∈ Finset.range n, (i / c ^ j % c) * c ^ j = i := by + intro n + induction n with + | zero => + intro i hi + simp only [pow_zero] at hi + simp + omega + | succ n ih => + intro i hi + rw [Finset.sum_range_succ'] + have h1 : ∀ j, i / c ^ (j + 1) % c = (i / c) / c ^ j % c := by + intro j + rw [pow_succ, Nat.div_div_eq_div_mul, Nat.mul_comm] + have h2 : i / c < c ^ n := by + refine Nat.div_lt_of_lt_mul ?_ + rw [Nat.mul_comm, ← pow_succ] + exact hi + have h3 : ∑ j ∈ Finset.range n, (i / c ^ (j + 1) % c) * c ^ (j + 1) + = (∑ j ∈ Finset.range n, ((i / c) / c ^ j % c) * c ^ j) * c := by + rw [Finset.sum_mul] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [h1 j, pow_succ] + ring + rw [h3, ih h2] + simp only [pow_zero, Nat.mul_one, Nat.div_one] + rw [Nat.mul_comm] + exact Nat.div_add_mod i c + +/-! ### The instance -/ + +theorem get_eq [NumEnc α] {i : ℕ} (hi : i < card α) {a : α} (h : i = enc a) : + get hi = a := by + have h1 : enc (get hi) = i := enc_get hi + exact enc_injective (h1.trans h) + +/-- The number of the `i`-th entry of a tuple, or zero past its end. -/ +def encAt {n : ℕ} [NumEnc α] (f : Fin n → α) (i : ℕ) : ℕ := + if h : i < n then enc (f ⟨i, h⟩) else 0 + +theorem encAt_lt {n : ℕ} [NumEnc α] (f : Fin n → α) {i : ℕ} (hi : i < n) : + encAt f i < card α := by + rw [encAt, dif_pos hi] + exact enc_lt _ + +/-- **A tuple is numbered like a numeral.** -/ +instance instPi (n : ℕ) [NumEnc α] : NumEnc (Fin n → α) where + card := card α ^ n + enc f := ∑ i ∈ Finset.range n, encAt f i * card α ^ i + dec i := + if h : i < card α ^ n then + some fun j : Fin n => + get (show i / card α ^ j.val % card α < card α from by + have hpos : 0 < card α ^ n := Nat.lt_of_le_of_lt (Nat.zero_le _) h + have hc : 0 < card α := by + by_contra hcon + have hz : card α = 0 := by omega + have hn : 0 < n := Nat.lt_of_le_of_lt (Nat.zero_le _) j.isLt + rw [hz, zero_pow (by omega)] at hpos + omega + exact Nat.mod_lt _ hc) + else none + enc_lt f := sum_lt_pow _ fun i hi => encAt_lt f hi + dec_enc f := by + have hlt : (∑ i ∈ Finset.range n, encAt f i * card α ^ i) < card α ^ n := + sum_lt_pow _ fun i hi => encAt_lt f hi + rw [dif_pos hlt] + congr 1 + funext j + have hc : 0 < card α := Nat.lt_of_le_of_lt (Nat.zero_le _) (enc_lt (f j)) + have hdig := digit_sum (c := card α) hc (encAt f) j.isLt + (fun i hi => encAt_lt f hi) + have hval : encAt f j.val = enc (f j) := by + rw [encAt, dif_pos j.isLt] + exact get_eq _ (hdig.trans hval) + enc_dec i f h := by + by_cases hi : i < card α ^ n + · rw [dif_pos hi] at h + have hf := Option.some_injective _ h + subst hf + show ∑ j ∈ Finset.range n, encAt _ j * card α ^ j = i + refine Eq.trans (Finset.sum_congr rfl fun j hj => ?_) (sum_digits hi) + rw [encAt, dif_pos (Finset.mem_range.mp hj), enc_get] + · rw [dif_neg hi] at h + exact absurd h (by simp) + dec_isSome i hi := by + rw [dif_pos hi] + rfl + +end NumEnc + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean b/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean new file mode 100644 index 00000000..fe12d69a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean @@ -0,0 +1,373 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.SubsetNP +public import Complexitylib.SAT.Semantics +public import Complexitylib.SAT.Language +public import Complexitylib.SAT.Verifier + +/-! +# A PCP verifier as a CNF formula + +`SubsetNP` reduces "some proof is accepted on every coin string" to "some +bitstring is a witness": a table, laid out one block of `Q` answers per coin +string, that is consistent and accepted everywhere. Both conditions are +predicates on individual bits of that bitstring, so both are CNF clauses. + +That is what this module builds. The formula's variables *are* the positions of +the witness — a SAT assignment and a witness are the same object, since both +read out of range as `false` — so the encoding needs no translation of models. + +* Consistency contributes, for each pair of query slots that read the same proof + position, the two clauses saying their variables agree. +* Acceptance contributes, for each coin string and each answer vector the + verdict rejects, the clause blocking that vector. + +With `r` coins and `q` queries the formula has `2^r q` variables and +`O(4^r q^2 + 2^r 2^q)` clauses — polynomial when `r` is logarithmic and `q` +constant. + +## Main definitions + +- `Complexity.allVecs` — the bit vectors of a given length +- `Complexity.PCPVerifier.varIdx` — the variable holding one answer +- `Complexity.PCPVerifier.toCNF` — the formula + +## Main results + +- `Complexity.mem_allVecs_iff` — `allVecs n` is exactly the vectors of length `n` +-/ + +@[expose] public section + +namespace Complexity + +open SAT + +/-! ### Enumerating bit vectors -/ + +/-- Every bit vector of a given length. -/ +def allVecs : ℕ → List (List Bool) + | 0 => [[]] + | n + 1 => (allVecs n).flatMap fun v => [false :: v, true :: v] + +theorem mem_allVecs_iff : ∀ (n : ℕ) (b : List Bool), b ∈ allVecs n ↔ b.length = n := by + intro n + induction n with + | zero => + intro b + constructor + · intro hb + simp only [allVecs, List.mem_singleton] at hb + rw [hb] + rfl + · intro hb + have : b = [] := List.length_eq_zero_iff.1 hb + rw [this] + simp [allVecs] + | succ m ih => + intro b + constructor + · intro hb + simp only [allVecs, List.mem_flatMap] at hb + obtain ⟨v, hv, hbv⟩ := hb + have hlen : v.length = m := (ih v).1 hv + simp only [List.mem_cons] at hbv + rcases hbv with h | h | h + · rw [h, List.length_cons, hlen] + · rw [h, List.length_cons, hlen] + · exact absurd h (by simp) + · intro hb + match b with + | [] => exact absurd hb (by simp) + | c :: v => + have hlen : v.length = m := by + rw [List.length_cons] at hb + omega + simp only [allVecs, List.mem_flatMap] + refine ⟨v, (ih v).2 hlen, ?_⟩ + cases c <;> simp + +namespace PCPVerifier + +variable (V : PCPVerifier) + +/-! ### Variables -/ + +/-- The variable holding the answer to query `i` on coin string `ρ`. The blocks +sit a stride `Q` apart, exactly as `SubsetNP.tableOf` reads them. -/ +def varIdx (t Q : ℕ) (ρ : Fin t → Bool) (i : ℕ) : ℕ := coinIndex ρ * Q + i + +theorem get_varIdx (t Q : ℕ) (x w : List Bool) (ρ : Fin t → Bool) {i : ℕ} + (hi : i < (V.positions x (BitString.toList ρ)).length) : + (V.tableOf t Q x w ρ)[i]? = some (Assignment.get w (varIdx t Q ρ i)) := by + rw [tableOf] + rw [List.getElem?_map, List.getElem?_range hi] + rfl + +/-! ### The clauses -/ + +/-- The coin strings, listed by index. Computable, unlike an enumeration drawn +from `Finset.univ`, because the reduction has to be carried out by a machine. -/ +def coinList (t : ℕ) : List (Fin t → Bool) := + (List.finRange (2 ^ t)).map coinOfIndex + +theorem mem_coinList (t : ℕ) (ρ : Fin t → Bool) : ρ ∈ coinList t := by + rw [coinList, List.mem_map] + exact ⟨⟨coinIndex ρ, coinIndex_lt ρ⟩, List.mem_finRange _, coinOfIndex_coinIndex ρ _⟩ + +/-- Two query slots reading the same proof position must get the same answer. -/ +def consClauses (t Q : ℕ) (x : List Bool) : List Clause := + (coinList t).flatMap fun ρ => + (coinList t).flatMap fun ρ' => + (List.range (V.positions x (BitString.toList ρ)).length).flatMap fun i => + (List.range (V.positions x (BitString.toList ρ')).length).flatMap fun i' => + if (V.positions x (BitString.toList ρ))[i]? + = (V.positions x (BitString.toList ρ'))[i']? then + [[⟨false, varIdx t Q ρ i⟩, ⟨true, varIdx t Q ρ' i'⟩], + [⟨true, varIdx t Q ρ i⟩, ⟨false, varIdx t Q ρ' i'⟩]] + else [] + +/-- For each coin string, a clause blocking every answer vector the verdict +rejects. The verdict arrives as a Boolean function, which is the form a +polynomial-time decision procedure takes. -/ +def acceptClauses (g : List Bool → Bool) (t Q : ℕ) (x : List Bool) : List Clause := + (coinList t).flatMap fun ρ => + ((allVecs (V.positions x (BitString.toList ρ)).length).filter fun b => + !g (pair (pair x (BitString.toList ρ)) b)).map fun b => + (List.range (V.positions x (BitString.toList ρ)).length).map fun i => + (⟨!(b.getD i false), varIdx t Q ρ i⟩ : Lit) + +/-- **The formula of a verifier on an input.** -/ +def toCNF (g : List Bool → Bool) (t Q : ℕ) (x : List Bool) : CNF := + V.consClauses t Q x ++ V.acceptClauses g t Q x + +/-! ### Semantics of the consistency clauses -/ + +theorem eval_consClauses_iff (t Q : ℕ) (x w : List Bool) : + CNF.eval w (V.consClauses t Q x) = true ↔ + ∀ (ρ ρ' : Fin t → Bool) (i i' : ℕ), + i < (V.positions x (BitString.toList ρ)).length → + i' < (V.positions x (BitString.toList ρ')).length → + (V.positions x (BitString.toList ρ))[i]? + = (V.positions x (BitString.toList ρ'))[i']? → + Assignment.get w (varIdx t Q ρ i) = Assignment.get w (varIdx t Q ρ' i') := by + classical + rw [CNF.eval, List.all_eq_true] + constructor + · intro h ρ ρ' i i' hi hi' hpos + have hmem : ([⟨false, varIdx t Q ρ i⟩, ⟨true, varIdx t Q ρ' i'⟩] : Clause) + ∈ V.consClauses t Q x := by + rw [consClauses] + simp only [List.mem_flatMap] + exact ⟨ρ, mem_coinList t ρ, ρ', mem_coinList t ρ', i, List.mem_range.2 hi, + i', List.mem_range.2 hi', by rw [if_pos hpos]; simp⟩ + have hmem2 : ([⟨true, varIdx t Q ρ i⟩, ⟨false, varIdx t Q ρ' i'⟩] : Clause) + ∈ V.consClauses t Q x := by + rw [consClauses] + simp only [List.mem_flatMap] + exact ⟨ρ, mem_coinList t ρ, ρ', mem_coinList t ρ', i, List.mem_range.2 hi, + i', List.mem_range.2 hi', by rw [if_pos hpos]; simp⟩ + have h1 := h _ hmem + have h2 := h _ hmem2 + simp only [Clause.eval, List.any_cons, List.any_nil, Lit.eval, Bool.or_false, + Bool.or_eq_true, beq_iff_eq] at h1 h2 + rcases h1 with h1 | h1 <;> rcases h2 with h2 | h2 <;> simp_all + · intro h c hc + rw [consClauses] at hc + simp only [List.mem_flatMap] at hc + obtain ⟨ρ, -, ρ', -, i, hi, i', hi', hc⟩ := hc + rw [List.mem_range] at hi hi' + by_cases hpos : (V.positions x (BitString.toList ρ))[i]? + = (V.positions x (BitString.toList ρ'))[i']? + · rw [if_pos hpos] at hc + have heq := h ρ ρ' i i' hi hi' hpos + simp only [List.mem_cons] at hc + rcases hc with rfl | rfl | hc + · simp only [Clause.eval, List.any_cons, List.any_nil, Lit.eval, Bool.or_false, + Bool.or_eq_true, beq_iff_eq] + rw [heq] + cases Assignment.get w (varIdx t Q ρ' i') <;> simp + · simp only [Clause.eval, List.any_cons, List.any_nil, Lit.eval, Bool.or_false, + Bool.or_eq_true, beq_iff_eq] + rw [heq] + cases Assignment.get w (varIdx t Q ρ' i') <;> simp + · exact absurd hc (by simp) + · rw [if_neg hpos] at hc + exact absurd hc (by simp) + +/-! ### Semantics of the acceptance clauses -/ + +theorem tableOf_getD (t Q : ℕ) (x w : List Bool) (ρ : Fin t → Bool) {i : ℕ} + (hi : i < (V.positions x (BitString.toList ρ)).length) : + (V.tableOf t Q x w ρ).getD i false = Assignment.get w (varIdx t Q ρ i) := by + rw [List.getD_eq_getElem?_getD, V.get_varIdx t Q x w ρ hi] + rfl + +theorem eval_acceptClauses_iff {g : List Bool → Bool} + (hg : ∀ z, g z = true ↔ z ∈ V.verdict) (t Q : ℕ) (x w : List Bool) : + CNF.eval w (V.acceptClauses g t Q x) = true ↔ + ∀ ρ : Fin t → Bool, + pair (pair x (BitString.toList ρ)) (V.tableOf t Q x w ρ) ∈ V.verdict := by + classical + rw [CNF.eval, List.all_eq_true] + constructor + · intro h ρ + by_contra hrej + set L := (V.positions x (BitString.toList ρ)).length with hL + set b := V.tableOf t Q x w ρ with hb + have hblen : b.length = L := V.length_tableOf t Q x w ρ + have hmem : ((List.range L).map fun i => + (⟨!(b.getD i false), varIdx t Q ρ i⟩ : Lit)) ∈ V.acceptClauses g t Q x := by + rw [acceptClauses] + simp only [List.mem_flatMap, List.mem_map, List.mem_filter] + refine ⟨ρ, mem_coinList t ρ, b, ⟨(mem_allVecs_iff L b).2 hblen, ?_⟩, rfl⟩ + simp only [Bool.not_eq_true'] + exact Bool.eq_false_iff.2 fun hcon => hrej ((hg _).1 hcon) + have hev := h _ hmem + rw [Clause.eval, List.any_eq_true] at hev + obtain ⟨l, hlmem, hlev⟩ := hev + rw [List.mem_map] at hlmem + obtain ⟨i, hi, rfl⟩ := hlmem + rw [List.mem_range] at hi + rw [Lit.eval, beq_iff_eq] at hlev + rw [V.tableOf_getD t Q x w ρ hi] at hlev + exact absurd hlev (by cases Assignment.get w (varIdx t Q ρ i) <;> simp) + · intro h c hc + rw [acceptClauses] at hc + simp only [List.mem_flatMap, List.mem_map, List.mem_filter] at hc + obtain ⟨ρ, -, b, ⟨hbvec, hbrej⟩, rfl⟩ := hc + set L := (V.positions x (BitString.toList ρ)).length with hL + have hblen : b.length = L := (mem_allVecs_iff L b).1 hbvec + have htlen : (V.tableOf t Q x w ρ).length = L := V.length_tableOf t Q x w ρ + have hne : b ≠ V.tableOf t Q x w ρ := by + intro heq + rw [heq] at hbrej + simp only [Bool.not_eq_true'] at hbrej + exact absurd ((hg _).2 (h ρ)) (by rw [hbrej]; simp) + -- they differ somewhere + have hdiff : ∃ i, i < L ∧ b.getD i false ≠ (V.tableOf t Q x w ρ).getD i false := by + by_contra hall + push Not at hall + refine hne (List.ext_getElem (by rw [hblen, htlen]) fun i hi1 hi2 => ?_) + have hiL : i < L := by rw [← hblen]; exact hi1 + have h1 : b.getD i false = b[i] := by + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hi1] + rfl + have h2 : (V.tableOf t Q x w ρ).getD i false = (V.tableOf t Q x w ρ)[i] := by + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hi2] + rfl + rw [← h1, ← h2] + exact hall i hiL + obtain ⟨i, hi, hne'⟩ := hdiff + rw [Clause.eval, List.any_eq_true] + refine ⟨⟨!(b.getD i false), varIdx t Q ρ i⟩, ?_, ?_⟩ + · rw [List.mem_map] + exact ⟨i, List.mem_range.2 hi, rfl⟩ + · rw [Lit.eval, beq_iff_eq, V.tableOf_getD t Q x w ρ hi] at * + revert hne' + cases hbi : b.getD i false <;> cases hwi : Assignment.get w (varIdx t Q ρ i) <;> simp + +/-! ### The formula is equivalent to the witness relation -/ + +/-- **A satisfying assignment is exactly a witness.** -/ +theorem eval_toCNF_iff {g : List Bool → Bool} (hg : ∀ z, g z = true ↔ z ∈ V.verdict) + (t Q : ℕ) (x w : List Bool) : + CNF.eval w (V.toCNF g t Q x) = true ↔ V.Witness t Q x w := by + classical + rw [toCNF, CNF.eval, List.all_append, Bool.and_eq_true, ← CNF.eval, ← CNF.eval, + V.eval_consClauses_iff t Q x w, V.eval_acceptClauses_iff hg t Q x w, Witness] + constructor + · rintro ⟨hcons, hacc⟩ + refine ⟨?_, hacc⟩ + intro ρ ρ' i i' p hp hp' + have hi : i < (V.positions x (BitString.toList ρ)).length := by + by_contra hcon + rw [List.getElem?_eq_none (by omega)] at hp + exact absurd hp (by simp) + have hi' : i' < (V.positions x (BitString.toList ρ')).length := by + by_contra hcon + rw [List.getElem?_eq_none (by omega)] at hp' + exact absurd hp' (by simp) + rw [V.get_varIdx t Q x w ρ hi, V.get_varIdx t Q x w ρ' hi'] + exact congrArg some (hcons ρ ρ' i i' hi hi' (by rw [hp, hp'])) + · rintro ⟨hcons, hacc⟩ + refine ⟨?_, hacc⟩ + intro ρ ρ' i i' hi hi' hpos + have hp : (V.positions x (BitString.toList ρ))[i]? + = some ((V.positions x (BitString.toList ρ))[i]'hi) := + List.getElem?_eq_getElem hi + have hcons' := hcons ρ ρ' i i' _ hp (by rw [← hpos]; exact hp) + rw [V.get_varIdx t Q x w ρ hi, V.get_varIdx t Q x w ρ' hi'] at hcons' + exact Option.some.inj hcons' + +/-- **The formula is satisfiable exactly when a proof exists.** -/ +theorem satisfiable_toCNF_iff {g : List Bool → Bool} (hg : ∀ z, g z = true ↔ z ∈ V.verdict) + (t Q : ℕ) (x : List Bool) : + CNF.Satisfiable (V.toCNF g t Q x) ↔ ∃ w : List Bool, V.Witness t Q x w := by + constructor + · rintro ⟨α, hα⟩ + exact ⟨α, (V.eval_toCNF_iff hg t Q x α).1 hα⟩ + · rintro ⟨w, hw⟩ + exact ⟨w, (V.eval_toCNF_iff hg t Q x w).2 hw⟩ + +/-! ### The reduction, at the level of membership -/ + +/-- The query budget used for a given input: one more than the bound, so that +the stride is positive even when the verifier makes no queries. -/ +def budget (q : ℕ → ℕ) (x : List Bool) : ℕ := q x.length + 1 + +theorem budget_pos (q : ℕ → ℕ) (x : List Bool) : 0 < budget q x := Nat.succ_pos _ + +theorem length_positions_le_budget {q : ℕ → ℕ} (hq : V.QueryBounded q) (x : List Bool) + (r : List Bool) : (V.positions x r).length ≤ budget q x := + le_trans (hq x r) (Nat.le_succ _) + +/-- **The encoded formula tracks membership.** For an input on which the +verifier is either certainly accepted or accepted with probability at most a +half, the formula is satisfiable exactly when some proof is always accepted. -/ +theorem satisfiable_toCNF_iff_exists_proof {g : List Bool → Bool} + (hg : ∀ z, g z = true ↔ z ∈ V.verdict) {q : ℕ → ℕ} (hq : V.QueryBounded q) + (t : ℕ) (x : List Bool) : + CNF.Satisfiable (V.toCNF g t (budget q x) x) + ↔ ∃ π : List Bool, ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ) := by + rw [V.satisfiable_toCNF_iff hg t (budget q x) x] + exact V.exists_witness_iff x (budget_pos q x) + fun ρ => V.length_positions_le_budget hq x (BitString.toList ρ) + +/-- **The reduction is correct.** If `L` is decided by the verifier with `t` +coins in the sense of `PCP`, then membership in `L` is membership of the encoded +formula in `SAT`. -/ +theorem mem_language_toCNF_iff {L : Language} {g : List Bool → Bool} + (hg : ∀ z, g z = true ↔ z ∈ V.verdict) {q : ℕ → ℕ} {t : ℕ} (hq : V.QueryBounded q) + (hcomp : ∀ x ∈ L, ∃ π : List Bool, eventProb (V.acceptEvent t x π) = 1) + (hsound : ∀ x ∉ L, ∀ π : List Bool, eventProb (V.acceptEvent t x π) ≤ 1 / 2) + (x : List Bool) : + x ∈ L ↔ (V.toCNF g t (budget q x) x).encode ∈ SAT.language := by + constructor + · intro hx + obtain ⟨π, hπ⟩ := hcomp x hx + have hall := (V.eventProb_acceptEvent_eq_one_iff t x π).1 hπ + obtain ⟨α, hα⟩ := (V.satisfiable_toCNF_iff_exists_proof hg hq t x).2 ⟨π, hall⟩ + exact ⟨_, rfl, ⟨α, hα⟩⟩ + · rintro ⟨φ, hφenc, hφsat⟩ + by_contra hx + have hφ : φ = V.toCNF g t (budget q x) x := by + have h1 := CNF.decode?_encode φ + have h2 := CNF.decode?_encode (V.toCNF g t (budget q x) x) + rw [hφenc] at h2 + exact Option.some.inj (h1.symm.trans h2) + have hsat : CNF.Satisfiable (V.toCNF g t (budget q x) x) := hφ ▸ hφsat + obtain ⟨π, hπ⟩ := (V.satisfiable_toCNF_iff_exists_proof hg hq t x).1 hsat + have hone : eventProb (V.acceptEvent t x π) = 1 := + (V.eventProb_acceptEvent_eq_one_iff t x π).2 hπ + have hhalf := hsound x hx π + rw [hone] at hhalf + norm_num at hhalf + +end PCPVerifier + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Pad.lean b/Complexitylib/Classes/PCP/Internal/Pad.lean new file mode 100644 index 00000000..3db63624 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Pad.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph + +/-! +# Padding a constraint graph with isolated vertices + +The expander family built by the zig-zag tower supplies graphs only at certain +sizes, far apart from one another. Rather than fold a large expander onto an +arbitrary vertex count — which costs a delicate spectral argument — one can +enlarge the constraint graph instead, up to the next size the family offers. + +Nothing is lost by doing so. The added vertices carry no edges, and every +quantity the amplification tracks is counted over *edges*: the number of edges +is unchanged, an assignment matters only through its values on the original +vertices, and so both the unsatisfiability value and satisfiability are +untouched. + +## Main definitions + +- `Complexity.ConstraintGraph.pad` — the same graph on more vertices + +## Main results + +- `Complexity.ConstraintGraph.numEdges_pad`, `unsatVal_pad`, + `satisfiable_pad_iff` — padding changes nothing that matters +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α : Type} + +/-- The same constraint graph, on `N ≥ numVerts` vertices; the extra ones carry +no edges. -/ +def pad (G : ConstraintGraph α) (N : ℕ) (h : G.numVerts ≤ N) : ConstraintGraph α where + numVerts := N + numEdges := G.numEdges + tail := fun e => Fin.castLE h (G.tail e) + head := fun e => Fin.castLE h (G.head e) + rel := G.rel + +@[simp] theorem numEdges_pad (G : ConstraintGraph α) (N : ℕ) (h : G.numVerts ≤ N) : + (G.pad N h).numEdges = G.numEdges := rfl + +@[simp] theorem numVerts_pad (G : ConstraintGraph α) (N : ℕ) (h : G.numVerts ≤ N) : + (G.pad N h).numVerts = N := rfl + +/-- Restricting an assignment of the padded graph to the original vertices. -/ +def restrict (G : ConstraintGraph α) {N : ℕ} (h : G.numVerts ≤ N) + (a : (G.pad N h).Assignment) : G.Assignment := + fun v => a (Fin.castLE h v) + +/-- Extending an assignment to the padded graph, arbitrarily on the new +vertices. -/ +noncomputable def extend [Nonempty α] (G : ConstraintGraph α) {N : ℕ} + (h : G.numVerts ≤ N) (a : G.Assignment) : (G.pad N h).Assignment := + fun v => if hv : v.val < G.numVerts then a ⟨v.val, hv⟩ else Classical.arbitrary α + +theorem restrict_extend [Nonempty α] (G : ConstraintGraph α) {N : ℕ} (h : G.numVerts ≤ N) + (a : G.Assignment) : G.restrict h (G.extend h a) = a := by + funext v + rw [restrict, extend] + simp only [Fin.val_castLE, dif_pos v.isLt] + +theorem satisfies_pad_iff (G : ConstraintGraph α) {N : ℕ} (h : G.numVerts ≤ N) + (a : (G.pad N h).Assignment) (e : Fin (G.pad N h).numEdges) : + (G.pad N h).Satisfies a e ↔ G.Satisfies (G.restrict h a) e := Iff.rfl + +theorem unsatEdges_pad (G : ConstraintGraph α) {N : ℕ} (h : G.numVerts ≤ N) + (a : (G.pad N h).Assignment) : + (G.pad N h).unsatEdges a = G.unsatEdges (G.restrict h a) := rfl + +theorem unsatFrac_pad (G : ConstraintGraph α) {N : ℕ} (h : G.numVerts ≤ N) + (a : (G.pad N h).Assignment) : + (G.pad N h).unsatFrac a = G.unsatFrac (G.restrict h a) := rfl + +/-- **Padding does not change the value.** -/ +theorem unsatVal_pad [Fintype α] [Nonempty α] [DecidableEq α] (G : ConstraintGraph α) + (N : ℕ) (h : G.numVerts ≤ N) : + (G.pad N h).unsatVal = G.unsatVal := by + classical + refine le_antisymm (Finset.le_inf' _ _ fun b _ => ?_) (Finset.le_inf' _ _ fun a _ => ?_) + · have hle := Finset.inf'_le (G.pad N h).unsatFrac (Finset.mem_univ (G.extend h b)) + rw [unsatFrac_pad, restrict_extend] at hle + exact hle + · rw [unsatFrac_pad] + exact Finset.inf'_le G.unsatFrac (Finset.mem_univ _) + +/-- **Padding does not change satisfiability.** -/ +theorem satisfiable_pad_iff [Nonempty α] (G : ConstraintGraph α) (N : ℕ) + (h : G.numVerts ≤ N) : + (G.pad N h).Satisfiable ↔ G.Satisfiable := by + constructor + · rintro ⟨a, ha⟩ + exact ⟨G.restrict h a, fun e => (G.satisfies_pad_iff h a e).1 (ha e)⟩ + · rintro ⟨b, hb⟩ + refine ⟨G.extend h b, fun e => ?_⟩ + rw [satisfies_pad_iff, restrict_extend] + exact hb e + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PadCSP.lean b/Complexitylib/Classes/PCP/Internal/PadCSP.lean new file mode 100644 index 00000000..cfcb8781 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PadCSP.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PadVerts +public import Complexitylib.Classes.PCP.Internal.RegCSP + +/-! +# Padding a constraint system + +`PadVerts` enlarges a regular graph; here the constraints come along. The fresh +vertices carry self-loops, and those loops are given the trivial constraint, so +they are satisfied by every assignment and never contribute an unsatisfied dart. + +Nothing is lost except dilution: the unsatisfied darts are exactly the old ones, +while the total number of darts grows in proportion to the number of vertices. +The unsatisfiability value is therefore scaled by the ratio of the old vertex +count to the new — a constant factor, since padding is only ever to within a +constant multiple. + +## Main definitions + +- `Complexity.RegCSP.padVerts` — the padded constraint system + +## Main results + +- `Complexity.RegCSP.card_unsatDarts_padVerts` — the unsatisfied darts are the + old ones +- `Complexity.RegCSP.satisfiable_padVerts_iff` — satisfiability is unchanged +- `Complexity.RegCSP.unsatVal_padVerts_ge` — the value is diluted by exactly the + ratio of the vertex counts +-/ + +@[expose] public section + +namespace Complexity + +namespace RegCSP + +variable {α : Type} + +/-- The padded constraint system: fresh vertices, whose self-loops carry the +constraint that is always satisfied. -/ +def padVerts (R : RegCSP α) (k : ℕ) : RegCSP α where + graph := R.graph.padVerts k + rel := fun v i x y => + match v with + | Sum.inl w => R.rel w i x y + | Sum.inr _ => true + +@[simp] theorem graph_padVerts (R : RegCSP α) (k : ℕ) : + (R.padVerts k).graph = R.graph.padVerts k := rfl + +/-- Restricting an assignment of the padded system to the original vertices. -/ +def unpad (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) : R.Assignment := + fun v => a (Sum.inl v) + +/-- Extending an assignment to the padded system. -/ +noncomputable def repad [Nonempty α] (R : RegCSP α) {k : ℕ} (a : R.Assignment) : + (R.padVerts k).Assignment := + fun v => + match v with + | Sum.inl w => a w + | Sum.inr _ => Classical.arbitrary α + +theorem unpad_repad [Nonempty α] (R : RegCSP α) {k : ℕ} (a : R.Assignment) : + R.unpad (R.repad (k := k) a) = a := rfl + +theorem satisfies_padVerts_inl (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) + (v : R.graph.V) (i : R.graph.D) : + (R.padVerts k).Satisfies a (Sum.inl v, i) ↔ R.Satisfies (R.unpad a) (v, i) := Iff.rfl + +theorem satisfies_padVerts_inr (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) + (j : Fin k) (i : R.graph.D) : (R.padVerts k).Satisfies a (Sum.inr j, i) := rfl + +/-- **The unsatisfied darts are exactly the old ones.** -/ +theorem unsatDarts_padVerts (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) : + (R.padVerts k).unsatDarts a + = (R.unsatDarts (R.unpad a)).image fun p => (Sum.inl p.1, p.2) := by + classical + ext p + constructor + · intro hp + rw [mem_unsatDarts] at hp + obtain ⟨v | j, i⟩ := p + · exact Finset.mem_image.2 ⟨(v, i), (mem_unsatDarts R).2 hp, rfl⟩ + · exact absurd (R.satisfies_padVerts_inr a j i) hp + · intro hp + obtain ⟨⟨w, i'⟩, hw, heq⟩ := Finset.mem_image.1 hp + rw [← heq, mem_unsatDarts] + rw [mem_unsatDarts] at hw + exact hw + +theorem card_unsatDarts_padVerts (R : RegCSP α) {k : ℕ} + (a : (R.padVerts k).Assignment) : + ((R.padVerts k).unsatDarts a).card = (R.unsatDarts (R.unpad a)).card := by + classical + have hinj : Function.Injective + (fun p : R.Dart => ((Sum.inl p.1, p.2) : (R.padVerts k).Dart)) := by + intro p q h + simp only [Prod.mk.injEq] at h + exact Prod.ext (by injection h.1) h.2 + rw [unsatDarts_padVerts] + exact Finset.card_image_of_injective _ hinj + +/-- **Satisfiability is unchanged.** -/ +theorem satisfiable_padVerts_iff [Nonempty α] (R : RegCSP α) (k : ℕ) : + (R.padVerts k).Satisfiable ↔ R.Satisfiable := by + constructor + · rintro ⟨a, ha⟩ + refine ⟨R.unpad a, fun p => ?_⟩ + obtain ⟨v, i⟩ := p + exact (R.satisfies_padVerts_inl a v i).1 (ha (Sum.inl v, i)) + · rintro ⟨b, hb⟩ + refine ⟨R.repad b, fun p => ?_⟩ + obtain ⟨v | j, i⟩ := p + · rw [satisfies_padVerts_inl, unpad_repad] + exact hb (v, i) + · exact R.satisfies_padVerts_inr _ j i + +/-! ### The dilution -/ + +theorem unsatFrac_padVerts (R : RegCSP α) (k : ℕ) (a : (R.padVerts k).Assignment) : + (R.padVerts k).unsatFrac a + = ((R.unsatDarts (R.unpad a)).card : ℚ) + / (((R.graph.order + k) * R.graph.deg : ℕ) : ℚ) := by + rw [unsatFrac, card_unsatDarts_padVerts] + congr 2 + rw [graph_padVerts, RegGraph.order_padVerts, RegGraph.deg_padVerts] + +/-- **Padding dilutes the value by the ratio of the vertex counts.** -/ +theorem unsatVal_padVerts_ge [Fintype α] [Nonempty α] [DecidableEq α] + (R : RegCSP α) (k : ℕ) (hord : 0 < R.graph.order) : + R.unsatVal * ((R.graph.order : ℕ) : ℚ) / (((R.graph.order + k : ℕ)) : ℚ) + ≤ (R.padVerts k).unsatVal := by + classical + have hd : (0 : ℚ) < (R.graph.deg : ℕ) := by + have := R.graph.deg_pos + exact_mod_cast this + have ho : (0 : ℚ) < (R.graph.order : ℕ) := by exact_mod_cast hord + have hok : (0 : ℚ) < ((R.graph.order + k : ℕ) : ℚ) := by + have : 0 < R.graph.order + k := by omega + exact_mod_cast this + have hod : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by + have : 0 < R.graph.order * R.graph.deg := Nat.mul_pos hord R.graph.deg_pos + exact_mod_cast this + have hokd : (0 : ℚ) < (((R.graph.order + k) * R.graph.deg : ℕ) : ℚ) := by + have : 0 < (R.graph.order + k) * R.graph.deg := + Nat.mul_pos (by omega) R.graph.deg_pos + exact_mod_cast this + refine Finset.le_inf' _ _ fun a _ => ?_ + have hle : R.unsatVal ≤ R.unsatFrac (R.unpad a) := R.unsatVal_le _ + rw [unsatFrac] at hle + rw [le_div_iff₀ hod] at hle + rw [unsatFrac_padVerts, div_le_div_iff₀ hok hokd] + push_cast at hle ⊢ + nlinarith [hle, hd, ho, hok] + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PadGraph.lean b/Complexitylib/Classes/PCP/Internal/PadGraph.lean new file mode 100644 index 00000000..5cec05c9 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PadGraph.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph + +/-! +# Padding a constraint graph + +A `PCP` verifier tosses a number of coins that depends on the input's *length* +alone, and it uses them to pick an edge. So the graph it reads must have a +number of edges that depends on the length alone — which the graph of a formula +does not. + +Padding fixes that: extra self-loops at vertex `0`, each carrying the constraint +that is always true. They change nothing about satisfiability, and they let the +edge count be pushed up to any size a length determines. + +## Main definitions + +- `Complexity.ConstraintGraph.padGraph` — the graph with extra trivial edges + +## Main results + +- `Complexity.ConstraintGraph.satisfiable_padGraph_iff` — padding preserves + satisfiability +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α : Type} + +/-- `G` with trivial self-loops added until it has at least `n` edges. -/ +def padGraph (G : ConstraintGraph α) (hv : 0 < G.numVerts) (n : ℕ) : ConstraintGraph α where + numVerts := G.numVerts + numEdges := max n G.numEdges + tail e := if h : e.val < G.numEdges then G.tail ⟨e.val, h⟩ else ⟨0, hv⟩ + head e := if h : e.val < G.numEdges then G.head ⟨e.val, h⟩ else ⟨0, hv⟩ + rel e := if h : e.val < G.numEdges then G.rel ⟨e.val, h⟩ else fun _ _ => true + +variable {G : ConstraintGraph α} {hv : 0 < G.numVerts} {n : ℕ} + +@[simp] theorem numVerts_padGraph : (G.padGraph hv n).numVerts = G.numVerts := rfl + +@[simp] theorem numEdges_padGraph : (G.padGraph hv n).numEdges = max n G.numEdges := rfl + +theorem tail_padGraph_of_lt {e : ℕ} (he : e < (G.padGraph hv n).numEdges) + (h : e < G.numEdges) : + ((G.padGraph hv n).tail ⟨e, he⟩).val = (G.tail ⟨e, h⟩).val := by + show (dite _ _ _ : Fin G.numVerts).val = _ + rw [dif_pos h] + +theorem head_padGraph_of_lt {e : ℕ} (he : e < (G.padGraph hv n).numEdges) + (h : e < G.numEdges) : + ((G.padGraph hv n).head ⟨e, he⟩).val = (G.head ⟨e, h⟩).val := by + show (dite _ _ _ : Fin G.numVerts).val = _ + rw [dif_pos h] + +theorem rel_padGraph_of_lt {e : ℕ} (he : e < (G.padGraph hv n).numEdges) + (h : e < G.numEdges) : + (G.padGraph hv n).rel ⟨e, he⟩ = G.rel ⟨e, h⟩ := by + show (dite _ _ _ : α → α → Bool) = _ + rw [dif_pos h] + +theorem tail_padGraph_of_ge {e : ℕ} (he : e < (G.padGraph hv n).numEdges) + (h : ¬ e < G.numEdges) : ((G.padGraph hv n).tail ⟨e, he⟩).val = 0 := by + show (dite _ _ _ : Fin G.numVerts).val = _ + rw [dif_neg h] + +theorem head_padGraph_of_ge {e : ℕ} (he : e < (G.padGraph hv n).numEdges) + (h : ¬ e < G.numEdges) : ((G.padGraph hv n).head ⟨e, he⟩).val = 0 := by + show (dite _ _ _ : Fin G.numVerts).val = _ + rw [dif_neg h] + +theorem rel_padGraph_of_ge {e : ℕ} (he : e < (G.padGraph hv n).numEdges) + (h : ¬ e < G.numEdges) : + (G.padGraph hv n).rel ⟨e, he⟩ = fun _ _ => true := by + show (dite _ _ _ : α → α → Bool) = _ + rw [dif_neg h] + +/-- The padded graph has the same assignments. -/ +theorem assignment_padGraph : (G.padGraph hv n).Assignment = G.Assignment := rfl + +/-- **Padding preserves satisfiability.** -/ +theorem satisfiable_padGraph_iff : (G.padGraph hv n).Satisfiable ↔ G.Satisfiable := by + constructor + · rintro ⟨a, ha⟩ + refine ⟨a, fun e => ?_⟩ + have hlt : e.val < (G.padGraph hv n).numEdges := + lt_of_lt_of_le e.isLt (le_max_right _ _) + have h := ha ⟨e.val, hlt⟩ + rw [Satisfies, satisfies] at h ⊢ + rw [rel_padGraph_of_lt hlt e.isLt] at h + rw [show (⟨e.val, e.isLt⟩ : Fin G.numEdges) = e from rfl] at h + rw [← h] + congr 1 + · exact congrArg a (Fin.ext (tail_padGraph_of_lt hlt e.isLt)).symm + · exact congrArg a (Fin.ext (head_padGraph_of_lt hlt e.isLt)).symm + · rintro ⟨a, ha⟩ + refine ⟨a, fun e => ?_⟩ + rw [Satisfies, satisfies] + by_cases h : e.val < G.numEdges + · have hb := ha ⟨e.val, h⟩ + rw [Satisfies, satisfies] at hb + rw [rel_padGraph_of_lt e.isLt h] + rw [show a ((G.padGraph hv n).tail e) = a (G.tail ⟨e.val, h⟩) from + congrArg a (Fin.ext (tail_padGraph_of_lt e.isLt h)), + show a ((G.padGraph hv n).head e) = a (G.head ⟨e.val, h⟩) from + congrArg a (Fin.ext (head_padGraph_of_lt e.isLt h))] + exact hb + · rw [rel_padGraph_of_ge e.isLt h] + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PadVerts.lean b/Complexitylib/Classes/PCP/Internal/PadVerts.lean new file mode 100644 index 00000000..85860881 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PadVerts.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.RegularGraph + +/-! +# Padding a regular graph with fresh vertices + +`SizedExpander` supplies an expander of approximately, not exactly, a requested +size, so the graph it is to be superposed on must first be brought up to the +expander's size. A regular graph cannot simply gain isolated vertices — that +would break regularity — so the fresh vertices carry self-loops instead, one per +label. + +The padded graph is disconnected and so has no spectral gap of its own; that is +of no concern, because expanderization takes the gap from the expander it +superposes, not from the graph underneath. + +## Main definitions + +- `Complexity.RegGraph.padVerts` — the graph on a prescribed larger vertex set + +## Main results + +- `Complexity.RegGraph.order_padVerts`, `Complexity.RegGraph.deg_padVerts` +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-- The rotation map of the padded graph: the old darts as before, and a +self-loop at each fresh vertex. -/ +def padRot (k : ℕ) : (G.V ⊕ Fin k) × G.D → (G.V ⊕ Fin k) × G.D + | (Sum.inl v, i) => (Sum.inl (G.rot (v, i)).1, (G.rot (v, i)).2) + | (Sum.inr j, i) => (Sum.inr j, i) + +theorem padRot_involutive (k : ℕ) : Function.Involutive (G.padRot k) := by + intro p + obtain ⟨v | j, i⟩ := p + · show G.padRot k (Sum.inl (G.rot (v, i)).1, (G.rot (v, i)).2) = _ + rw [padRot] + have h := G.rot_involutive (v, i) + simp only [Prod.mk.injEq] + constructor + · exact congrArg (fun p => Sum.inl p.1) h + · exact congrArg (fun p => p.2) h + · rfl + +/-- **The graph with `k` fresh looped vertices added.** -/ +def padVerts (k : ℕ) : RegGraph where + V := G.V ⊕ Fin k + D := G.D + decEqV := by + haveI := G.decEqV + exact inferInstance + decEqD := G.decEqD + fintypeV := by + haveI := G.fintypeV + exact inferInstance + fintypeD := G.fintypeD + nonemptyD := G.nonemptyD + rot := G.padRot k + rot_involutive := G.padRot_involutive k + +@[simp] theorem deg_padVerts (k : ℕ) : (G.padVerts k).deg = G.deg := rfl + +@[simp] theorem order_padVerts (k : ℕ) : (G.padVerts k).order = G.order + k := by + show Fintype.card (G.V ⊕ Fin k) = Fintype.card G.V + k + rw [Fintype.card_sum, Fintype.card_fin] + +/-- Padding to a prescribed size. -/ +def padTo (N : ℕ) : RegGraph := G.padVerts (N - G.order) + +@[simp] theorem deg_padTo (N : ℕ) : (G.padTo N).deg = G.deg := rfl + +theorem order_padTo {N : ℕ} (h : G.order ≤ N) : (G.padTo N).order = N := by + rw [padTo, order_padVerts] + omega + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PermArith.lean b/Complexitylib/Classes/PCP/Internal/PermArith.lean new file mode 100644 index 00000000..cb94c9ae --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PermArith.lean @@ -0,0 +1,256 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Data.Nat.Choose.Bounds +public import Mathlib.Data.Nat.Factorial.BigOperators +public import Mathlib.Analysis.Complex.ExponentialBounds +public import Mathlib.Tactic + +/-! +# Arithmetic for the expander counting bound + +Four elementary estimates, all in `ℕ`, which together turn the permutation +count of `PermCount` into a bound small enough to survive a union bound over +all vertex sets. + +* A single binomial term is at most the whole binomial sum: `C(s,t) 2^{s-t} ≤ 3^s`. +* Descending factorials compare like powers: `descFactorial s k · n^k ≤ s^k · + descFactorial n k` when `s ≤ n` — this is `(s/n)^k` in disguise, and it is + where the smallness of a set of at most half the vertices enters. +* `descFactorial n k · (n-k)! = n!`, so the count is a fraction of `n!`. +* `C(n,s) s^s ≤ 3^s n^s`, the usual `(e n / s)^s` bound with `e` replaced by + the integer `3`. Its one analytic ingredient is `(1 + 1/m)^m ≤ e < 3`. + +## Main results + +- `Complexity.choose_mul_two_pow_le` +- `Complexity.descFactorial_mul_pow_le` +- `Complexity.descFactorial_mul_factorial_sub` +- `Complexity.choose_mul_pow_self_le` +-/ + +@[expose] public section + +namespace Complexity + +open Finset + +/-- **One term of a binomial sum.** -/ +theorem choose_mul_two_pow_le (s t : ℕ) (ht : t ≤ s) : + s.choose t * 2 ^ (s - t) ≤ 3 ^ s := by + have hexp : (3 : ℕ) ^ s = ∑ k ∈ range (s + 1), 1 ^ k * 2 ^ (s - k) * s.choose k := by + have := add_pow (1 : ℕ) 2 s + norm_num at this ⊢ + exact this + rw [hexp] + have hmem : t ∈ range (s + 1) := Finset.mem_range.2 (by omega) + calc s.choose t * 2 ^ (s - t) = 1 ^ t * 2 ^ (s - t) * s.choose t := by ring + _ ≤ _ := Finset.single_le_sum + (f := fun k => 1 ^ k * 2 ^ (s - k) * s.choose k) (fun k _ => Nat.zero_le _) hmem + +/-- **Descending factorials compare like powers.** -/ +theorem descFactorial_mul_pow_le {s n : ℕ} (hsn : s ≤ n) (k : ℕ) : + s.descFactorial k * n ^ k ≤ s ^ k * n.descFactorial k := by + have hn : n ^ k = ∏ _i ∈ range k, n := by simp + have hs : s ^ k = ∏ _i ∈ range k, s := by simp + rw [Nat.descFactorial_eq_prod_range, Nat.descFactorial_eq_prod_range, hn, hs, + ← Finset.prod_mul_distrib, ← Finset.prod_mul_distrib] + refine Finset.prod_le_prod' fun i _ => ?_ + have h : (s - i) * n ≤ s * (n - i) := by + rcases le_or_gt i s with hi | hi + · have h1 : (s - i) * n = s * n - i * n := by + rw [Nat.sub_mul] + have h2 : s * (n - i) = s * n - s * i := by + rw [Nat.mul_sub] + rw [h1, h2] + have : s * i ≤ i * n := by + rw [mul_comm] + exact Nat.mul_le_mul_left _ hsn + omega + · have : s - i = 0 := by omega + rw [this, zero_mul] + exact Nat.zero_le _ + exact h + +/-- **The descending factorial is a fraction of the factorial.** -/ +theorem descFactorial_mul_factorial_sub {n k : ℕ} (hk : k ≤ n) : + n.descFactorial k * Nat.factorial (n - k) = Nat.factorial n := by + rw [Nat.descFactorial_eq_factorial_mul_choose] + calc Nat.factorial k * n.choose k * Nat.factorial (n - k) + = n.choose k * Nat.factorial k * Nat.factorial (n - k) := by ring + _ = Nat.factorial n := Nat.choose_mul_factorial_mul_factorial hk + +/-! ### The `(3 n / s)^s` bound -/ + +private theorem succ_pow_le_three_mul (m : ℕ) : ((m : ℝ) + 1) ^ m ≤ 3 * (m : ℝ) ^ m := by + rcases Nat.eq_zero_or_pos m with rfl | hm + · norm_num + have hm0 : (0 : ℝ) < m := by exact_mod_cast hm + have h1 : (1 : ℝ) + 1 / m ≤ Real.exp (1 / m) := by + have := Real.add_one_le_exp (1 / (m : ℝ)) + linarith + have h2 : ((1 : ℝ) + 1 / m) ^ m ≤ Real.exp 1 := by + calc ((1 : ℝ) + 1 / m) ^ m ≤ (Real.exp (1 / m)) ^ m := + pow_le_pow_left₀ (by positivity) h1 m + _ = Real.exp ((m : ℝ) * (1 / m)) := by + rw [← Real.exp_nat_mul] + _ = Real.exp 1 := by + rw [mul_one_div, div_self (ne_of_gt hm0)] + have h3 : Real.exp 1 < 3 := by + have := Real.exp_one_lt_d9 + linarith + have hfac : ((m : ℝ) + 1) ^ m = (m : ℝ) ^ m * ((1 : ℝ) + 1 / m) ^ m := by + rw [← mul_pow] + congr 1 + field_simp + rw [hfac] + have hmm : (0 : ℝ) ≤ (m : ℝ) ^ m := by positivity + nlinarith [h2, h3, hmm] + +/-- **`s^s ≤ 3^s s!`**, the integer form of `s! ≥ (s/e)^s`. -/ +theorem pow_self_le_three_pow_mul_factorial (s : ℕ) : + s ^ s ≤ 3 ^ s * Nat.factorial s := by + induction s with + | zero => simp + | succ m ih => + have hstep : (m + 1) ^ m ≤ 3 * m ^ m := by + have := succ_pow_le_three_mul m + exact_mod_cast this + calc (m + 1) ^ (m + 1) = (m + 1) * (m + 1) ^ m := by ring + _ ≤ (m + 1) * (3 * m ^ m) := Nat.mul_le_mul_left _ hstep + _ ≤ (m + 1) * (3 * (3 ^ m * Nat.factorial m)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul_left _ ih) + _ = 3 ^ (m + 1) * Nat.factorial (m + 1) := by + rw [Nat.factorial_succ, pow_succ] + ring + +/-- **The `(3 n / s)^s` bound on a binomial coefficient.** -/ +theorem choose_mul_pow_self_le (n s : ℕ) : n.choose s * s ^ s ≤ 3 ^ s * n ^ s := by + calc n.choose s * s ^ s ≤ n.choose s * (3 ^ s * Nat.factorial s) := + Nat.mul_le_mul_left _ (pow_self_le_three_pow_mul_factorial s) + _ = 3 ^ s * (Nat.factorial s * n.choose s) := by ring + _ = 3 ^ s * n.descFactorial s := by rw [Nat.descFactorial_eq_factorial_mul_choose] + _ ≤ 3 ^ s * n ^ s := Nat.mul_le_mul_left _ (Nat.descFactorial_le_pow n s) + +/-! ### The per-set estimate -/ + +/-- The numeric heart: `2^{2s} 3^{31s} ≤ 2^{60k}` whenever `9 s ≤ 10 k`. -/ +theorem two_pow_three_pow_le {s k : ℕ} (h9 : 9 * s ≤ 10 * k) : + 2 ^ (2 * s) * 3 ^ (31 * s) ≤ 2 ^ (60 * k) := by + have hbase : (2 : ℕ) ^ 20 * 3 ^ 310 ≤ 2 ^ 540 := by + have hb1 : (3 : ℕ) ^ 31 ≤ 2 ^ 52 := by norm_num + have hb2 : (3 : ℕ) ^ 310 ≤ 2 ^ 520 := by + calc (3 : ℕ) ^ 310 = ((3 : ℕ) ^ 31) ^ 10 := by rw [← pow_mul] + _ ≤ ((2 : ℕ) ^ 52) ^ 10 := Nat.pow_le_pow_left hb1 10 + _ = 2 ^ 520 := by rw [← pow_mul] + calc (2 : ℕ) ^ 20 * 3 ^ 310 ≤ 2 ^ 20 * 2 ^ 520 := Nat.mul_le_mul_left _ hb2 + _ = 2 ^ 540 := by rw [← pow_add] + have hL : ((2 : ℕ) ^ (2 * s) * 3 ^ (31 * s)) ^ 10 = ((2 : ℕ) ^ 20 * 3 ^ 310) ^ s := by + rw [mul_pow, mul_pow, ← pow_mul, ← pow_mul, ← pow_mul, ← pow_mul] + congr 2 <;> ring + have hR : (((2 : ℕ) ^ (60 * k)) ^ 10) = 2 ^ (600 * k) := by + rw [← pow_mul] + congr 1 + ring + have hstep : ((2 : ℕ) ^ 20 * 3 ^ 310) ^ s ≤ ((2 : ℕ) ^ 540) ^ s := + Nat.pow_le_pow_left hbase s + have hR2 : ((2 : ℕ) ^ 540) ^ s ≤ 2 ^ (600 * k) := by + rw [← pow_mul] + exact Nat.pow_le_pow_right (by norm_num) (by omega) + have hfin : ((2 : ℕ) ^ (2 * s) * 3 ^ (31 * s)) ^ 10 ≤ ((2 : ℕ) ^ (60 * k)) ^ 10 := by + rw [hL, hR] + exact le_trans hstep hR2 + exact (Nat.pow_le_pow_iff_left (by norm_num)).1 hfin + +/-- **The estimate for one vertex set**, with the permutation count abstracted. +The hypothesis is what `PermCount` supplies, in the form `descFactorial` and +`choose` bounds put it; the conclusion leaves a factor `2^s` of room for the +union bound over all sets of size `s`. -/ +theorem key_estimate {n s k B : ℕ} (hs : 1 ≤ s) (hsn : 2 * s ≤ n) (h9 : 9 * s ≤ 10 * k) + (hB : B * 2 ^ k * n ^ k ≤ 3 ^ s * s ^ k * Nat.factorial n) : + 2 ^ s * (n.choose s * B ^ 30) ≤ Nat.factorial n ^ 30 := by + have hks : s ≤ k * 30 := by omega + have hn0 : 0 < n := by omega + obtain ⟨m, hm⟩ : ∃ m, k * 30 = s + m := ⟨k * 30 - s, by omega⟩ + have hsspos : 0 < s ^ s := pow_pos (by omega) s + have hnum := two_pow_three_pow_le h9 + have h2 : 2 ^ s * n.choose s * 3 ^ (s * 30) * s ^ (k * 30) ≤ (2 * n) ^ (k * 30) := by + refine Nat.le_of_mul_le_mul_right ?_ hsspos + have hD : n.choose s * s ^ s ≤ 3 ^ s * n ^ s := choose_mul_pow_self_le n s + have hcancel : 2 ^ s * 3 ^ (31 * s) ≤ 2 ^ (30 * k + m) := by + refine Nat.le_of_mul_le_mul_left ?_ (show 0 < 2 ^ s by positivity) + have hLl : 2 ^ s * (2 ^ s * 3 ^ (31 * s)) = 2 ^ (2 * s) * 3 ^ (31 * s) := by + rw [← mul_assoc, ← pow_add] + congr 2 + omega + have hRr : 2 ^ s * 2 ^ (30 * k + m) = 2 ^ (60 * k) := by + rw [← pow_add] + congr 1 + omega + rw [hLl, hRr] + exact hnum + have hsm : 2 ^ s * 3 ^ (31 * s) * s ^ m ≤ 2 ^ (30 * k) * n ^ m := by + calc 2 ^ s * 3 ^ (31 * s) * s ^ m ≤ 2 ^ (30 * k + m) * s ^ m := + Nat.mul_le_mul_right _ hcancel + _ = 2 ^ (30 * k) * (2 ^ m * s ^ m) := by rw [pow_add]; ring + _ = 2 ^ (30 * k) * (2 * s) ^ m := by rw [mul_pow] + _ ≤ 2 ^ (30 * k) * n ^ m := Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hsn m) + have hsk : s ^ (k * 30) = s ^ s * s ^ m := by rw [hm, pow_add] + have hnk : (2 * n) ^ (k * 30) = 2 ^ (30 * k) * (n ^ s * n ^ m) := by + have e1 : (2 : ℕ) ^ (k * 30) = 2 ^ (30 * k) := by congr 1; ring + rw [mul_pow, e1, hm, pow_add] + have h3 : (3 : ℕ) ^ (s * 30) * 3 ^ s = 3 ^ (31 * s) := by + rw [← pow_add] + congr 1 + ring + calc 2 ^ s * n.choose s * 3 ^ (s * 30) * s ^ (k * 30) * s ^ s + = (2 ^ s * 3 ^ (s * 30) * s ^ (k * 30)) * (n.choose s * s ^ s) := by ring + _ ≤ (2 ^ s * 3 ^ (s * 30) * s ^ (k * 30)) * (3 ^ s * n ^ s) := + Nat.mul_le_mul_left _ hD + _ = (2 ^ s * (3 ^ (s * 30) * 3 ^ s) * s ^ m) * (s ^ s * n ^ s) := by + rw [hsk]; ring + _ = (2 ^ s * 3 ^ (31 * s) * s ^ m) * (s ^ s * n ^ s) := by rw [h3] + _ ≤ (2 ^ (30 * k) * n ^ m) * (s ^ s * n ^ s) := Nat.mul_le_mul_right _ hsm + _ = (2 * n) ^ (k * 30) * s ^ s := by rw [hnk]; ring + have h1' : B ^ 30 * (2 * n) ^ (k * 30) + ≤ 3 ^ (s * 30) * s ^ (k * 30) * Nat.factorial n ^ 30 := by + have hpow := Nat.pow_le_pow_left hB 30 + have hBpow : B ^ 30 * (2 * n) ^ (k * 30) = (B * 2 ^ k * n ^ k) ^ 30 := by + simp only [mul_pow, ← pow_mul] + ring + have hRpow : (3 ^ s * s ^ k * Nat.factorial n) ^ 30 + = 3 ^ (s * 30) * s ^ (k * 30) * Nat.factorial n ^ 30 := by + simp only [mul_pow, ← pow_mul] + rw [hBpow, ← hRpow] + exact hpow + have hpos : 0 < (2 * n) ^ (k * 30) := pow_pos (by omega) _ + refine Nat.le_of_mul_le_mul_right ?_ hpos + calc 2 ^ s * (n.choose s * B ^ 30) * (2 * n) ^ (k * 30) + = (2 ^ s * n.choose s) * (B ^ 30 * (2 * n) ^ (k * 30)) := by ring + _ ≤ (2 ^ s * n.choose s) * (3 ^ (s * 30) * s ^ (k * 30) * Nat.factorial n ^ 30) := + Nat.mul_le_mul_left _ h1' + _ = (2 ^ s * n.choose s * 3 ^ (s * 30) * s ^ (k * 30)) * Nat.factorial n ^ 30 := by ring + _ ≤ (2 * n) ^ (k * 30) * Nat.factorial n ^ 30 := Nat.mul_le_mul_right _ h2 + _ = Nat.factorial n ^ 30 * (2 * n) ^ (k * 30) := by ring + +/-- **The counting hypothesis of `key_estimate`,** as `PermCount` produces it. -/ +theorem count_bound {n s t : ℕ} (hsn : s ≤ n) (hts : t ≤ s) (hkn : s - t ≤ n) : + (s.choose t * s.descFactorial (s - t) * Nat.factorial (n - (s - t))) * 2 ^ (s - t) * n ^ (s - t) + ≤ 3 ^ s * s ^ (s - t) * Nat.factorial n := by + set k := s - t with hk + have hA : s.choose t * 2 ^ k ≤ 3 ^ s := choose_mul_two_pow_le s t hts + have hBb : s.descFactorial k * n ^ k ≤ s ^ k * n.descFactorial k := + descFactorial_mul_pow_le hsn k + have hC : n.descFactorial k * Nat.factorial (n - k) = Nat.factorial n := + descFactorial_mul_factorial_sub hkn + calc (s.choose t * s.descFactorial k * Nat.factorial (n - k)) * 2 ^ k * n ^ k + = (s.choose t * 2 ^ k) * (s.descFactorial k * n ^ k) * Nat.factorial (n - k) := by ring + _ ≤ 3 ^ s * (s ^ k * n.descFactorial k) * Nat.factorial (n - k) := + Nat.mul_le_mul_right _ (Nat.mul_le_mul hA hBb) + _ = 3 ^ s * s ^ k * (n.descFactorial k * Nat.factorial (n - k)) := by ring + _ = 3 ^ s * s ^ k * Nat.factorial n := by rw [hC] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PermCount.lean b/Complexitylib/Classes/PCP/Internal/PermCount.lean new file mode 100644 index 00000000..74ae64dd --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PermCount.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Combinatorics.Enumerative.DoubleCounting +public import Mathlib.Data.Fintype.CardEmbedding +public import Mathlib.Data.Nat.Choose.Bounds +public import Mathlib.Tactic + +/-! +# Counting permutations that keep a set inside a set + +The expander existence proof needs one combinatorial estimate: of the `n!` +permutations of `Fin n`, at most `descFactorial s k · (n - k)!` map a given +`k`-element set inside a given `s`-element set. + +The proof is the obvious one, made precise. Restricting a permutation to `K` +gives an injection into `S`; there are `descFactorial s k` of those. Two +permutations with the same restriction differ only outside `K`, where they are +injections from an `(n - k)`-set into the complement of the common image — +another `(n - k)`-set — so each restriction is shared by at most `(n - k)!` +permutations. + +## Main results + +- `Complexity.card_perm_mapsTo_le` — the estimate +- `Complexity.card_perm_escape_le` — its consequence for the escape count: + few permutations move only a small part of `S` out of `S` +-/ + +@[expose] public section + +namespace Complexity + +open Finset + +variable {n : ℕ} + +/-- How many points of `S` the permutation `σ` sends outside `S`. -/ +noncomputable def escape (σ : Equiv.Perm (Fin n)) (S : Finset (Fin n)) : ℕ := + (S.filter fun v => σ v ∉ S).card + +/-! ### Restrictions of a permutation -/ + +/-- The permutations mapping `K` into `S`. -/ +noncomputable def permsInto (S K : Finset (Fin n)) : Finset (Equiv.Perm (Fin n)) := + Finset.univ.filter fun σ => ∀ v ∈ K, σ v ∈ S + +/-- The restrictions that can occur: injective maps of `K` into `S`. -/ +noncomputable def restrs (S K : Finset (Fin n)) : Finset ({x // x ∈ K} → Fin n) := + Finset.univ.filter fun f => Function.Injective f ∧ ∀ v, f v ∈ S + +theorem mem_restrs {S K : Finset (Fin n)} {f : {x // x ∈ K} → Fin n} (hf : f ∈ restrs S K) : + Function.Injective f ∧ ∀ v, f v ∈ S := by + have := hf + rw [restrs, Finset.mem_filter] at this + exact this.2 + +/-- **There are few restrictions.** -/ +theorem card_restrs_le (S K : Finset (Fin n)) : + (restrs S K).card ≤ S.card.descFactorial K.card := by + classical + have hinj : Function.Injective (fun f : {f // f ∈ restrs S K} => + (⟨fun v => ⟨f.1 v, (mem_restrs f.2).2 v⟩, fun a b hab => + (mem_restrs f.2).1 (congrArg Subtype.val hab)⟩ : + {x // x ∈ K} ↪ {x // x ∈ S})) := by + intro f g h + have h' : ∀ v, f.1 v = g.1 v := by + intro v + have := DFunLike.congr_fun h v + exact congrArg Subtype.val this + exact Subtype.ext (funext h') + have hle := Fintype.card_le_of_injective _ hinj + rwa [Fintype.card_coe, Fintype.card_embedding_eq, Fintype.card_coe, Fintype.card_coe] at hle + +/-- The values of a restriction. -/ +noncomputable def restrImage {K : Finset (Fin n)} (f : {x // x ∈ K} → Fin n) : Finset (Fin n) := + Finset.univ.image f + +theorem card_restrImage {S K : Finset (Fin n)} {f : {x // x ∈ K} → Fin n} + (hf : f ∈ restrs S K) : (restrImage f).card = K.card := by + rw [restrImage, Finset.card_image_of_injective _ (mem_restrs hf).1, Finset.card_univ, + Fintype.card_coe] + +/-- **Each restriction is shared by few permutations.** -/ +theorem card_fiber_le (S K : Finset (Fin n)) (f : {x // x ∈ K} → Fin n) + (hf : f ∈ restrs S K) : + ((permsInto S K).filter fun σ => (fun v : {x // x ∈ K} => σ v) = f).card + ≤ Nat.factorial (n - K.card) := by + classical + set R : Finset (Fin n) := Finset.univ \ restrImage f with hR + have hRcard : R.card = n - K.card := by + rw [hR, Finset.card_sdiff, Finset.inter_univ, Finset.card_univ, Fintype.card_fin, + card_restrImage hf] + -- a permutation in the fibre maps the complement of `K` into `R` + have hmaps : ∀ σ ∈ (permsInto S K).filter fun σ => (fun v : {x // x ∈ K} => σ v) = f, + ∀ v : {x // x ∉ K}, σ v.1 ∈ R := by + intro σ hσ v + rw [Finset.mem_filter] at hσ + rw [hR, Finset.mem_sdiff] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [restrImage, Finset.mem_image] + rintro ⟨w, -, hw⟩ + have hfw : f w = σ w.1 := (congrFun hσ.2 w).symm + rw [hfw] at hw + have : (w : Fin n) = v.1 := σ.injective hw + exact v.2 (this ▸ w.2) + have hinj : Function.Injective (fun σ : {σ // σ ∈ (permsInto S K).filter + fun σ => (fun v : {x // x ∈ K} => σ v) = f} => + (⟨fun v => ⟨σ.1 v.1, hmaps σ.1 σ.2 v⟩, fun a b hab => by + have : σ.1 a.1 = σ.1 b.1 := congrArg Subtype.val hab + exact Subtype.ext (σ.1.injective this)⟩ : + {x // x ∉ K} ↪ {x // x ∈ R})) := by + intro σ τ h + have hout : ∀ v : Fin n, v ∉ K → σ.1 v = τ.1 v := by + intro v hv + have := DFunLike.congr_fun h ⟨v, hv⟩ + exact congrArg Subtype.val this + have hin : ∀ v : Fin n, v ∈ K → σ.1 v = τ.1 v := by + intro v hv + have hσ := σ.2 + have hτ := τ.2 + rw [Finset.mem_filter] at hσ hτ + have h1 : σ.1 v = f ⟨v, hv⟩ := congrFun hσ.2 ⟨v, hv⟩ + have h2 : τ.1 v = f ⟨v, hv⟩ := congrFun hτ.2 ⟨v, hv⟩ + rw [h1, h2] + refine Subtype.ext (Equiv.ext fun v => ?_) + by_cases hv : v ∈ K + · exact hin v hv + · exact hout v hv + have hcompl : Fintype.card {x : Fin n // x ∉ K} = n - K.card := by + have h := Fintype.card_subtype_compl (p := fun x : Fin n => x ∈ K) + rw [Fintype.card_fin, Fintype.card_coe] at h + exact h + have hle := Fintype.card_le_of_injective _ hinj + rw [Fintype.card_coe, Fintype.card_embedding_eq, Fintype.card_coe] at hle + rw [hRcard, hcompl, Nat.descFactorial_self] at hle + exact hle + +/-- **The estimate.** -/ +theorem card_perm_mapsTo_le (S K : Finset (Fin n)) : + (permsInto S K).card ≤ S.card.descFactorial K.card * Nat.factorial (n - K.card) := by + classical + have hfib : ∀ σ ∈ permsInto S K, (fun v : {x // x ∈ K} => σ v) ∈ restrs S K := by + intro σ hσ + rw [permsInto, Finset.mem_filter] at hσ + rw [restrs, Finset.mem_filter] + exact ⟨Finset.mem_univ _, fun a b hab => Subtype.ext (σ.injective hab), + fun v => hσ.2 v.1 v.2⟩ + rw [Finset.card_eq_sum_card_fiberwise hfib] + calc ∑ f ∈ restrs S K, ((permsInto S K).filter + fun σ => (fun v : {x // x ∈ K} => σ v) = f).card + ≤ ∑ _f ∈ restrs S K, Nat.factorial (n - K.card) := + Finset.sum_le_sum fun f hf => card_fiber_le S K f hf + _ = (restrs S K).card * Nat.factorial (n - K.card) := by + rw [Finset.sum_const, smul_eq_mul] + _ ≤ S.card.descFactorial K.card * Nat.factorial (n - K.card) := + Nat.mul_le_mul_right _ (card_restrs_le S K) + +/-! ### Permutations with little escape -/ + +/-- **Few permutations move only a little of `S` out of `S`.** Such a +permutation keeps a `(s - t)`-element subset of `S` inside `S`, and there are +few subsets and, by `card_perm_mapsTo_le`, few permutations for each. -/ +theorem card_perm_escape_le (S : Finset (Fin n)) (t : ℕ) : + (Finset.univ.filter fun σ : Equiv.Perm (Fin n) => escape σ S ≤ t).card + ≤ S.card.choose (S.card - t) + * (S.card.descFactorial (S.card - t) * Nat.factorial (n - (S.card - t))) := by + classical + set k := S.card - t with hk + have hsub : (Finset.univ.filter fun σ : Equiv.Perm (Fin n) => escape σ S ≤ t) + ⊆ (S.powersetCard k).biUnion fun K => permsInto S K := by + intro σ hσ + rw [Finset.mem_filter] at hσ + have hesc : escape σ S ≤ t := hσ.2 + set A : Finset (Fin n) := S.filter fun v => σ v ∈ S with hA + have hcompl : A.card + escape σ S = S.card := by + rw [hA, escape] + exact Finset.card_filter_add_card_filter_not _ + have hAk : k ≤ A.card := by omega + obtain ⟨K, hKA, hKcard⟩ := Finset.exists_subset_card_eq hAk + rw [Finset.mem_biUnion] + refine ⟨K, ?_, ?_⟩ + · rw [Finset.mem_powersetCard] + refine ⟨fun v hv => ?_, hKcard⟩ + have := hKA hv + rw [hA, Finset.mem_filter] at this + exact this.1 + · rw [permsInto, Finset.mem_filter] + refine ⟨Finset.mem_univ _, fun v hv => ?_⟩ + have := hKA hv + rw [hA, Finset.mem_filter] at this + exact this.2 + refine le_trans (Finset.card_le_card hsub) ?_ + refine le_trans (Finset.card_biUnion_le) ?_ + have hbound : ∀ K ∈ S.powersetCard k, + (permsInto S K).card ≤ S.card.descFactorial k * Nat.factorial (n - k) := by + intro K hK + rw [Finset.mem_powersetCard] at hK + have := card_perm_mapsTo_le S K + rw [hK.2] at this + exact this + calc ∑ K ∈ S.powersetCard k, (permsInto S K).card + ≤ ∑ _K ∈ S.powersetCard k, S.card.descFactorial k * Nat.factorial (n - k) := + Finset.sum_le_sum hbound + _ = (S.powersetCard k).card * (S.card.descFactorial k * Nat.factorial (n - k)) := by + rw [Finset.sum_const, smul_eq_mul] + _ = S.card.choose k * (S.card.descFactorial k * Nat.factorial (n - k)) := by + rw [Finset.card_powersetCard] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PermGraph.lean b/Complexitylib/Classes/PCP/Internal/PermGraph.lean new file mode 100644 index 00000000..76a2df21 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PermGraph.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Cheeger +public import Complexitylib.Classes.PCP.Internal.PermCount + +/-! +# Graphs built from permutations + +A tuple of `D` permutations of `Fin n` gives a `2 D`-regular graph: at each +vertex, every permutation contributes a forward dart to its image and a +backward dart to its preimage. Reversal swaps the two, so the rotation map is +an involution with no bookkeeping. + +This is the shape in which the expander family is obtained: the permutations +are chosen by counting (a random tuple works), and this module supplies the +translation from a statement about permutations — *some* permutation moves a +constant fraction of any small set out of itself — to the edge expansion the +Cheeger bound consumes. + +## Main definitions + +- `Complexity.RegGraph.permsGraph` — the `2 D`-regular graph of a tuple +- `Complexity.escape` — how many points of a set a permutation moves out of it + +## Main results + +- `Complexity.RegGraph.edgeExpansion_permsGraph` — a lower bound on escape for + every small set gives edge expansion +-/ + +@[expose] public section + +namespace Complexity + +variable {n D : ℕ} + +namespace RegGraph + +/-- The rotation map of a tuple of permutations: a forward dart becomes the +matching backward dart at the image, and conversely. -/ +def permsRot (σ : Fin D → Equiv.Perm (Fin n)) : + Fin n × (Fin D × Bool) → Fin n × (Fin D × Bool) := + fun p => if p.2.2 then ((σ p.2.1).symm p.1, (p.2.1, false)) + else (σ p.2.1 p.1, (p.2.1, true)) + +theorem permsRot_involutive (σ : Fin D → Equiv.Perm (Fin n)) : + Function.Involutive (permsRot σ) := by + intro p + obtain ⟨v, i, b⟩ := p + cases b with + | false => simp [permsRot] + | true => simp [permsRot] + +/-- **The graph of a tuple of permutations**, of degree `2 D`. -/ +def permsGraph (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n)) : RegGraph where + V := Fin n + D := Fin D × Bool + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨(⟨0, hD⟩, false)⟩ + rot := permsRot σ + rot_involutive := permsRot_involutive σ + +@[simp] theorem order_permsGraph (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n)) : + (permsGraph hD σ).order = n := Fintype.card_fin n + +theorem deg_permsGraph (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n)) : + (permsGraph hD σ).deg = 2 * D := by + show Fintype.card (Fin D × Bool) = 2 * D + rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_bool] + ring + +theorem nbr_permsGraph_false (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n)) + (v : Fin n) (i : Fin D) : (permsGraph hD σ).nbr v (i, false) = σ i v := rfl + +/-- **Forward darts leave.** The darts of the graph that leave `S` include, for +every permutation, one for each point of `S` that permutation moves out. -/ +theorem sum_escape_le_dartsBetween (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n)) + (S : Finset (Fin n)) : + ∑ i : Fin D, escape (σ i) S + ≤ ((permsGraph hD σ).dartsBetween S Sᶜ).card := by + classical + set E : Finset (Fin D × Fin n) := + Finset.univ.filter fun p => p.2 ∈ S ∧ σ p.1 p.2 ∉ S with hE + have hone : ∀ i : Fin D, (∑ v : Fin n, if v ∈ S ∧ σ i v ∉ S then (1 : ℕ) else 0) + = escape (σ i) S := by + intro i + rw [escape, Finset.card_filter] + simp only [ite_and] + rw [Finset.sum_ite_mem, Finset.univ_inter] + have hcard : E.card = ∑ i : Fin D, escape (σ i) S := by + rw [hE, Finset.card_filter, Fintype.sum_prod_type] + exact Finset.sum_congr rfl fun i _ => hone i + rw [← hcard] + refine Finset.card_le_card_of_injOn (fun p => (p.2, (p.1, false))) (fun p hp => ?_) ?_ + · have hp' : p.2 ∈ S ∧ σ p.1 p.2 ∉ S := by simpa [hE] using hp + have hmem : ((p.2, (p.1, false)) : (permsGraph hD σ).V × (permsGraph hD σ).D) + ∈ (permsGraph hD σ).dartsBetween S Sᶜ := + Finset.mem_filter.2 ⟨Finset.mem_univ _, hp'.1, Finset.mem_compl.2 hp'.2⟩ + simpa using hmem + · intro p _ q _ h + have h1 : p.2 = q.2 := congrArg Prod.fst h + have h2 : p.1 = q.1 := congrArg (fun x => x.2.1) h + exact Prod.ext h2 h1 + +/-- **From escape to expansion.** If every nonempty set of at most half the +vertices is moved out of itself by some permutation, in at least a `1 / c` +fraction, the graph has edge expansion `1 / (2 c D)`. -/ +theorem edgeExpansion_permsGraph (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n)) (c : ℕ) + (hc : 0 < c) + (hesc : ∀ S : Finset (Fin n), 2 * S.card ≤ n → ∃ i : Fin D, S.card ≤ c * escape (σ i) S) : + (permsGraph hD σ).EdgeExpansion (1 / (2 * (c : ℝ) * D)) := by + classical + intro S hS + rw [order_permsGraph] at hS + obtain ⟨i, hi⟩ := hesc S hS + have hcD : (0 : ℝ) < 2 * (c : ℝ) * D := by + have h1 : (0 : ℝ) < c := by exact_mod_cast hc + have h2 : (0 : ℝ) < D := by exact_mod_cast hD + positivity + have hsum : (escape (σ i) S : ℝ) ≤ ∑ j : Fin D, (escape (σ j) S : ℝ) := by + refine Finset.single_le_sum (f := fun j => (escape (σ j) S : ℝ)) (fun j _ => ?_) + (Finset.mem_univ i) + positivity + have hbound : (∑ j : Fin D, (escape (σ j) S : ℝ)) + ≤ (((permsGraph hD σ).dartsBetween S Sᶜ).card : ℝ) := by + have := sum_escape_le_dartsBetween hD σ S + exact_mod_cast this + have hi' : (S.card : ℝ) ≤ (c : ℝ) * (escape (σ i) S : ℝ) := by exact_mod_cast hi + rw [deg_permsGraph] + have hrw : 1 / (2 * (c : ℝ) * D) * ((2 * D : ℕ) : ℝ) * (S.card : ℝ) + = (S.card : ℝ) / (c : ℝ) := by + push_cast + field_simp + rw [hrw] + have hc' : (0 : ℝ) < c := by exact_mod_cast hc + rw [div_le_iff₀ hc'] + have hfin : (escape (σ i) S : ℝ) ≤ (((permsGraph hD σ).dartsBetween S Sᶜ).card : ℝ) := + le_trans hsum hbound + nlinarith [hi', hfin, hc'] + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Plurality.lean b/Complexitylib/Classes/PCP/Internal/Plurality.lean new file mode 100644 index 00000000..b3b2efa9 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Plurality.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PowerCSP +public import Mathlib.Data.Finset.Max + +/-! +# The plurality assignment + +Soundness of Dinur's powering step is proved by *decoding*: an arbitrary +assignment of the powered system, whose labels are opinions that need not be +consistent with each other, is turned into a single assignment of the original +system, and the walks whose constraints fail are counted against it. + +The decoding is by plurality. The endpoint `u` of a length-`h` walk `w` out of +`v` holds an opinion about `v` — read off at the index `revWalk v w`, the +reversal of `w`, which is the walk from `u` back to `v`. Letting `w` range over +all `deg ^ h` walks out of `v` gives a multiset of opinions about `v`, and +`plurality` picks a most frequent one. + +Two consequences are recorded: the plurality value is at least as popular as any +other value, and it is held by at least a `1 / |α|` fraction of the walks. The +second is the pigeonhole that keeps the decoded assignment from being vacuous. + +## Main definitions + +- `RegCSP.opinionAbout` — what the far end of a walk says about its start +- `RegCSP.opinionCount` — how many walks out of `v` ascribe a given value to it +- `RegCSP.plurality` — the decoded assignment + +## Main results + +- `RegCSP.opinionAbout_walkEnd_revWalk`, `RegCSP.opinionAbout_padWalk` — the + opinions the powered constraint reads are entries of the plurality's multiset +- `RegCSP.opinionCount_le_plurality` — no value beats the plurality +- `RegCSP.card_le_card_mul_opinionCount_plurality` — the plurality is held by at + least a `1 / |α|` fraction of walks +-/ + +@[expose] public section + +namespace Complexity + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) (L : R.graph.Loops) (t h : ℕ) + +/-- The value that the far end of the length-`h` walk `w` out of `v` ascribes to +`v`, read at the index `revWalk v w` — the walk back from that end to `v`. -/ +def opinionAbout (A : (R.power L t h).Assignment) (v : R.graph.V) + (w : Fin h → R.graph.D) : α := + A (R.graph.walkEnd h v w) (R.graph.revWalk v w) + +/-- **Reversal duality.** The value `v` reads at the walk `w` *is* the opinion +that `w`'s far end holds about `v`. Both reversal lemmas of `Power` are used: +reversing `w` lands back at `v`, and reversing it twice returns `w`. -/ +theorem opinionAbout_walkEnd_revWalk (A : (R.power L t h).Assignment) (v : R.graph.V) + (w : Fin h → R.graph.D) : + R.opinionAbout L t h A (R.graph.walkEnd h v w) (R.graph.revWalk v w) = A v w := by + rw [opinionAbout, R.graph.walkEnd_revWalk v w, R.graph.revWalk_revWalk v w] + +/-- **The bridge to decoding.** The opinion that the *start* of a walk holds +about its `k`-th vertex — exactly what the powered constraint reads — is one of +the opinions about that vertex whose mode is `plurality`. So bounding how often +the powered constraint reads an untruthful opinion is a statement about the +plurality's own multiset. -/ +theorem opinionAbout_padWalk (A : (R.power L t h).Assignment) (v : R.graph.V) + (s : Fin t → R.graph.D) {k : ℕ} (hkh : k ≤ h) (hkt : k ≤ t) : + R.opinionAbout L t h A (R.graph.walkAt t v s k) + (R.graph.revWalk v (L.padWalk v s k h)) + = A v (L.padWalk v s k h) := by + rw [← L.walkEnd_padWalk v s hkh hkt, R.opinionAbout_walkEnd_revWalk] + +section Decode + +variable [DecidableEq α] [Fintype α] [Nonempty α] + +/-- The number of length-`h` walks out of `v` whose far end ascribes the value +`a` to `v`. -/ +def opinionCount (A : (R.power L t h).Assignment) (v : R.graph.V) (a : α) : ℕ := + (Finset.univ.filter fun w : Fin h → R.graph.D => R.opinionAbout L t h A v w = a).card + +/-- The plurality decoding: each vertex is given a value that the ends of the +walks out of it ascribe to it most often. -/ +noncomputable def plurality (A : (R.power L t h).Assignment) (v : R.graph.V) : α := + (Finset.exists_max_image (Finset.univ : Finset α) (R.opinionCount L t h A v) + ⟨Classical.arbitrary α, Finset.mem_univ _⟩).choose + +/-- No value is ascribed to `v` more often than its plurality value. -/ +theorem opinionCount_le_plurality (A : (R.power L t h).Assignment) (v : R.graph.V) (a : α) : + R.opinionCount L t h A v a ≤ R.opinionCount L t h A v (R.plurality L t h A v) := + (Finset.exists_max_image (Finset.univ : Finset α) (R.opinionCount L t h A v) + ⟨Classical.arbitrary α, Finset.mem_univ _⟩).choose_spec.2 a (Finset.mem_univ a) + +omit [Nonempty α] in +/-- The counts over all values partition the walks. -/ +theorem sum_opinionCount (A : (R.power L t h).Assignment) (v : R.graph.V) : + ∑ a : α, R.opinionCount L t h A v a = R.graph.deg ^ h := by + classical + have hcard : Fintype.card (Fin h → R.graph.D) = R.graph.deg ^ h := R.graph.card_walks h + calc ∑ a : α, R.opinionCount L t h A v a + = ∑ a : α, (Finset.univ.filter fun w : Fin h → R.graph.D => + R.opinionAbout L t h A v w = a).card := rfl + _ = (Finset.univ : Finset (Fin h → R.graph.D)).card := by + rw [← Finset.card_eq_sum_card_fiberwise] + intro w _ + exact Finset.mem_univ _ + _ = R.graph.deg ^ h := by rw [Finset.card_univ, hcard] + +/-- **Pigeonhole.** The plurality value is ascribed to `v` by at least a +`1 / |α|` fraction of the walks out of `v`. -/ +theorem card_le_card_mul_opinionCount_plurality (A : (R.power L t h).Assignment) + (v : R.graph.V) : + R.graph.deg ^ h + ≤ Fintype.card α * R.opinionCount L t h A v (R.plurality L t h A v) := by + calc R.graph.deg ^ h = ∑ a : α, R.opinionCount L t h A v a := (R.sum_opinionCount L t h A v).symm + _ ≤ ∑ _a : α, R.opinionCount L t h A v (R.plurality L t h A v) := + Finset.sum_le_sum fun a _ => R.opinionCount_le_plurality L t h A v a + _ = Fintype.card α * R.opinionCount L t h A v (R.plurality L t h A v) := by + rw [Finset.sum_const, Finset.card_univ, smul_eq_mul] + +end Decode + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PosScan.lean b/Complexitylib/Classes/PCP/Internal/PosScan.lean new file mode 100644 index 00000000..29511b68 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PosScan.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.DataScan +public import Complexitylib.Classes.PCP.Internal.SubsetNP +public import Complexitylib.Classes.PCP.Internal.CoinEnum + +/-! +# Reading a verifier's query list + +A `PCPVerifier` hands over its query positions only as an encoded list — that is +what `positions_mem` provides, and it is all a polynomial-time algorithm can +have, since a single position may be astronomically large. This module reads +individual entries back out of that encoding with the bracket scan. + +Two facts make the reading enough for everything downstream. A position is +recovered as its own serialization, so two positions can be compared by +comparing strings, with no arithmetic on the values; and an index past the end +of the list is recognisable, because every serialization is non-empty. + +## Main definitions + +- `Complexity.posInner` — the encoding stripped of its outer brackets +- `Complexity.posAt`, `Complexity.posCount` — one entry, and how many there are + +## Main results + +- `Complexity.posAt_eq`, `Complexity.posCount_eq` — what the scan reads +- `Complexity.posAt_eq_iff` — comparing entries compares positions +-/ + +@[expose] public section + +namespace Complexity + +/-- The serialized entries of an encoded list, with the outer brackets removed: +the string the scan consumes. -/ +def posInner (e : List Bool) : List Bool := (e.drop 1).take (e.length - 2) + +theorem posInner_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => posInner (a z)) ∈ FP := by + have hdrop : (fun z => dropOne (a z)) ∈ FP := dropOneFn_mem_FP ha + have hlen : (fun z => List.replicate ((a z).length - 2) false) ∈ FP := by + have h1 : (fun z => dropOne (dropOne (a z))) ∈ FP := dropOneFn_mem_FP hdrop + have := zeroBlockFn_mem_FP h1 + refine mem_FP_of_eq this fun z => ?_ + congr 1 + rw [dropOne, dropOne, List.length_drop, List.length_drop] + omega + have := Cobham.takeLenFn_mem_FP hlen hdrop + refine mem_FP_of_eq this fun z => ?_ + rw [posInner, dropOne, List.length_replicate] + +/-- The `i`-th entry of an encoded list, as its own serialization. -/ +noncomputable def posAt (e : List Bool) (i : ℕ) : List Bool := + DataScan.childOf DataScan.scanPoly (DataScan.scanArg i (posInner e)) + +/-- How many entries an encoded list has, in unary. -/ +noncomputable def posCount (e : List Bool) : List Bool := + DataScan.childCount DataScan.scanPoly (DataScan.scanArg 0 (posInner e)) + +theorem posAt_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => posAt (b z) (a z).length) ∈ FP := by + have harg : (fun z => DataScan.scanArg (a z).length (posInner (b z))) ∈ FP := + DataScan.scanArg_mem_FP ha (posInner_mem_FP hb) + have := mem_FP_comp harg (DataScan.childOf_mem_FP DataScan.scanPoly) + simpa [Function.comp] using this + +theorem posCount_mem_FP {b : List Bool → List Bool} (hb : b ∈ FP) : + (fun z => posCount (b z)) ∈ FP := by + have harg : (fun z => DataScan.scanArg (([] : List Bool)).length (posInner (b z))) ∈ FP := + DataScan.scanArg_mem_FP (constFn_mem_FP []) (posInner_mem_FP hb) + have := mem_FP_comp harg (DataScan.childCount_mem_FP DataScan.scanPoly) + simpa [Function.comp, posCount] using this + +/-! ### What the scan reads -/ + +variable {α : Type} [DataEncode α] + +theorem posInner_bitstringEncode (l : List α) : + posInner (DataEncode.bitstringEncode l) + = ((l.map DataEncode.encode).map Data.toBits).flatten := by + rw [posInner, DataEncode.bitstringEncode_def, + show DataEncode.encode l = Data.l (l.map DataEncode.encode) from rfl] + exact DataScan.inner_toBits _ + +theorem posCount_eq (l : List α) : + posCount (DataEncode.bitstringEncode l) = List.replicate l.length true := by + rw [posCount, posInner_bitstringEncode, DataScan.childCount_flatten] + simp + +theorem posAt_eq (l : List α) (i : ℕ) : + posAt (DataEncode.bitstringEncode l) i + = (((l.map DataEncode.encode)[i]?).map Data.toBits).getD [] := by + rw [posAt, posInner_bitstringEncode, DataScan.child_flatten] + +theorem posAt_eq_of_lt {l : List α} {i : ℕ} (h : i < l.length) : + posAt (DataEncode.bitstringEncode l) i + = DataEncode.bitstringEncode (l[i]'h) := by + rw [posAt_eq, List.getElem?_map, List.getElem?_eq_getElem (by simpa using h)] + rfl + +theorem posAt_eq_nil {l : List α} {i : ℕ} (h : l.length ≤ i) : + posAt (DataEncode.bitstringEncode l) i = [] := by + rw [posAt_eq, List.getElem?_map, List.getElem?_eq_none (by simpa using h)] + rfl + +theorem posAt_ne_nil {l : List α} {i : ℕ} (h : i < l.length) : + posAt (DataEncode.bitstringEncode l) i ≠ [] := by + rw [posAt_eq_of_lt h, DataEncode.bitstringEncode_def] + cases hd : DataEncode.encode (l[i]'h) with + | l xs => + rw [Data.toBits_l] + simp + +/-- **Concatenating encoded lists.** The encoding of an append is the two inner +parts, one after the other, inside a fresh pair of brackets. -/ +theorem bitstringEncode_append (l₁ l₂ : List α) : + DataEncode.bitstringEncode (l₁ ++ l₂) + = false :: (posInner (DataEncode.bitstringEncode l₁) + ++ posInner (DataEncode.bitstringEncode l₂)) ++ [true] := by + rw [posInner_bitstringEncode, posInner_bitstringEncode, + DataEncode.bitstringEncode_def, + show DataEncode.encode (l₁ ++ l₂) + = Data.l ((l₁ ++ l₂).map DataEncode.encode) from rfl, + Data.toBits_l, List.map_append, List.map_append, List.flatten_append] + simp + +/-- **Comparing entries compares positions.** The scan returns each entry's own +serialization, and that serialization determines the entry. -/ +theorem posAt_eq_iff {l l' : List α} {i i' : ℕ} (h : i < l.length) (h' : i' < l'.length) : + posAt (DataEncode.bitstringEncode l) i = posAt (DataEncode.bitstringEncode l') i' + ↔ (l[i]'h) = (l'[i']'h') := by + rw [posAt_eq_of_lt h, posAt_eq_of_lt h'] + exact ⟨fun hh => DataEncode.bitstringEncode_injective hh, fun hh => by rw [hh]⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PositionsFP.lean b/Complexitylib/Classes/PCP/Internal/PositionsFP.lean new file mode 100644 index 00000000..5efa9da4 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PositionsFP.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ListEncode + +/-! +# A verifier's query list from its positions + +`PCPVerifier` asks for the query list in `DataEncode` form, which is not how an +algorithm naturally describes it: an algorithm says "the `i`-th position is +this number". This module bridges the two, so that building a verifier needs +only a polynomial-time rule for each position, given in unary. + +The width a number needs is the number itself — every `v` is below `2 ^ v` — so +no logarithms are involved: the same unary value serves as both the value and +the width bound for `natEncodeFn`. + +## Main results + +- `Complexity.positions_mem_of_unary` — a unary position rule gives + `positions_mem` +-/ + +@[expose] public section + +namespace Complexity + +theorem fstBlock_length_le (z : List Bool) : (Cobham.fstBlock z).length ≤ z.length := by + induction z using Cobham.fstBlock.induct <;> simp [Cobham.fstBlock] <;> omega + +/-- The encoding of one position, read off a packed argument. -/ +noncomputable def posEntryFn (P : List Bool → List Bool) (w : List Bool) : List Bool := + natEncodeFn (pair (P w) (P w)) + +theorem posEntryFn_mem_FP {P : List Bool → List Bool} (hP : P ∈ FP) : + posEntryFn P ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP hP hP) natEncodeFn_mem_FP + simpa [Function.comp, posEntryFn] using this + +theorem posEntryFn_eq {P : List Bool → List Bool} (w : List Bool) : + posEntryFn P w = DataEncode.bitstringEncode ((P w).length) := by + rw [posEntryFn, natEncodeFn_eq, Cobham.sndBlock_pair] + rw [Cobham.sndBlock_pair, Cobham.fstBlock_pair] + exact Nat.lt_two_pow_self + +/-- **A unary position rule gives the query list.** If the number of queries and +each query position are polynomial-time computable in unary, then the encoded +query list is polynomial-time computable. -/ +theorem positions_mem_of_unary {pos : List Bool → ℕ → ℕ} {cnt : List Bool → ℕ} + (hcnt : (fun z : List Bool => List.replicate (cnt z) true) ∈ FP) + {P : List Bool → List Bool} (hP : P ∈ FP) + (hPspec : ∀ (z : List Bool) (i : ℕ), + P (pair z (List.replicate i true)) = List.replicate (pos z i) true) : + ∃ g ∈ FP, ∀ z : List Bool, + g z = DataEncode.bitstringEncode ((List.range (cnt z)).map (pos z)) := by + classical + set E := posEntryFn P with hE + have hEfp : E ∈ FP := posEntryFn_mem_FP hP + have hEspec : ∀ (z : List Bool) (i : ℕ), + E (pair z (List.replicate i true)) = DataEncode.bitstringEncode (pos z i) := by + intro z i + rw [hE, posEntryFn_eq, hPspec, List.length_replicate] + -- the loop stays polynomial + obtain ⟨pE, hpE⟩ := Cobham.output_length_poly_of_mem_FP hEfp + set p : Polynomial ℕ := + Polynomial.C 4 * Polynomial.X * (pE.comp (Polynomial.C 3 * Polynomial.X + Polynomial.C 2)) + + Polynomial.C 3 * Polynomial.X + Polynomial.C 6 with hp + have hbound : ∀ z' : List Bool, ∀ k ≤ (Cobham.fstBlock z').length, + ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z'))).length + ≤ p.eval z'.length := by + intro z' k hk + have hx : (Cobham.sndBlock z').length ≤ z'.length := sndBlock_length_le z' + have hf : (Cobham.fstBlock z').length ≤ z'.length := fstBlock_length_le z' + have hb : ∀ i < k, (E (pair (Cobham.sndBlock z') (List.replicate i true))).length + ≤ pE.eval (3 * z'.length + 2) := by + intro i hi + refine le_trans (hpE _) ?_ + refine polynomial_eval_mono_nat pE ?_ + rw [pair_length, List.length_replicate] + omega + have hcat := length_entryCat_le E (Cobham.sndBlock z') _ k hb + rw [listStep_iterate, pair_length, pair_length, List.length_replicate] + have hpe : p.eval z'.length + = 4 * z'.length * (pE.eval (3 * z'.length + 2)) + 3 * z'.length + 6 := by + rw [hp] + simp [Polynomial.eval_comp] + rw [hpe] + have hkz : k ≤ z'.length := le_trans hk hf + have hmul : k * pE.eval (3 * z'.length + 2) + ≤ z'.length * pE.eval (3 * z'.length + 2) := Nat.mul_le_mul_right _ hkz + have hcat' : (entryCat E (Cobham.sndBlock z') k).length + ≤ z'.length * pE.eval (3 * z'.length + 2) := le_trans hcat hmul + have h4 := Nat.mul_le_mul_left 4 hcat' + rw [show 4 * z'.length * pE.eval (3 * z'.length + 2) + = 4 * (z'.length * pE.eval (3 * z'.length + 2)) from by ring] + omega + refine ⟨fun z => listEncFn E (pair (List.replicate (cnt z) true) z), ?_, ?_⟩ + · have hpair : (fun z : List Bool => pair (List.replicate (cnt z) true) z) ∈ FP := + mem_FP_pairWithInput hcnt + have := mem_FP_comp hpair (listEncFn_mem_FP hEfp p hbound) + simpa [Function.comp] using this + · intro z + refine listEncFn_eq_bitstringEncode _ ?_ ?_ + · rw [Cobham.fstBlock_pair, List.length_replicate, List.length_map, List.length_range] + · intro i hi + rw [Cobham.sndBlock_pair, hEspec] + congr 1 + rw [List.getElem_map, List.getElem_range] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Power.lean b/Complexitylib/Classes/PCP/Internal/Power.lean new file mode 100644 index 00000000..6c688832 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Power.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.WalkPath + +/-! +# Walk reversal and the powered graph + +The graph-theoretic half of Dinur's powering step. The `t`-th power of a +regular graph `G` has the same vertices, and one edge for each **walk** of +length `t` in `G`, joining the walk's two ends. + +Making that a `RegGraph` means exhibiting the rotation map: an involution on +darts. A dart of the power is a vertex together with a tuple of `t` labels, and +its reverse is the *reversed walk* — starting at the far end and retracing the +same edges backwards. So the work here is to define reversal and prove it is an +involution. + +## How reversal is defined + +The `k`-th dart of the walk `(v, s)` is `(walkAt k, s k)`; reversing it with +`G.rot` yields the next vertex together with the label that points *back*, +called `backLabel`. The reversed walk reads those back-labels in reverse order, +using `Fin.rev` — whose own involutivity (`Fin.rev_rev`) carries most of the +index bookkeeping. + +`rot_dart` is the one computational fact everything rests on: reversing the +`k`-th dart gives `(walkAt (k+1), backLabel k)`. Applying `G.rot_involutive` to +it turns each step of the reversed walk back into a step of the original. + +## Why the power's spectral bound is `lam ^ t` + +The power's walk operator *is* the `t`-fold operator of `G`: averaging over all +`deg ^ t` walks out of a vertex is exactly `stepIter t` (`sum_walkEnd`). So the +squared-norm contraction of `RegularGraph` applies verbatim, and a graph with +`SpectralBound lam` powers up to one with `SpectralBound (lam ^ t)`. This is +what makes powering amplify the gap. + +## Main definitions + +- `RegGraph.backLabel` — the label pointing back along a dart of a walk +- `RegGraph.revWalk` — the reversed walk +- `RegGraph.power` — the `t`-th power as a `RegGraph` + +## Main results + +- `RegGraph.rot_dart` — reversing the `k`-th dart of a walk +- `RegGraph.walkAt_revWalk` — the reversed walk retraces the trajectory +- `RegGraph.walkEnd_revWalk`, `RegGraph.revWalk_revWalk` — reversal is an + involution +- `RegGraph.step_power` — the power's walk operator is `stepIter t` +- `RegGraph.spectralBound_power` — `SpectralBound lam` powers to + `SpectralBound (lam ^ t)` +- `RegGraph.deg_power`, `RegGraph.order_power` +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Reversing the darts of a walk -/ + +/-- The label at `walkAt (k+1)` that points back along the `k`-th dart of the +walk `(v, s)`. -/ +def backLabel {t : ℕ} (v : G.V) (s : Fin t → G.D) (k : Fin t) : G.D := + (G.rot (G.walkAt t v s k.val, s k)).2 + +/-- **The computational core.** Reversing the `k`-th dart of the walk `(v, s)` +gives the next vertex on the walk, together with the label pointing back. -/ +theorem rot_dart {t : ℕ} (v : G.V) (s : Fin t → G.D) (k : Fin t) : + G.rot (G.walkAt t v s k.val, s k) + = (G.walkAt t v s (k.val + 1), G.backLabel v s k) := by + refine Prod.ext ?_ rfl + exact (G.walkAt_succ_of_lt v s k.isLt).symm + +/-- The walk `(v, s)` reversed: it starts at the far end and reads the +back-labels of the original darts in reverse order. -/ +def revWalk {t : ℕ} (v : G.V) (s : Fin t → G.D) : Fin t → G.D := + fun j => G.backLabel v s (Fin.rev j) + +/-- The reversed walk retraces the original trajectory backwards. -/ +theorem walkAt_revWalk {t : ℕ} (v : G.V) (s : Fin t → G.D) : + ∀ k : ℕ, k ≤ t → + G.walkAt t (G.walkEnd t v s) (G.revWalk v s) k = G.walkAt t v s (t - k) := by + intro k + induction k with + | zero => intro _; simpa using (G.walkAt_self_eq_walkEnd v s).symm + | succ k ih => + intro hk + have hkt : k < t := by omega + have hk' : k ≤ t := le_of_lt hkt + have hrev : (Fin.rev (⟨k, hkt⟩ : Fin t)).val = t - (k + 1) := by + rw [Fin.val_rev] + have hrot := G.rot_dart v s (Fin.rev (⟨k, hkt⟩ : Fin t)) + have hinv := G.rot_involutive + (G.walkAt t v s (Fin.rev (⟨k, hkt⟩ : Fin t)).val, s (Fin.rev (⟨k, hkt⟩ : Fin t))) + rw [hrot] at hinv + rw [G.walkAt_succ_of_lt _ _ hkt, ih hk'] + have harith : t - k = (t - (k + 1)) + 1 := by omega + have hstep : G.revWalk v s ⟨k, hkt⟩ = G.backLabel v s (Fin.rev (⟨k, hkt⟩ : Fin t)) := rfl + rw [hstep, harith, nbr, ← hrev, hinv, hrev] + +/-- Reversing a walk lands back at its start. -/ +theorem walkEnd_revWalk {t : ℕ} (v : G.V) (s : Fin t → G.D) : + G.walkEnd t (G.walkEnd t v s) (G.revWalk v s) = v := by + have h := G.walkAt_revWalk v s t le_rfl + rw [G.walkAt_self_eq_walkEnd] at h + simpa using h + +/-- Reversal is an involution on walks. -/ +theorem revWalk_revWalk {t : ℕ} (v : G.V) (s : Fin t → G.D) : + G.revWalk (G.walkEnd t v s) (G.revWalk v s) = s := by + funext j + have hj : (Fin.rev j).val ≤ t := le_of_lt (Fin.rev j).isLt + have hwalk : G.walkAt t (G.walkEnd t v s) (G.revWalk v s) (Fin.rev j).val + = G.walkAt t v s (t - (Fin.rev j).val) := G.walkAt_revWalk v s _ hj + have harith : t - (Fin.rev j).val = j.val + 1 := by + rw [Fin.val_rev]; omega + have hlabel : G.revWalk v s (Fin.rev j) = G.backLabel v s j := by + rw [revWalk, Fin.rev_rev] + have hrot := G.rot_dart v s j + have hinv := G.rot_involutive (G.walkAt t v s j.val, s j) + rw [hrot] at hinv + calc G.revWalk (G.walkEnd t v s) (G.revWalk v s) j + = (G.rot (G.walkAt t (G.walkEnd t v s) (G.revWalk v s) (Fin.rev j).val, + G.revWalk v s (Fin.rev j))).2 := rfl + _ = (G.rot (G.walkAt t v s (j.val + 1), G.backLabel v s j)).2 := by + rw [hwalk, harith, hlabel] + _ = s j := by rw [hinv] + +/-! ### The powered graph -/ + +/-- The `t`-th power of `G`: same vertices, one edge per walk of length `t`. -/ +def power (G : RegGraph) (t : ℕ) : RegGraph where + V := G.V + D := Fin t → G.D + decEqV := G.decEqV + decEqD := inferInstance + fintypeV := G.fintypeV + fintypeD := inferInstance + nonemptyD := inferInstance + rot p := (G.walkEnd t p.1 p.2, G.revWalk p.1 p.2) + rot_involutive p := by + refine Prod.ext ?_ ?_ + · exact G.walkEnd_revWalk p.1 p.2 + · exact G.revWalk_revWalk p.1 p.2 + +@[simp] theorem V_power (t : ℕ) : (G.power t).V = G.V := rfl + +@[simp] theorem D_power (t : ℕ) : (G.power t).D = (Fin t → G.D) := rfl + +@[simp] theorem order_power (t : ℕ) : (G.power t).order = G.order := rfl + +@[simp] theorem deg_power (t : ℕ) : (G.power t).deg = G.deg ^ t := by + show Fintype.card (Fin t → G.D) = G.deg ^ t + rw [Fintype.card_fun, Fintype.card_fin] + rfl + +theorem nbr_power (t : ℕ) (v : G.V) (s : Fin t → G.D) : + (G.power t).nbr v s = G.walkEnd t v s := rfl + +/-- The power's walk operator is the `t`-fold walk operator of `G`. -/ +theorem step_power (t : ℕ) (f : G.V → ℝ) (v : G.V) : + (G.power t).step f v = G.stepIter t f v := by + have hd : ((G.deg : ℝ)) ^ t ≠ 0 := pow_ne_zero _ G.deg_ne_zero + calc (G.power t).step f v + = (∑ s : Fin t → G.D, f (G.walkEnd t v s)) / ((G.deg ^ t : ℕ) : ℝ) := by + rw [step, deg_power] + rfl + _ = ((G.deg : ℝ) ^ t * G.stepIter t f v) / ((G.deg : ℝ) ^ t) := by + rw [G.sum_walkEnd f t v] + push_cast + ring_nf + _ = G.stepIter t f v := by + field_simp + +/-- **Powering amplifies the spectral gap.** -/ +theorem spectralBound_power {lam : ℝ} (h : G.SpectralBound lam) (t : ℕ) : + (G.power t).SpectralBound (lam ^ t) := by + intro f hf + show (∑ v : G.V, ((G.power t).step f v) ^ 2) ≤ (lam ^ t) ^ 2 * ∑ v : G.V, (f v) ^ 2 + have hsum : (∑ v : G.V, f v) = 0 := hf + have hbound := G.sum_sq_stepIter_le h t f hsum + have hstep : ∀ v : G.V, (G.power t).step f v = G.stepIter t f v := G.step_power t f + calc ∑ v : G.V, ((G.power t).step f v) ^ 2 + = ∑ v : G.V, (G.stepIter t f v) ^ 2 := + Finset.sum_congr rfl fun v _ => by rw [hstep v] + _ ≤ lam ^ (2 * t) * ∑ v : G.V, (f v) ^ 2 := hbound + _ = (lam ^ t) ^ 2 * ∑ v : G.V, (f v) ^ 2 := by + rw [← pow_mul, mul_comm 2 t] + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PowerCSP.lean b/Complexitylib/Classes/PCP/Internal/PowerCSP.lean new file mode 100644 index 00000000..ac4fe798 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PowerCSP.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Power +public import Complexitylib.Classes.PCP.Internal.RegCSP +public import Complexitylib.Classes.PCP.Internal.WalkDart + +/-! +# Powering a constraint system + +Dinur's gap amplification step. The `t`-th power of a constraint system `R` has +the same vertices; its constraints are indexed by the **walks of length `t`** in +`R`'s graph, and its alphabet consists of *opinions*. + +## Opinions + +A label of the powered system at `v` is a function +`(Fin h → G.D) → α`: for every length-`h` walk out of `v`, a claim about the +label of that walk's endpoint. Since `G` has self-loops, `Loops.padWalk` names +every vertex within distance `h` of `v` by such a walk, so a label is exactly an +opinion about the ball of radius `h` around `v` — while remaining a *constant* +sized alphabet, `|α| ^ (deg ^ h)`, independent of the number of vertices. That +is what makes the alphabet-reduction step afterwards possible. + +## The powered constraint + +The constraint on the walk `(v, s)` compares the opinions held at its two ends. +For each step `k` of the walk that lies in the **middle window** — close enough +to the start (`k ≤ h`) that the start has an opinion about `v k`, and close +enough to the end (`t - (k+1) ≤ h`) that the end has an opinion about `v (k+1)` +— it demands that those two opinions satisfy `R`'s own constraint on the `k`-th +dart. The end's opinion is addressed through the *reversed* walk, which is why +`Power`'s reversal machinery is needed here. + +Steps outside the middle window are not checked: neither endpoint is required to +have an opinion about them. + +## What is proved here + +Perfect completeness: a satisfying assignment `σ` of `R` induces the *truthful* +opinion assignment `v ↦ (w ↦ σ (walkEnd h v w))`, which satisfies every walk +constraint, because on the middle window the two opinions are literally `σ`'s +values at the two ends of a dart of `R`. + +The converse — that the value *doubles*, the analytic heart of Dinur's proof — +is the soundness direction and is not proved here. + +## ⚠️ Soundness needs a different walk law + +Soundness decodes `A` by plurality (`Plurality`) and needs, for each checked +step `k`, that the two opinions the constraint reads are truthful with +probability at least `1 / |α|` each. That fails for the construction above, and +not for want of effort: + +* the plurality at `x` is taken over **all** `deg ^ h` walk indices out of `x`, + whereas the index the constraint reads at step `k` is + `revWalk (padWalk … k h)`, whose last `h - k` labels are the *fixed* loop + label. Those indices form a sub-cube of relative size `deg ^ (k - h)`, so a + popular-overall opinion may be wrong on every index the constraint ever + reads. + +Defining the plurality over the mixture of padded distributions instead fixes +each step in isolation but not the first moment, which needs +`∑_{k ∈ W} a_k · b_{t-1-k} > 0` for the prefix- and suffix-truthfulness +profiles `a, b`. Fixed-length walks force `i + j = t - 1` on the prefix and +suffix lengths, so `a` and `b` can be supported on mirror-disjoint halves of the +window and the sum vanishes; an adversarial `A` whose opinions depend only on +the walk length realises this. + +The construction that works is Dinur's: stop the walk with probability `1/q` at +each step. Memorylessness makes the prefix and suffix lengths **independent**, +so the double sum factorises into a product of two mixture bounds and each +factor is at least `1 / |α|`. Concretely: label darts by +`Fin T → G.D × Fin q`, let the effective length be the first index whose second +component is `0`, reverse only that prefix (keeping the tail, which preserves +involutivity), and index opinions by *variable-length* walks so that no padding +is needed. Every step of the effective walk is then checkable, and no window is +required. + +What the present construction does support is the single matching position: +with `t = 2 * h + 1` and `k = h`, the prefix and suffix are unpadded walks of +length exactly `h`, so both distributions are uniform and independent, giving +soundness with no amplification. That is a fine sanity check, but it is not +enough for the PCP theorem, which needs the gain to grow with `t`. + +## Main definitions + +- `Opinion` — the alphabet of the powered system +- `RegCSP.power` — the powered constraint system +- `RegCSP.truthful` — the opinion assignment induced by an assignment of `R` + +## Main results + +- `RegCSP.graph_power`, `RegCSP.rel_power_iff` +- `RegCSP.satisfies_power_truthful` — the truthful assignment satisfies every + walk constraint +- `RegCSP.satisfiable_power_of_satisfiable` — perfect completeness +- `RegCSP.not_satisfies_power_of_faulty` — a faulty dart in the middle window + with truthful opinions at both ends breaks the walk's constraint +- `RegCSP.card_dart_power`, `RegCSP.unsatFrac_power` — the powered value is a + fraction of walks +- `RegCSP.card_walks_faulty` — the first moment: `deg ^ (t-1)` walks per faulty + dart per step index +-/ + +@[expose] public section + +namespace Complexity + +/-- A label of the powered system: for each length-`h` walk out of the vertex, a +claim about the label of that walk's endpoint. -/ +abbrev Opinion (G : RegGraph) (h : ℕ) (α : Type) : Type := (Fin h → G.D) → α + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) (L : R.graph.Loops) (t h : ℕ) + +/-- The `t`-th power of `R`, with opinions of radius `h` as its alphabet: one +constraint per length-`t` walk, checking `R`'s constraints on the steps of the +walk that both endpoints have an opinion about. -/ +def power (R : RegCSP α) (L : R.graph.Loops) (t h : ℕ) : + RegCSP (Opinion R.graph h α) where + graph := R.graph.power t + rel v s a b := decide (∀ k : Fin t, k.val ≤ h → t - (k.val + 1) ≤ h → + R.rel (R.graph.walkAt t v s k.val) (s k) + (a (L.padWalk v s k.val h)) + (b (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) + (t - (k.val + 1)) h)) = true) + +@[simp] theorem graph_power : (R.power L t h).graph = R.graph.power t := rfl + +theorem rel_power_iff (v : R.graph.V) (s : Fin t → R.graph.D) + (a b : Opinion R.graph h α) : + (R.power L t h).rel v s a b = true ↔ + ∀ k : Fin t, k.val ≤ h → t - (k.val + 1) ≤ h → + R.rel (R.graph.walkAt t v s k.val) (s k) + (a (L.padWalk v s k.val h)) + (b (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) + (t - (k.val + 1)) h)) = true := by + simp [power] + +/-- The truthful opinion assignment induced by an assignment of `R`: every +vertex reports the true labels of the endpoints of the walks out of it. -/ +def truthful (σ : R.Assignment) : (R.power L t h).Assignment := + fun v w => σ (R.graph.walkEnd h v w) + +/-- On the middle window the truthful opinions are exactly `σ`'s values at the +two ends of the corresponding dart of `R`, so a satisfying `σ` satisfies every +walk constraint. -/ +theorem satisfies_power_truthful {σ : R.Assignment} (hσ : ∀ p, R.Satisfies σ p) + (p : (R.power L t h).Dart) : (R.power L t h).Satisfies (R.truthful L t h σ) p := by + obtain ⟨v, s⟩ := p + have hnbr : (R.power L t h).graph.nbr v s = R.graph.walkEnd t v s := R.graph.nbr_power t v s + rw [Satisfies, satisfies] + dsimp only + rw [hnbr, rel_power_iff] + intro k hk1 hk2 + have hkt : k.val < t := k.isLt + -- the start's opinion about the `k`-th vertex + have hstart : R.truthful L t h σ v (L.padWalk v s k.val h) + = σ (R.graph.walkAt t v s k.val) := by + rw [truthful, L.walkEnd_padWalk v s hk1 (le_of_lt hkt)] + -- the end's opinion about the `(k+1)`-st vertex, addressed along the reversal + have harith : t - (t - (k.val + 1)) = k.val + 1 := by omega + have hend : R.truthful L t h σ (R.graph.walkEnd t v s) + (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) (t - (k.val + 1)) h) + = σ (R.graph.walkAt t v s (k.val + 1)) := by + rw [truthful, L.walkEnd_padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) hk2 (by omega), + R.graph.walkAt_revWalk v s (t - (k.val + 1)) (by omega), harith] + rw [hstart, hend] + have hdart := hσ (R.graph.walkAt t v s k.val, s k) + rw [Satisfies, satisfies] at hdart + rwa [R.graph.walkAt_succ_of_lt v s hkt] + +/-- **Perfect completeness of powering.** -/ +theorem satisfiable_power_of_satisfiable (hR : R.Satisfiable) : + (R.power L t h).Satisfiable := by + obtain ⟨σ, hσ⟩ := hR + exact ⟨R.truthful L t h σ, fun p => R.satisfies_power_truthful L t h hσ p⟩ + +/-- **The soundness-side counterpart.** If some step of the walk lies in the +middle window, carries a dart that `σ` fails, and both endpoints happen to +report `σ`'s values for that dart's two vertices, then the walk's constraint +fails. + +This is the bridge from counting *faulty darts along walks* to the value of the +powered system: it is what makes a walk that meets a faulty dart an unsatisfied +constraint, provided the two opinions involved are truthful. Bounding how often +they are not is the remaining analytic work. -/ +theorem not_satisfies_power_of_faulty {σ : R.Assignment} + (A : (R.power L t h).Assignment) (v : R.graph.V) (s : Fin t → R.graph.D) + (k : Fin t) (hk1 : k.val ≤ h) (hk2 : t - (k.val + 1) ≤ h) + (hfault : ¬ R.Satisfies σ (R.graph.walkAt t v s k.val, s k)) + (htruth₁ : A v (L.padWalk v s k.val h) = σ (R.graph.walkAt t v s k.val)) + (htruth₂ : A (R.graph.walkEnd t v s) + (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) (t - (k.val + 1)) h) + = σ (R.graph.walkAt t v s (k.val + 1))) : + ¬ (R.power L t h).Satisfies A (v, s) := by + intro hsat + have hnbr : (R.power L t h).graph.nbr v s = R.graph.walkEnd t v s := R.graph.nbr_power t v s + rw [Satisfies, satisfies] at hsat + dsimp only at hsat + rw [hnbr, rel_power_iff] at hsat + have hk := hsat k hk1 hk2 + rw [htruth₁, htruth₂] at hk + rw [Satisfies, satisfies] at hfault + dsimp only at hfault + rw [← R.graph.walkAt_succ_of_lt v s k.isLt] at hfault + exact hfault hk + +/-! ### Counting -/ + +/-- The powered system has one constraint per walk. -/ +theorem card_dart_power : + Fintype.card (R.power L t h).Dart = R.graph.order * R.graph.deg ^ t := by + rw [card_dart] + simp [graph_power] + +/-- The value of an assignment of the powered system is the fraction of *walks* +whose constraint it fails. -/ +theorem unsatFrac_power (A : (R.power L t h).Assignment) : + (R.power L t h).unsatFrac A + = (((R.power L t h).unsatDarts A).card : ℚ) + / ((R.graph.order * R.graph.deg ^ t : ℕ) : ℚ) := by + rw [unsatFrac] + congr 2 + simp [graph_power] + +/-- **The first moment.** For each step index `k`, the walks whose `k`-th dart +is one that `σ` fails number exactly `deg ^ (t-1)` times the faulty darts — one +`deg ^ (t-1)`-sized fibre per faulty dart, by `sum_stepDart`. This is what makes +the expected number of faulty steps along a walk proportional to `unsatFrac σ`. -/ +theorem card_walks_faulty (σ : R.Assignment) {k : ℕ} (hk : k < t) : + (∑ v : R.graph.V, (Finset.univ.filter fun s : Fin t → R.graph.D => + (R.graph.walkAt t v s k, s ⟨k, hk⟩) ∈ R.unsatDarts σ).card) + = R.graph.deg ^ (t - 1) * (R.unsatDarts σ).card := + R.graph.card_walks_stepDart_mem hk (R.unsatDarts σ) + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PoweringBound.lean b/Complexitylib/Classes/PCP/Internal/PoweringBound.lean new file mode 100644 index 00000000..3369c189 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/PoweringBound.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.KilledFirstMoment +public import Mathlib.Algebra.Order.Ring.Pow + +/-! +# The powering bound, in closed form + +`powering_soundness` states the second-moment argument exactly as it falls out +of the two moment estimates: a ratio of a first-moment lower bound squared to a +second-moment upper bound, with every count left explicit. This module turns it +into the statement the amplifier needs — a lower bound on the powered system's +value as a rational function of the original value, with all the constants +isolated: + +`c² u / (c + 2 T² u + 2 T / (1 - λ)) ≤ unsatFrac (killedPow)` + +where `u` is the decoded assignment's violated fraction and +`c = (q - 1) / (4 |α|²)`. For small `u` this is linear in `u` with slope of +order `(q - 1)² (1 - λ) / (|α|⁴ T)`, and since `T` need only be linear in +`q |α|`, the slope grows with `q`: that is the amplification. For large `u` it +is bounded below by a constant. + +Two technical points are handled here. The first moment appears in the +denominator of the second-moment bound, so the ratio has to be made monotone +before the first-moment *lower* bound can be substituted in both places. And +the plurality loss must be at most half the total, which requires `T` large +enough relative to `q` and `|α|` — Bernoulli's inequality shows +`H + 1 = 4 |α| (q - 1)` suffices. + +## Main results + +- `Complexity.RegCSP.unsatFrac_killedPow_clean` — the closed-form bound +- `Complexity.RegCSP.le_unsatVal_killedPow_min` — the `min` form +- `Complexity.exists_powering_params` — a choice of `T` and `H` meeting every + side condition +-/ + +@[expose] public section + +namespace Complexity + +/-! ### Monotonicity of the Paley–Zygmund ratio -/ + +/-- `m ↦ m² / (m + P)` is increasing on `m ≥ 0` for `P > 0`. -/ +theorem sq_div_add_mono {m M P : ℝ} (hm : 0 ≤ m) (hmM : m ≤ M) (hP : 0 < P) : + m ^ 2 / (m + P) ≤ M ^ 2 / (M + P) := by + rw [div_le_div_iff₀ (by linarith) (by linarith)] + have h1 : 0 ≤ m * M * (M - m) := by + apply mul_nonneg (mul_nonneg hm (by linarith)) (by linarith) + have h2 : 0 ≤ P * ((M - m) * (M + m)) := by + apply mul_nonneg hP.le (mul_nonneg (by linarith) (by linarith)) + nlinarith [h1, h2] + +/-! ### The algebra of the bound -/ + +/-- The powering bound's algebra, over opaque real quantities: `U` violated +darts among `N · d`, first moment at least `U (q - 1) (d^T q^T / 2)² / (K² d^(T+1) q^T)`, +second moment as in `sum_sq_goodCrossings_le`. -/ +theorem powering_algebra {U N d K q lam C : ℝ} (T' : ℕ) (hN : 0 < N) (hd : 0 < d) + (hK : 0 < K) (hq : 1 ≤ q) (hlam : lam < 1) (hU : 0 < U) + (hcount : (U * ((q - 1) * (d ^ (T' + 2) * q ^ (T' + 2) / 2 + * (d ^ (T' + 2) * q ^ (T' + 2) / 2))) / (K ^ 2 * (d ^ (T' + 2 + 1) * q ^ (T' + 2)))) ^ 2 + / (U * ((q - 1) * (d ^ (T' + 2) * q ^ (T' + 2) / 2 + * (d ^ (T' + 2) * q ^ (T' + 2) / 2))) / (K ^ 2 * (d ^ (T' + 2 + 1) * q ^ (T' + 2))) + + 2 * (q ^ (T' + 2) * (d ^ T' * (((T' + 2 : ℕ) : ℝ) * ((T' + 2 : ℕ) : ℝ) * (U * U / N) + + ((T' + 2 : ℕ) : ℝ) * (1 / (1 - lam)) * (d * U))))) + ≤ C) : + ((q - 1) / (4 * K ^ 2)) ^ 2 * (U / (N * d)) + / ((q - 1) / (4 * K ^ 2) + 2 * ((T' + 2 : ℕ) : ℝ) ^ 2 * (U / (N * d)) + + 2 * ((T' + 2 : ℕ) : ℝ) / (1 - lam)) + ≤ C / (N * (d ^ (T' + 2) * q ^ (T' + 2))) := by + have hlam' : 0 < 1 - lam := by linarith + have hq0 : 0 < q := by linarith + set c : ℝ := (q - 1) / (4 * K ^ 2) with hc + set u : ℝ := U / (N * d) with hu + set W : ℝ := N * (d ^ (T' + 2) * q ^ (T' + 2)) with hW + set Tr : ℝ := ((T' + 2 : ℕ) : ℝ) with hTr + set E : ℝ := 2 * Tr ^ 2 * u + 2 * Tr / (1 - lam) with hE + have hc0 : 0 ≤ c := by rw [hc]; apply div_nonneg <;> nlinarith + have hu0 : 0 < u := by rw [hu]; positivity + have hW0 : 0 < W := by rw [hW]; positivity + have hTr0 : 0 < Tr := by rw [hTr]; positivity + have hE0 : 0 < E := by rw [hE]; positivity + have hF : U * ((q - 1) * (d ^ (T' + 2) * q ^ (T' + 2) / 2 + * (d ^ (T' + 2) * q ^ (T' + 2) / 2))) / (K ^ 2 * (d ^ (T' + 2 + 1) * q ^ (T' + 2))) + = c * u * W := by + rw [hc, hu, hW] + field_simp + ring + have hP : 2 * (q ^ (T' + 2) * (d ^ T' * (Tr * Tr * (U * U / N) + Tr * (1 / (1 - lam)) * (d * U)))) + = W * (u * E) := by + rw [hE, hu, hW] + field_simp + ring + rw [hF, hP] at hcount + have hratio : (c * u * W) ^ 2 / (c * u * W + W * (u * E)) = W * (c ^ 2 * u / (c + E)) := by + field_simp + rw [hratio] at hcount + have hgoal : c + 2 * Tr ^ 2 * u + 2 * Tr / (1 - lam) = c + E := by rw [hE]; ring + rw [hgoal] + rw [div_le_div_iff₀ (by positivity) hW0] + have hcE : 0 < c + E := by positivity + have h := mul_le_mul_of_nonneg_right hcount hcE.le + have heq : c ^ 2 * u * W = W * (c ^ 2 * u / (c + E)) * (c + E) := by + rw [mul_assoc W, div_mul_cancel₀ _ hcE.ne'] + ring + rw [heq] + exact h + +namespace RegCSP + +variable {α : Type} [Fintype α] [DecidableEq α] [Nonempty α] +variable (R : RegCSP α) (q T : ℕ) (hq : 0 < q) + +/-- **The second-moment count, with the first-moment lower bound on both +sides.** -/ +theorem card_unsatDarts_ge' (A : (R.killedPow q T hq).Assignment) {Alb P : ℝ} + (hA0 : 0 ≤ Alb) + (hA : Alb ≤ ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + (hB : ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) ^ 2 + ≤ (∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ)) + P) + (hP : 0 < P) : + Alb ^ 2 / (Alb + P) ≤ (((R.killedPow q T hq).unsatDarts A).card : ℝ) := by + classical + have hS0 : 0 ≤ ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) := + Finset.sum_nonneg fun z _ => by positivity + refine le_trans (sq_div_add_mono hA0 hA hP) ?_ + exact R.card_unsatDarts_ge q T hq A hS0 le_rfl hB (by linarith) + +/-- The slope constant of the powering bound. -/ +noncomputable def powConst (q : ℕ) (α : Type) [Fintype α] : ℝ := + ((q : ℝ) - 1) / (4 * (Fintype.card α : ℝ) ^ 2) + +/-- **The powering bound in closed form.** Under the side conditions of +`powering_soundness` and with the plurality loss at most half the total, the +powered system's violated fraction is at least +`c² u / (c + 2 T² u + 2 T / (1 - λ))`, `u` the decoded assignment's violated +fraction. -/ +theorem unsatFrac_killedPow_clean (A : (R.killedPow q T hq).Assignment) {H : ℕ} + (hH : 2 * H + 1 < T) (hHT : H + 1 ≤ T) + (hsq : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), i + j + 1 < T) + {lam : ℝ} (hlam0 : 0 ≤ lam) (hlam1 : lam < 1) (hspec : R.graph.SpectralBound lam) + (hn : 0 < R.graph.order) (hq1 : 1 ≤ q) + (hloss : 2 * (Fintype.card α * pluralityLoss R.graph.deg q T H) ≤ R.graph.deg ^ T * q ^ T) : + powConst q α ^ 2 * (((R.unsatFrac (R.kDecode q T hq A) : ℚ) : ℝ)) + / (powConst q α + 2 * (T : ℝ) ^ 2 * (((R.unsatFrac (R.kDecode q T hq A) : ℚ) : ℝ)) + + 2 * (T : ℝ) / (1 - lam)) + ≤ (((R.killedPow q T hq).unsatFrac A : ℚ) : ℝ) := by + classical + have hN0 : (0 : ℝ) < R.graph.order := by exact_mod_cast hn + have hd0 : (0 : ℝ) < R.graph.deg := by exact_mod_cast R.graph.deg_pos + have hK0 : (0 : ℝ) < Fintype.card α := by + exact_mod_cast (Fintype.card_pos : 0 < Fintype.card α) + have hq1' : (1 : ℝ) ≤ q := by exact_mod_cast hq1 + -- the violated fraction of the decoded assignment + have hu : (((R.unsatFrac (R.kDecode q T hq A) : ℚ) : ℝ)) + = ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) / ((R.graph.order : ℝ) * R.graph.deg) := by + rw [RegCSP.unsatFrac] + push_cast + rfl + have hfrac : (((R.killedPow q T hq).unsatFrac A : ℚ) : ℝ) + = (((R.killedPow q T hq).unsatDarts A).card : ℝ) + / ((R.graph.order : ℝ) * ((R.graph.deg : ℝ) ^ T * (q : ℝ) ^ T)) := by + rw [RegCSP.unsatFrac, R.card_dart_killedPow q T hq] + push_cast + rfl + rw [hu, hfrac, powConst] + -- the case of no violated darts is trivial + by_cases hU0 : ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) = 0 + · rw [hU0] + simp only [zero_div, mul_zero] + positivity + have hUpos : (0 : ℝ) < ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) := + lt_of_le_of_ne (by positivity) (Ne.symm hU0) + -- the first-moment lower bound, simplified using the loss condition + have hle : Fintype.card α * pluralityLoss R.graph.deg q T H ≤ R.graph.deg ^ T * q ^ T := by + omega + have hhalf : (((R.graph.deg ^ T * q ^ T - Fintype.card α * pluralityLoss R.graph.deg q T H + : ℕ)) : ℝ) ≥ (R.graph.deg : ℝ) ^ T * (q : ℝ) ^ T / 2 := by + rw [Nat.cast_sub hle] + push_cast + have h2 : (2 : ℝ) * (Fintype.card α * pluralityLoss R.graph.deg q T H : ℕ) + ≤ (R.graph.deg ^ T * q ^ T : ℕ) := by exact_mod_cast hloss + push_cast at h2 + linarith + have hden : (0 : ℝ) < ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) := by + have : 0 < Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) := by + have := R.graph.deg_pos + have := (Fintype.card_pos : 0 < Fintype.card α) + positivity + exact_mod_cast this + have hF : ((R.unsatDarts (R.kDecode q T hq A)).card : ℝ) * (((q : ℝ) - 1) + * ((R.graph.deg : ℝ) ^ T * (q : ℝ) ^ T / 2 * ((R.graph.deg : ℝ) ^ T * (q : ℝ) ^ T / 2))) + / ((Fintype.card α : ℝ) ^ 2 * ((R.graph.deg : ℝ) ^ (T + 1) * (q : ℝ) ^ T)) + ≤ ∑ z : R.graph.V × R.KLabels q T, ((R.goodCrossings q T hq A z).card : ℝ) := by + have h := (div_le_iff₀' hden).2 (R.sum_goodCrossings_ge q T hq A hH hHT hsq) + refine le_trans ?_ h + have hden' : (0 : ℝ) + < (Fintype.card α : ℝ) ^ 2 * ((R.graph.deg : ℝ) ^ (T + 1) * (q : ℝ) ^ T) := by + positivity + have hcastden : ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) + = (Fintype.card α : ℝ) ^ 2 * ((R.graph.deg : ℝ) ^ (T + 1) * (q : ℝ) ^ T) := by + push_cast; ring + rw [hcastden] + refine div_le_div_of_nonneg_right ?_ hden'.le + push_cast + rw [Nat.cast_sub hq1] + push_cast + refine mul_le_mul_of_nonneg_left ?_ hUpos.le + refine mul_le_mul_of_nonneg_left ?_ (by linarith) + exact mul_le_mul hhalf hhalf (by positivity) (by positivity) + have hB := R.sum_sq_goodCrossings_le q T hq A hlam0 hlam1 hspec hn + have hT2 : 2 ≤ T := by omega + obtain ⟨T', rfl⟩ : ∃ T', T = T' + 2 := ⟨T - 2, by omega⟩ + have hP0 : (0 : ℝ) < 2 * ((q : ℝ) ^ (T' + 2) * ((R.graph.deg : ℝ) ^ (T' + 2 - 2) + * (((T' + 2 : ℕ) : ℝ) * ((T' + 2 : ℕ) : ℝ) + * (((R.unsatDarts (R.kDecode q (T' + 2) hq A)).card : ℝ) + * ((R.unsatDarts (R.kDecode q (T' + 2) hq A)).card : ℝ) / (R.graph.order : ℝ)) + + ((T' + 2 : ℕ) : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) + * ((R.unsatDarts (R.kDecode q (T' + 2) hq A)).card : ℝ))))) := by + have hlam' : 0 < 1 - lam := by linarith + positivity + have hcount := R.card_unsatDarts_ge' q (T' + 2) hq A (by positivity) hF hB hP0 + have hsub : T' + 2 - 2 = T' := by omega + rw [hsub] at hcount + exact powering_algebra T' hN0 hd0 hK0 hq1' hlam1 hUpos hcount + +/-! ### The `min` form -/ + +/-- The slope of the powering bound for small values. -/ +noncomputable def powSlope (c T lam : ℝ) : ℝ := c ^ 2 / (c + 2 + 2 * T / (1 - lam)) + +/-- The floor of the powering bound for large values. -/ +noncomputable def powFloor (c T lam : ℝ) : ℝ := + (c ^ 2 / T ^ 2) / (c + 2 * T ^ 2 + 2 * T / (1 - lam)) + +/-- **The rational bound dominates a `min`.** For values up to `1 / T²` the +bound is linear with slope `powSlope`; beyond that it is at least `powFloor`. -/ +theorem min_le_powBound {c T lam u : ℝ} (hc : 0 ≤ c) (hT : 1 ≤ T) (hlam : lam < 1) + (hu0 : 0 ≤ u) (hu1 : u ≤ 1) : + min (powSlope c T lam * u) (powFloor c T lam) + ≤ c ^ 2 * u / (c + 2 * T ^ 2 * u + 2 * T / (1 - lam)) := by + have hlam' : 0 < 1 - lam := by linarith + have hD : 0 < c + 2 * T ^ 2 * u + 2 * T / (1 - lam) := by positivity + by_cases h : u ≤ 1 / T ^ 2 + · refine le_trans (min_le_left _ _) ?_ + rw [powSlope, div_mul_eq_mul_div] + refine div_le_div_of_nonneg_left (by positivity) hD ?_ + have : 2 * T ^ 2 * u ≤ 2 := by + rw [le_div_iff₀ (by positivity)] at h + linarith + linarith + · refine le_trans (min_le_right _ _) ?_ + rw [powFloor] + push Not at h + have hT2 : 0 < T ^ 2 := by positivity + have hnum : c ^ 2 / T ^ 2 ≤ c ^ 2 * u := by + rw [div_le_iff₀ hT2] + have : 1 / T ^ 2 * T ^ 2 ≤ u * T ^ 2 := + mul_le_mul_of_nonneg_right h.le hT2.le + rw [one_div, inv_mul_cancel₀ hT2.ne'] at this + nlinarith [sq_nonneg c] + have hden : c + 2 * T ^ 2 * u + 2 * T / (1 - lam) ≤ c + 2 * T ^ 2 + 2 * T / (1 - lam) := by + nlinarith + calc (c ^ 2 / T ^ 2) / (c + 2 * T ^ 2 + 2 * T / (1 - lam)) + ≤ (c ^ 2 * u) / (c + 2 * T ^ 2 + 2 * T / (1 - lam)) := + div_le_div_of_nonneg_right hnum (by positivity) + _ ≤ c ^ 2 * u / (c + 2 * T ^ 2 * u + 2 * T / (1 - lam)) := + div_le_div_of_nonneg_left (by positivity) hD hden + +/-- **The powered value, in `min` form.** -/ +theorem le_unsatVal_killedPow_min {H : ℕ} + (hH : 2 * H + 1 < T) (hHT : H + 1 ≤ T) + (hsq : ∀ i ∈ Finset.range (H + 1), ∀ j ∈ Finset.range (H + 1), i + j + 1 < T) + {lam : ℝ} (hlam0 : 0 ≤ lam) (hlam1 : lam < 1) (hspec : R.graph.SpectralBound lam) + (hn : 0 < R.graph.order) (hq1 : 1 ≤ q) + (hloss : 2 * (Fintype.card α * pluralityLoss R.graph.deg q T H) ≤ R.graph.deg ^ T * q ^ T) : + min (powSlope (powConst q α) T lam * ((R.unsatVal : ℚ) : ℝ)) (powFloor (powConst q α) T lam) + ≤ (((R.killedPow q T hq).unsatVal : ℚ) : ℝ) := by + refine R.le_unsatVal_killedPow q T hq fun A => ?_ + have hclean := R.unsatFrac_killedPow_clean q T hq A hH hHT hsq hlam0 hlam1 hspec hn hq1 hloss + have hc0 : 0 ≤ powConst q α := by + rw [powConst] + have : (1 : ℝ) ≤ q := by exact_mod_cast hq1 + apply div_nonneg <;> nlinarith + have hT1 : (1 : ℝ) ≤ T := by + have : 1 ≤ T := by omega + exact_mod_cast this + have hu0 : (0 : ℝ) ≤ ((R.unsatFrac (R.kDecode q T hq A) : ℚ) : ℝ) := by + exact_mod_cast R.unsatFrac_nonneg _ + have hu1 : ((R.unsatFrac (R.kDecode q T hq A) : ℚ) : ℝ) ≤ 1 := by + exact_mod_cast R.unsatFrac_le_one _ + have hv : ((R.unsatVal : ℚ) : ℝ) ≤ ((R.unsatFrac (R.kDecode q T hq A) : ℚ) : ℝ) := by + exact_mod_cast R.unsatVal_le _ + refine le_trans ?_ (le_trans (min_le_powBound hc0 hT1 hlam1 hu0 hu1) hclean) + refine min_le_min_right _ ?_ + have hs : 0 ≤ powSlope (powConst q α) T lam := by + rw [powSlope] + have hlam' : 0 < 1 - lam := by linarith + positivity + exact mul_le_mul_of_nonneg_left hv hs + +end RegCSP + +/-! ### Choosing the parameters -/ + +/-- **Bernoulli, for the plurality loss.** With `m = 4 K (q - 1)`, +`4 K (q - 1)^m ≤ q^m`. -/ +theorem four_mul_pow_le {K q : ℕ} (hK : 1 ≤ K) (hq : 2 ≤ q) : + 4 * K * (q - 1) ^ (4 * K * (q - 1)) ≤ q ^ (4 * K * (q - 1)) := by + have hq1 : 1 ≤ q - 1 := by omega + have hqr : ((q - 1 : ℕ) : ℝ) = (q : ℝ) - 1 := by + rw [Nat.cast_sub (by omega)]; push_cast; ring + have hpos : (0 : ℝ) < ((q - 1 : ℕ) : ℝ) := by exact_mod_cast hq1 + set m := 4 * K * (q - 1) with hm + have hbern : (1 : ℝ) + (m : ℝ) * (1 / ((q - 1 : ℕ) : ℝ)) + ≤ (1 + 1 / ((q - 1 : ℕ) : ℝ)) ^ m := + one_add_mul_le_pow (by linarith [one_div_nonneg.2 hpos.le]) m + have hratio : (1 + 1 / ((q - 1 : ℕ) : ℝ)) = (q : ℝ) / ((q - 1 : ℕ) : ℝ) := by + have hne : ((q - 1 : ℕ) : ℝ) ≠ 0 := hpos.ne' + rw [eq_div_iff hne, add_mul, one_mul, one_div, inv_mul_cancel₀ hne, hqr] + ring + rw [hratio, div_pow] at hbern + have hm' : (m : ℝ) * (1 / ((q - 1 : ℕ) : ℝ)) = 4 * K := by + rw [hm] + push_cast + field_simp + rw [hm'] at hbern + have hpm : (0 : ℝ) < ((q - 1 : ℕ) : ℝ) ^ m := by positivity + rw [le_div_iff₀ hpm] at hbern + have : (4 * K : ℝ) * ((q - 1 : ℕ) : ℝ) ^ m ≤ (q : ℝ) ^ m := by + have hK0 : (0 : ℝ) ≤ ((q - 1 : ℕ) : ℝ) ^ m := hpm.le + nlinarith + exact_mod_cast this + +/-- The truncation length used for powering: `8 K (q - 1)`. -/ +def powT (K q : ℕ) : ℕ := 2 * (4 * K * (q - 1)) + +/-- The plurality threshold used for powering: `4 K (q - 1) - 1`. -/ +def powH (K q : ℕ) : ℕ := 4 * K * (q - 1) - 1 + +/-- **Parameters for powering.** For `q ≥ 2` and alphabet size `K ≥ 1`, the +choices `powT` and `powH` meet every side condition of the powering bound, for +any degree. -/ +theorem powering_params_spec {K q : ℕ} (hK : 1 ≤ K) (hq : 2 ≤ q) (d : ℕ) : + 2 * powH K q + 1 < powT K q ∧ powH K q + 1 ≤ powT K q + ∧ (∀ i ∈ Finset.range (powH K q + 1), ∀ j ∈ Finset.range (powH K q + 1), + i + j + 1 < powT K q) + ∧ 2 * (K * RegCSP.pluralityLoss d q (powT K q) (powH K q)) + ≤ d ^ powT K q * q ^ powT K q := by + set m := 4 * K * (q - 1) with hm + have hm1 : 1 ≤ m := by + rw [hm] + have : 1 ≤ q - 1 := by omega + nlinarith + have hT : powT K q = 2 * m := rfl + have hH : powH K q = m - 1 := rfl + rw [hT, hH] + refine ⟨by omega, by omega, ?_, ?_⟩ + · intro i hi j hj + rw [Finset.mem_range] at hi hj + omega + · have hHm : m - 1 + 1 = m := by omega + rw [RegCSP.pluralityLoss, hHm] + have hstar := four_mul_pow_le hK hq + rw [← hm] at hstar + have hT' : 2 * m - m = m := by omega + rw [hT'] + have h1 : 4 * K * (q - 1) ^ (2 * m) ≤ q ^ (2 * m) := by + have hpow : (q - 1) ^ (2 * m) = (q - 1) ^ m * (q - 1) ^ m := by + rw [← pow_add]; congr 1; omega + have hpow' : q ^ (2 * m) = q ^ m * q ^ m := by + rw [← pow_add]; congr 1; omega + rw [hpow, hpow'] + have hle : (q - 1) ^ m ≤ q ^ m := Nat.pow_le_pow_left (by omega) m + calc 4 * K * ((q - 1) ^ m * (q - 1) ^ m) = (4 * K * (q - 1) ^ m) * (q - 1) ^ m := by ring + _ ≤ q ^ m * q ^ m := Nat.mul_le_mul hstar hle + have h2 : 4 * K * ((q - 1) ^ m * q ^ m) ≤ q ^ (2 * m) := by + have hpow' : q ^ (2 * m) = q ^ m * q ^ m := by + rw [← pow_add]; congr 1; omega + rw [hpow'] + calc 4 * K * ((q - 1) ^ m * q ^ m) = (4 * K * (q - 1) ^ m) * q ^ m := by ring + _ ≤ q ^ m * q ^ m := Nat.mul_le_mul_right _ hstar + have hsum : 2 * (K * ((q - 1) ^ (2 * m) + (q - 1) ^ m * q ^ m)) ≤ q ^ (2 * m) := by + nlinarith [h1, h2] + calc 2 * (K * (d ^ (2 * m) * (q - 1) ^ (2 * m) + d ^ (2 * m) * ((q - 1) ^ m * q ^ m))) + = d ^ (2 * m) * (2 * (K * ((q - 1) ^ (2 * m) + (q - 1) ^ m * q ^ m))) := by ring + _ ≤ d ^ (2 * m) * q ^ (2 * m) := Nat.mul_le_mul_left _ hsum + +/-- The per-unit slope: `powSlope` grows at least linearly in `q - 1`, with this +coefficient. -/ +noncomputable def slopeUnit (K lam : ℝ) : ℝ := + 1 / (16 * K ^ 4 * (1 / (4 * K ^ 2) + 2 + 16 * K / (1 - lam))) + +/-- **The slope grows linearly in `q`.** -/ +theorem slopeUnit_mul_le_powSlope {K : ℕ} {q : ℕ} (hK : 1 ≤ K) (hq : 2 ≤ q) {lam : ℝ} + (hlam1 : lam < 1) : + slopeUnit (K : ℝ) lam * ((q : ℝ) - 1) + ≤ RegCSP.powSlope (((q : ℝ) - 1) / (4 * (K : ℝ) ^ 2)) (powT K q : ℝ) lam := by + have hlam' : 0 < 1 - lam := by linarith + have hK0 : (0 : ℝ) < K := by exact_mod_cast (by omega : 0 < K) + have hq1 : (1 : ℝ) ≤ (q : ℝ) - 1 := by + have : (2 : ℝ) ≤ q := by exact_mod_cast hq + linarith + have hTcast : (powT K q : ℝ) = 8 * K * ((q : ℝ) - 1) := by + rw [powT, Nat.cast_mul, Nat.cast_mul, Nat.cast_mul, Nat.cast_sub (by omega)] + push_cast + ring + rw [hTcast, RegCSP.powSlope, slopeUnit] + set r := (q : ℝ) - 1 with hr + set D₀ : ℝ := 1 / (4 * (K : ℝ) ^ 2) + 2 + 16 * K / (1 - lam) with hD₀ + have hD₀0 : 0 < D₀ := by rw [hD₀]; positivity + have hden : r / (4 * (K : ℝ) ^ 2) + 2 + 2 * (8 * K * r) / (1 - lam) ≤ r * D₀ := by + rw [hD₀] + have h2 : (2 : ℝ) ≤ r * 2 := by linarith + have hx : r / (4 * (K : ℝ) ^ 2) = r * (1 / (4 * (K : ℝ) ^ 2)) := by ring + have hy : 2 * (8 * K * r) / (1 - lam) = r * (16 * K / (1 - lam)) := by ring + rw [hx, hy] + linarith + have hdenpos : 0 < r / (4 * (K : ℝ) ^ 2) + 2 + 2 * (8 * K * r) / (1 - lam) := by positivity + calc 1 / (16 * (K : ℝ) ^ 4 * D₀) * r + = (r / (4 * (K : ℝ) ^ 2)) ^ 2 / (r * D₀) := by + field_simp + ring + _ ≤ (r / (4 * (K : ℝ) ^ 2)) ^ 2 / (r / (4 * (K : ℝ) ^ 2) + 2 + 2 * (8 * K * r) / (1 - lam)) := + div_le_div_of_nonneg_left (by positivity) hdenpos hden + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Preprocess.lean b/Complexitylib/Classes/PCP/Internal/Preprocess.lean new file mode 100644 index 00000000..308eb1a2 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Preprocess.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.DegreeReductionSound +public import Complexitylib.Classes.PCP.Internal.ExpanderizeCSP +public import Complexitylib.Classes.PCP.Internal.SelfLoops +public import Complexitylib.Classes.PCP.Internal.NumEnc + +/-! +# Preprocessing, assembled + +Dinur's powering step needs its input to be regular, to be an expander, and to +carry a self-loop at every vertex. `preprocess` produces all three from an +arbitrary constraint graph, by composing the three steps already built: + +`preprocess G E = ((G.reduce E).expanderize E).addLoops` + +Each step costs only a constant factor of the value and none of them can turn an +unsatisfiable system satisfiable, so the composite is a gap-preserving reduction +with a constant of its own, `preprocessConst`. + +Degrees compose transparently: degree reduction gives `1 + E.degree`, +expanderizing adds `E.degree`, and the loops add one, for a final degree of +`2 + 2 · E.degree` — a constant, as the amplification bookkeeping requires. The +size is a constant multiple of the original too: the vertex set is fixed by the +last two steps, so it stays the `2 · numEdges` half-edges of the first. + +## Main definitions + +- `ConstraintGraph.preprocess` — the composite +- `ConstraintGraph.preprocessLoops` — its self-loops +- `ConstraintGraph.preprocessConst` — the constant factor it costs + +## Main results + +- `ConstraintGraph.deg_preprocess`, `order_preprocess` +- `ConstraintGraph.satisfiable_preprocess_of_satisfiable` — completeness +- `ConstraintGraph.le_unsatVal_preprocess` — soundness, with a constant factor +- `ConstraintGraph.spectralBound_preprocess` — the result is an expander, with a + bound strictly below one +-/ + +@[expose] public section + +namespace Complexity + +namespace ConstraintGraph + +variable {α : Type} [DecidableEq α] (G : ConstraintGraph α) (E : ExpanderFamily) + +/-- The darts of a preprocessed system: the self-loop, the edge-link, the +cloud's and the expander's. Naming the type outright — rather than leaving it as +the composite the construction produces — keeps it independent of the graph. -/ +abbrev PreDart (E : ExpanderFamily) : Type := + Unit ⊕ (Option (Fin E.degree) ⊕ Fin E.degree) + +/-- Degree reduction, then expanderizing, then adding self-loops, with the dart +type named. -/ +noncomputable def preprocess : RegCSP α where + graph := + { V := G.HalfEdge + D := PreDart E + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨Sum.inl ()⟩ + rot := (((G.reduce E).expanderize E).addLoops).graph.rot + rot_involutive := (((G.reduce E).expanderize E).addLoops).graph.rot_involutive } + rel := (((G.reduce E).expanderize E).addLoops).rel + +/-- **It is the composite it is built from.** -/ +theorem preprocess_eq : G.preprocess E = ((G.reduce E).expanderize E).addLoops := rfl + +/-- The preprocessed system's vertices are the half-edges, which are numbered +by their edge and their side. -/ +noncomputable instance : NumEnc (G.preprocess E).graph.V := + inferInstanceAs (NumEnc (Fin G.numEdges × Bool)) + +/-- Its darts are the self-loop, the edge-link, the cloud-links and the +expander's edges, in that order. -/ +noncomputable instance : NumEnc (G.preprocess E).graph.D := + inferInstanceAs (NumEnc (Unit ⊕ (Option (Fin E.degree) ⊕ Fin E.degree))) + +/-- The self-loops of the preprocessed system. -/ +noncomputable def preprocessLoops : (G.preprocess E).graph.Loops := + ((G.reduce E).expanderize E).graph.addLoopsLoops + +@[simp] theorem order_preprocess : (G.preprocess E).graph.order = 2 * G.numEdges := by + show Fintype.card (Fin G.numEdges × Bool) = _ + simp [Nat.mul_comm] + +@[simp] theorem deg_preprocess : (G.preprocess E).graph.deg = 2 + 2 * E.degree := by + show Fintype.card (PreDart E) = _ + simp + omega + +/-- **Completeness.** -/ +theorem satisfiable_preprocess_of_satisfiable (h : G.Satisfiable) : + (G.preprocess E).Satisfiable := by + rw [preprocess_eq, RegCSP.satisfiable_addLoops_iff, RegCSP.satisfiable_expanderize_iff] + exact G.satisfiable_reduce_of_satisfiable E h + +/-- The constant factor preprocessing costs. -/ +noncomputable def preprocessConst (E : ExpanderFamily) (α : Type) [Fintype α] : ℝ := + reduceConst E α + * (((1 + E.degree : ℕ) : ℝ) / ((1 + E.degree : ℕ) + (E.degree : ℝ))) + * (((1 + 2 * E.degree : ℕ) : ℝ) / (((1 + 2 * E.degree : ℕ) : ℝ) + 1)) + +section Value + +variable [Fintype α] [Nonempty α] + +/-- The value after the two trivial-constraint steps, as a multiple of the value +after degree reduction. -/ +theorem unsatVal_preprocess_eq : + ((G.preprocess E).unsatVal : ℚ) + = (G.reduce E).unsatVal + * ((1 + E.degree : ℕ) : ℚ) / (((1 + E.degree : ℕ) : ℚ) + (E.degree : ℚ)) + * ((1 + 2 * E.degree : ℕ) : ℚ) / ((((1 + 2 * E.degree : ℕ) : ℚ)) + 1) := by + have hdegR : (G.reduce E).graph.deg = 1 + E.degree := by + rw [graph_reduce, deg_reduceGraph] + have hdegX : ((G.reduce E).expanderize E).graph.deg = 1 + 2 * E.degree := by + rw [RegCSP.graph_expanderize, ExpanderFamily.deg_expanderize, hdegR] + ring + rw [preprocess_eq, RegCSP.unsatVal_addLoops, hdegX, RegCSP.unsatVal_expanderize, hdegR] + +/-- **Soundness of preprocessing.** -/ +theorem le_unsatVal_preprocess : + preprocessConst E α * ((G.unsatVal : ℚ) : ℝ) + ≤ (((G.preprocess E).unsatVal : ℚ) : ℝ) := by + set k₁ : ℝ := ((1 + E.degree : ℕ) : ℝ) / (((1 + E.degree : ℕ) : ℝ) + (E.degree : ℝ)) with hk₁ + set k₂ : ℝ := ((1 + 2 * E.degree : ℕ) : ℝ) / (((1 + 2 * E.degree : ℕ) : ℝ) + 1) with hk₂ + have hk₁nn : 0 ≤ k₁ := by rw [hk₁]; positivity + have hk₂nn : 0 ≤ k₂ := by rw [hk₂]; positivity + have hred := G.le_unsatVal_reduce E + have heq : (((G.preprocess E).unsatVal : ℚ) : ℝ) + = (((G.reduce E).unsatVal : ℚ) : ℝ) * k₁ * k₂ := by + rw [G.unsatVal_preprocess_eq E, hk₁, hk₂] + push_cast + ring + rw [heq, preprocessConst, ← hk₁, ← hk₂] + calc reduceConst E α * k₁ * k₂ * ((G.unsatVal : ℚ) : ℝ) + = (reduceConst E α * ((G.unsatVal : ℚ) : ℝ)) * k₁ * k₂ := by ring + _ ≤ (((G.reduce E).unsatVal : ℚ) : ℝ) * k₁ * k₂ := by + exact mul_le_mul_of_nonneg_right + (mul_le_mul_of_nonneg_right hred hk₁nn) hk₂nn + +end Value + +/-! ### The spectral bound -/ + +/-- The spectral bound preprocessing achieves. -/ +noncomputable def preprocessLam (E : ExpanderFamily) : ℝ := + (1 + (1 + 2 * (E.degree : ℝ)) + * (((1 + (E.degree : ℝ)) + (E.degree : ℝ) * E.lam) / ((1 + (E.degree : ℝ)) + E.degree))) + / (1 + (1 + 2 * (E.degree : ℝ))) + +/-- **The preprocessed system is an expander.** -/ +theorem spectralBound_preprocess : + (G.preprocess E).graph.SpectralBound (preprocessLam E) := by + have hdegR : (G.reduce E).graph.deg = 1 + E.degree := by + rw [graph_reduce, deg_reduceGraph] + have hdegX : ((G.reduce E).expanderize E).graph.deg = 1 + 2 * E.degree := by + rw [RegCSP.graph_expanderize, ExpanderFamily.deg_expanderize, hdegR] + ring + have hX := (G.reduce E).spectralBound_expanderize E + rw [hdegR] at hX + set mu : ℝ := (((1 + E.degree : ℕ) : ℝ) + (E.degree : ℝ) * E.lam) + / (((1 + E.degree : ℕ) : ℝ) + (E.degree : ℝ)) with hmu + have hmunn : 0 ≤ mu := by + rw [hmu] + have : (0 : ℝ) ≤ 1 - E.lam := by linarith [E.lam_lt_one] + have hlam : 0 ≤ E.lam := E.lam_nonneg + positivity + have hL := ((G.reduce E).expanderize E).graph.spectralBound_addLoops hmunn hX + rw [hdegX] at hL + have hgoal : preprocessLam E + = (1 + ((1 + 2 * E.degree : ℕ) : ℝ) * mu) / (1 + ((1 + 2 * E.degree : ℕ) : ℝ)) := by + rw [preprocessLam, hmu] + push_cast + ring_nf + rw [hgoal] + exact hL + +theorem preprocessLam_lt_one : preprocessLam E < 1 := by + have hd : (0 : ℝ) ≤ (E.degree : ℝ) := by positivity + have hlam := E.lam_lt_one + have hlamnn := E.lam_nonneg + have hmu : ((1 + (E.degree : ℝ)) + (E.degree : ℝ) * E.lam) + / ((1 + (E.degree : ℝ)) + E.degree) < 1 := by + rw [div_lt_one (by positivity)] + have hdpos : (0 : ℝ) < (E.degree : ℝ) := by exact_mod_cast E.degree_pos + nlinarith + rw [preprocessLam, div_lt_one (by positivity)] + nlinarith [hmu] + +end ConstraintGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/RankCount.lean b/Complexitylib/Classes/PCP/Internal/RankCount.lean new file mode 100644 index 00000000..f561ce47 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/RankCount.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Data.Finset.Sort +public import Mathlib.Data.Fintype.Card +public import Mathlib.Order.Interval.Finset.Fin + +/-! +# Counting below, and the element counted to + +A finite set of numbers is enumerated in increasing order by +`Finset.orderEmbOfFin`. An algorithm cannot enumerate; what it can do is count. +This module connects the two: the position of an element in the increasing +enumeration is the number of elements below it, so an algorithm finds the `k`-th +element by looking for the one with `k` elements below it. + +## Main definitions + +- `Complexity.countBelow` — how many elements of a set lie below a number + +## Main results + +- `Complexity.countBelow_orderEmbOfFin` — counting below the `i`-th element + gives `i` +- `Complexity.orderEmbOfFin_eq_of_countBelow` — so the count names the element +- `Complexity.idxOf_eq_countP` — and in a list sorted by a key, the position of + an entry is the number of entries with a smaller key +-/ + +@[expose] public section + +namespace Complexity + +/-- How many elements of `S` lie below `p`. -/ +def countBelow (S : Finset ℕ) (p : ℕ) : ℕ := (S.filter (· < p)).card + +/-- **Counting below the `i`-th smallest element gives `i`.** -/ +theorem countBelow_orderEmbOfFin (S : Finset ℕ) {k : ℕ} (h : S.card = k) (i : Fin k) : + countBelow S (S.orderEmbOfFin h i) = i.val := by + classical + have himg : Finset.image (S.orderEmbOfFin h) Finset.univ = S := + S.image_orderEmbOfFin_univ h + have hfilter : S.filter (· < S.orderEmbOfFin h i) + = Finset.image (S.orderEmbOfFin h) (Finset.Iio i) := by + ext q + simp only [Finset.mem_filter, Finset.mem_image, Finset.mem_Iio] + constructor + · rintro ⟨hqS, hqlt⟩ + have hq : q ∈ Finset.image (S.orderEmbOfFin h) Finset.univ := by rw [himg]; exact hqS + obtain ⟨j, -, rfl⟩ := Finset.mem_image.mp hq + exact ⟨j, (OrderEmbedding.lt_iff_lt _).mp hqlt, rfl⟩ + · rintro ⟨j, hj, rfl⟩ + exact ⟨S.orderEmbOfFin_mem h j, (OrderEmbedding.lt_iff_lt _).mpr hj⟩ + rw [countBelow, hfilter, Finset.card_image_of_injective _ (S.orderEmbOfFin h).injective, + Fin.card_Iio] + +/-- **The count names the element.** -/ +theorem orderEmbOfFin_eq_of_countBelow {S : Finset ℕ} {k : ℕ} (h : S.card = k) (i : Fin k) + {p : ℕ} (hp : p ∈ S) (hcount : countBelow S p = i.val) : S.orderEmbOfFin h i = p := by + classical + have himg : Finset.image (S.orderEmbOfFin h) Finset.univ = S := + S.image_orderEmbOfFin_univ h + rw [← himg, Finset.mem_image] at hp + obtain ⟨j, -, hj⟩ := hp + have hjcount : countBelow S (S.orderEmbOfFin h j) = j.val := + countBelow_orderEmbOfFin S h j + rw [hj, hcount] at hjcount + rw [← hj] + exact congrArg _ (Fin.ext hjcount) + +/-- **Counting below is strictly monotone along the set.** -/ +theorem countBelow_lt_countBelow {S : Finset ℕ} {j c : ℕ} (hj : j ∈ S) (hlt : j < c) : + countBelow S j < countBelow S c := by + classical + refine Finset.card_lt_card ⟨?_, ?_⟩ + · intro x hx + rw [Finset.mem_filter] at hx ⊢ + exact ⟨hx.1, by omega⟩ + · intro hsub + have hjc : j ∈ S.filter (· < c) := Finset.mem_filter.mpr ⟨hj, hlt⟩ + have := hsub hjc + rw [Finset.mem_filter] at this + omega + +/-- **An element's position is below the size.** -/ +theorem countBelow_lt_card {S : Finset ℕ} {c : ℕ} (hc : c ∈ S) : countBelow S c < S.card := by + classical + refine Finset.card_lt_card ⟨Finset.filter_subset _ _, ?_⟩ + intro hsub + have := hsub hc + rw [Finset.mem_filter] at this + omega + +/-! ### Positions in a sorted list -/ + +/-- **In a list sorted by a key, an entry's position is the number of entries +with a smaller key.** -/ +theorem idxOf_eq_countP {β : Type} [BEq β] [LawfulBEq β] {key : β → ℕ} : + ∀ {l : List β}, List.Pairwise (fun p q => key p ≤ key q) l → + (∀ p ∈ l, ∀ q ∈ l, key p = key q → p = q) → + ∀ {x : β}, x ∈ l → l.idxOf x = l.countP fun q => decide (key q < key x) + | [], _, _, _, hx => by simp at hx + | a :: t, hpair, hinj, x, hx => by + rw [List.pairwise_cons] at hpair + by_cases hxa : x = a + · subst hxa + have hzero : (t.countP fun q => decide (key q < key x)) = 0 := by + refine List.countP_eq_zero.mpr fun q hq => ?_ + have := hpair.1 q hq + simp only [decide_eq_true_eq] + omega + rw [List.idxOf_cons_self, List.countP_cons, hzero] + simp + · have hxt : x ∈ t := by + rcases List.mem_cons.mp hx with h | h + · exact absurd h hxa + · exact h + have hlt : key a < key x := by + have hle := hpair.1 x hxt + have hne : key a ≠ key x := fun h => + hxa (hinj x (List.mem_cons_of_mem _ hxt) a List.mem_cons_self h.symm) + omega + have hih := idxOf_eq_countP hpair.2 + (fun p hp q hq => hinj p (List.mem_cons_of_mem _ hp) q (List.mem_cons_of_mem _ hq)) hxt + rw [List.idxOf_cons_ne _ (Ne.symm hxa), hih, List.countP_cons] + simp only [decide_eq_true_eq, if_pos hlt] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/RegCSP.lean b/Complexitylib/Classes/PCP/Internal/RegCSP.lean new file mode 100644 index 00000000..1795a8e0 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/RegCSP.lean @@ -0,0 +1,206 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.RegularGraph +public import Mathlib.Data.Rat.Lemmas +public import Mathlib.Tactic.Positivity + +/-! +# Constraint graphs on a regular graph + +Dinur's argument runs on constraint graphs whose underlying multigraph is +`d`-regular, because that is what makes random walks and the spectral gap +available. This module puts the two halves together: a `RegCSP` is a `RegGraph` +together with a constraint attached to each **dart**, symmetric under reversal, +so that it is really one constraint per undirected edge. + +The measure on constraints is the uniform measure on **darts**: `unsatFrac` +divides the number of unsatisfied darts by `order * deg`. Constraints are +attached to darts rather than to undirected edges, and are *not* required to +agree with their reverse. Nothing is lost: the random walk traverses darts, so +the dart measure is the one every estimate is stated in, and the eventual +verifier samples a dart and checks one constraint. Requiring symmetry instead +would force each construction — powering above all — to prove that reversing a +walk and swapping the two opinions leaves its constraint unchanged, an +index-reversal argument of no mathematical content. + +Two presentations of a constraint system coexist in this development, on +purpose. `ConstraintGraph` has its vertex and edge counts as *numeric fields*, +so it is a single type that a transformation can be iterated on (see +`Amplifier`) and that a bitstring encoding can address; `RegCSP` carries +structured vertex and dart types, which is what Dinur's constructions produce. +The bijective bridge between them belongs to the final encoded reduction and is +built there. + +## Main definitions + +- `RegCSP`, `RegCSP.Dart`, `RegCSP.Assignment`, `RegCSP.satisfies`, + `RegCSP.Satisfies`, `RegCSP.Satisfiable`, `RegCSP.unsatDarts` +- `RegCSP.unsatFrac`, `RegCSP.unsatVal` — the fraction of darts an assignment + fails, and its minimum over assignments + +## Main results + +- `RegCSP.unsatFrac_eq_zero_iff`, `RegCSP.unsatVal_eq_zero_iff_satisfiable` — + value zero is satisfiability +- `RegCSP.unsatVal_nonneg`, `RegCSP.unsatVal_le_one` +- `RegCSP.inv_card_dart_le_unsatVal` — an unsatisfiable system has value at + least one dart's worth +-/ + +@[expose] public section + +namespace Complexity + +/-- A constraint system on a regular multigraph: one constraint per **dart**. -/ +structure RegCSP (α : Type) where + /-- The underlying regular multigraph. -/ + graph : RegGraph + /-- The constraint on the dart `(v, i)`, as a predicate on the label of `v` + and the label of its `i`-th neighbour, in that order. -/ + rel : graph.V → graph.D → α → α → Bool + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) + +/-- A dart: a vertex together with one of its `d` outgoing edge labels. -/ +abbrev Dart (R : RegCSP α) : Type := R.graph.V × R.graph.D + +/-- An assignment labels every vertex with a symbol of the alphabet. -/ +abbrev Assignment (R : RegCSP α) : Type := R.graph.V → α + +/-- Whether the dart `p`'s constraint holds under `a`, as a `Bool`. -/ +def satisfies (a : R.Assignment) (p : R.Dart) : Bool := + R.rel p.1 p.2 (a p.1) (a (R.graph.nbr p.1 p.2)) + +/-- The dart `p`'s constraint holds under `a`. -/ +def Satisfies (a : R.Assignment) (p : R.Dart) : Prop := R.satisfies a p = true + +instance (a : R.Assignment) (p : R.Dart) : Decidable (R.Satisfies a p) := + inferInstanceAs (Decidable (R.satisfies a p = true)) + +/-- The darts left unsatisfied by `a`. -/ +def unsatDarts (a : R.Assignment) : Finset R.Dart := + Finset.univ.filter fun p => ¬ R.Satisfies a p + +@[simp] theorem mem_unsatDarts {a : R.Assignment} {p : R.Dart} : + p ∈ R.unsatDarts a ↔ ¬ R.Satisfies a p := by + simp [unsatDarts] + +/-- Some assignment satisfies every dart. -/ +def Satisfiable : Prop := ∃ a : R.Assignment, ∀ p, R.Satisfies a p + +/-- The number of darts. -/ +theorem card_dart : Fintype.card R.Dart = R.graph.order * R.graph.deg := by + simp [Dart] + +theorem card_unsatDarts_le (a : R.Assignment) : + (R.unsatDarts a).card ≤ R.graph.order * R.graph.deg := by + have h := Finset.card_le_univ (R.unsatDarts a) + rwa [card_dart] at h + +/-- The fraction of darts an assignment leaves unsatisfied. -/ +def unsatFrac (a : R.Assignment) : ℚ := + ((R.unsatDarts a).card : ℚ) / ((R.graph.order * R.graph.deg : ℕ) : ℚ) + +theorem unsatFrac_nonneg (a : R.Assignment) : 0 ≤ R.unsatFrac a := by + unfold unsatFrac; positivity + +theorem unsatFrac_le_one (a : R.Assignment) : R.unsatFrac a ≤ 1 := by + rcases Nat.eq_zero_or_pos (R.graph.order * R.graph.deg) with h | h + · simp [unsatFrac, h] + · have hpos : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by exact_mod_cast h + rw [unsatFrac, div_le_one hpos] + exact_mod_cast R.card_unsatDarts_le a + +/-- An assignment wastes no darts exactly when it satisfies them all. -/ +theorem unsatFrac_eq_zero_iff {a : R.Assignment} : + R.unsatFrac a = 0 ↔ ∀ p, R.Satisfies a p := by + constructor + · intro h p + by_contra hp + have hne : (R.unsatDarts a).Nonempty := ⟨p, by simpa using hp⟩ + have hcard : 0 < (R.unsatDarts a).card := Finset.card_pos.mpr hne + have hm : 0 < R.graph.order * R.graph.deg := lt_of_lt_of_le hcard (R.card_unsatDarts_le a) + have hmq : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by exact_mod_cast hm + have hcq : (0 : ℚ) < ((R.unsatDarts a).card : ℚ) := by exact_mod_cast hcard + rw [unsatFrac, div_eq_zero_iff] at h + rcases h with h | h + · exact absurd h (ne_of_gt hcq) + · exact absurd h (ne_of_gt hmq) + · intro h + have hempty : R.unsatDarts a = ∅ := by + ext p; simpa using h p + simp [unsatFrac, hempty] + +/-- An unsatisfiable regular constraint graph has a dart. -/ +theorem card_dart_pos_of_not_satisfiable (h : ¬ R.Satisfiable) [Nonempty α] : + 0 < R.graph.order * R.graph.deg := by + rcases Nat.eq_zero_or_pos (R.graph.order * R.graph.deg) with h0 | h0 + · refine absurd ⟨(fun _ => Classical.arbitrary α : R.Assignment), fun p => ?_⟩ h + have hcard : Fintype.card R.Dart = 0 := by rw [card_dart, h0] + have hempty : IsEmpty R.Dart := Fintype.card_eq_zero_iff.mp hcard + exact hempty.elim p + · exact h0 + +section Value + +variable [Fintype α] [Nonempty α] + +/-- The least fraction of darts any assignment leaves unsatisfied. -/ +noncomputable def unsatVal : ℚ := + (Finset.univ : Finset R.Assignment).inf' Finset.univ_nonempty R.unsatFrac + +theorem unsatVal_le (a : R.Assignment) : R.unsatVal ≤ R.unsatFrac a := + Finset.inf'_le _ (Finset.mem_univ a) + +theorem le_unsatVal {c : ℚ} (h : ∀ a : R.Assignment, c ≤ R.unsatFrac a) : c ≤ R.unsatVal := + Finset.le_inf' _ _ fun a _ => h a + +theorem exists_assignment_unsatFrac_eq_unsatVal : + ∃ a : R.Assignment, R.unsatFrac a = R.unsatVal := by + obtain ⟨a, -, ha⟩ := Finset.exists_mem_eq_inf' (Finset.univ_nonempty) R.unsatFrac + exact ⟨a, ha.symm⟩ + +theorem unsatVal_nonneg : 0 ≤ R.unsatVal := R.le_unsatVal fun a => R.unsatFrac_nonneg a + +theorem unsatVal_le_one : R.unsatVal ≤ 1 := by + obtain ⟨a, ha⟩ := R.exists_assignment_unsatFrac_eq_unsatVal + exact ha ▸ R.unsatFrac_le_one a + +theorem unsatVal_eq_zero_iff_satisfiable : R.unsatVal = 0 ↔ R.Satisfiable := by + constructor + · intro h + obtain ⟨a, ha⟩ := R.exists_assignment_unsatFrac_eq_unsatVal + exact ⟨a, R.unsatFrac_eq_zero_iff.mp (ha.trans h)⟩ + · rintro ⟨a, ha⟩ + have h0 : R.unsatFrac a = 0 := R.unsatFrac_eq_zero_iff.mpr ha + exact le_antisymm (h0 ▸ R.unsatVal_le a) R.unsatVal_nonneg + +/-- On an unsatisfiable graph every assignment fails a dart, so the value is at +least one dart's worth. -/ +theorem inv_card_dart_le_unsatVal (h : ¬ R.Satisfiable) : + 1 / ((R.graph.order * R.graph.deg : ℕ) : ℚ) ≤ R.unsatVal := by + refine R.le_unsatVal fun a => ?_ + have hpos : 0 < R.graph.order * R.graph.deg := R.card_dart_pos_of_not_satisfiable h + have hmq : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by exact_mod_cast hpos + have hne : (R.unsatDarts a).Nonempty := by + by_contra hcon + rw [Finset.not_nonempty_iff_eq_empty] at hcon + refine h ⟨a, fun p => ?_⟩ + by_contra hp + simpa [hcon] using (mem_unsatDarts (R := R) (a := a) (p := p)).mpr hp + have hcard : (1 : ℚ) ≤ ((R.unsatDarts a).card : ℚ) := by + exact_mod_cast Finset.card_pos.mpr hne + rw [unsatFrac] + gcongr + +end Value + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/RegularGraph.lean b/Complexitylib/Classes/PCP/Internal/RegularGraph.lean new file mode 100644 index 00000000..9533df8b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/RegularGraph.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Algebra.BigOperators.Field +public import Mathlib.Algebra.BigOperators.Fin +public import Mathlib.Algebra.Order.BigOperators.Ring.Finset +public import Mathlib.Algebra.Order.Chebyshev +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Data.Fintype.Prod +public import Mathlib.Data.Real.Basic +public import Mathlib.Tactic.FieldSimp +public import Mathlib.Tactic.Linarith +public import Mathlib.Tactic.Positivity +public import Mathlib.Tactic.Ring + +/-! +# Regular graphs, their walk operator, and the spectral gap + +The graph-theoretic substrate of Dinur's proof: regular multigraphs given by a +**rotation map**, the associated random-walk averaging operator, and a +square-norm formulation of the spectral gap. + +A `RegGraph` carries a finite vertex type `V`, a finite nonempty label type `D`, +and an involution `rot : V × D → V × D` on *darts* (a vertex together with one +of its outgoing edge labels). The involution pairs each dart with its reverse, +which is what makes the graph undirected and `|D|`-regular, with parallel edges +and self-loops allowed — all three are needed, since powering and +expanderization produce them. The neighbour function is `nbr v i = (rot (v,i)).1`. + +## Why `V` and `D` are types, not numbers + +Dinur's constructions build new graphs whose vertices and labels are *structured*: +powering takes the label type to walk tuples `Fin t → D`, and degree reduction +takes the vertex type to the dart type `V × D`. Carrying `V` and `D` as types +lets those constructions be written directly, with no encoding bijections; the +translation to `Fin`-indexed data is deferred to the one place that needs it, +the encoded reduction at the very end. + +## The spectral gap, without square roots + +Rather than second eigenvalues, `SpectralBound G lam` says directly that the +walk operator contracts *mean-zero* functions by `lam` in the Euclidean norm, +stated on **squared** norms: + +`∑ v, (step f v) ^ 2 ≤ lam ^ 2 * ∑ v, (f v) ^ 2` whenever `∑ v, f v = 0`. + +This avoids `Real.sqrt` and eigenvalue machinery entirely, and it is exactly +the form the walk analysis needs: `step` preserves sums (so it preserves +mean-zero-ness), hence the bound self-composes and `t` steps contract by +`lam ^ t`. + +## Main definitions + +- `RegGraph`, `RegGraph.deg`, `RegGraph.order`, `RegGraph.nbr`, + `RegGraph.step`, `RegGraph.stepIter` +- `RegGraph.SpectralBound` + +## Main results + +- `RegGraph.sum_nbr` — summing over darts is summing over vertices, `deg` times +- `RegGraph.sum_step` — the walk operator preserves sums +- `RegGraph.step_symm` — it is self-adjoint +- `RegGraph.sum_sq_step_le` — it is a contraction, with no spectral hypothesis +- `RegGraph.sum_sq_stepIter_le` — `t` steps contract mean-zero functions by + `lam ^ (2 * t)` in squared norm +-/ + +@[expose] public section + +namespace Complexity + +/-- A regular multigraph, presented by a rotation map: an involution on darts +`(vertex, edge label)` sending each dart to its reverse. Every vertex has +exactly one dart per label, so the graph is `|D|`-regular; parallel edges and +self-loops are allowed. -/ +structure RegGraph where + /-- The vertex type. -/ + V : Type + /-- The edge-label type; each vertex has one outgoing dart per label. -/ + D : Type + /-- Vertices have decidable equality, so assignments form a `Fintype`. -/ + decEqV : DecidableEq V + /-- Labels have decidable equality, so label tuples form a `Fintype`. -/ + decEqD : DecidableEq D + /-- The vertex type is finite. -/ + fintypeV : Fintype V + /-- The label type is finite. -/ + fintypeD : Fintype D + /-- The label type is nonempty, i.e. the degree is positive. -/ + nonemptyD : Nonempty D + /-- The rotation map, sending a dart to its reverse. -/ + rot : V × D → V × D + /-- Reversing a dart twice is the identity. -/ + rot_involutive : Function.Involutive rot + +attribute [instance] RegGraph.decEqV RegGraph.decEqD RegGraph.fintypeV RegGraph.fintypeD + RegGraph.nonemptyD + +namespace RegGraph + +variable (G : RegGraph) + +/-- The degree: the number of darts at each vertex. -/ +def deg : ℕ := Fintype.card G.D + +/-- The number of vertices. -/ +def order : ℕ := Fintype.card G.V + +theorem deg_pos : 0 < G.deg := Fintype.card_pos + +@[simp] theorem card_eq_order : Fintype.card G.V = G.order := rfl + +@[simp] theorem card_eq_deg : Fintype.card G.D = G.deg := rfl + +theorem deg_ne_zero : (G.deg : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr G.deg_pos.ne' + +/-- The `i`-th neighbour of `v`. -/ +def nbr (v : G.V) (i : G.D) : G.V := (G.rot (v, i)).1 + +/-- The rotation map is a bijection of darts. -/ +theorem rot_bijective : Function.Bijective G.rot := G.rot_involutive.bijective + +/-- Summing a function of the neighbour over all darts is summing it over all +vertices, each counted `deg` times. This is the rotation-map form of +regularity, and it is the source of every counting identity below. Stated for an +arbitrary `AddCommMonoid`, since the walk analysis needs it both for real +averages and for counting in `ℕ`. -/ +theorem sum_nbr_nsmul {M : Type*} [AddCommMonoid M] (f : G.V → M) : + ∑ v : G.V, ∑ i : G.D, f (G.nbr v i) = G.deg • ∑ v : G.V, f v := by + have hprod : ∑ p : G.V × G.D, f (G.rot p).1 = ∑ p : G.V × G.D, f p.1 := + Fintype.sum_bijective G.rot G.rot_bijective _ _ fun _ => rfl + calc ∑ v : G.V, ∑ i : G.D, f (G.nbr v i) + = ∑ p : G.V × G.D, f (G.rot p).1 := + (Fintype.sum_prod_type (fun p : G.V × G.D => f (G.rot p).1)).symm + _ = ∑ p : G.V × G.D, f p.1 := hprod + _ = ∑ v : G.V, ∑ _i : G.D, f v := Fintype.sum_prod_type (fun p : G.V × G.D => f p.1) + _ = ∑ v : G.V, G.deg • f v := by simp + _ = G.deg • ∑ v : G.V, f v := Finset.sum_nsmul _ _ _ + +theorem sum_nbr (f : G.V → ℝ) : + ∑ v : G.V, ∑ i : G.D, f (G.nbr v i) = (G.deg : ℝ) * ∑ v : G.V, f v := by + rw [G.sum_nbr_nsmul f, nsmul_eq_mul] + +/-- One step of the random walk, as an averaging operator on real-valued +functions on the vertices. -/ +noncomputable def step (f : G.V → ℝ) (v : G.V) : ℝ := + (∑ i : G.D, f (G.nbr v i)) / (G.deg : ℝ) + +/-- The walk operator preserves sums: it is doubly stochastic. -/ +theorem sum_step (f : G.V → ℝ) : ∑ v : G.V, G.step f v = ∑ v : G.V, f v := by + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + calc ∑ v : G.V, G.step f v + = (∑ v : G.V, ∑ i : G.D, f (G.nbr v i)) / (G.deg : ℝ) := by + rw [Finset.sum_div]; rfl + _ = ((G.deg : ℝ) * ∑ v : G.V, f v) / (G.deg : ℝ) := by rw [G.sum_nbr f] + _ = ∑ v : G.V, f v := by field_simp + +/-- The walk operator is self-adjoint for the standard inner product. -/ +theorem step_symm (f g : G.V → ℝ) : + ∑ v : G.V, G.step f v * g v = ∑ v : G.V, f v * G.step g v := by + have key : ∑ p : G.V × G.D, f (G.rot p).1 * g p.1 + = ∑ p : G.V × G.D, f p.1 * g (G.rot p).1 := by + refine Fintype.sum_bijective G.rot G.rot_bijective _ _ fun p => ?_ + rw [G.rot_involutive p] + have hL : ∑ v : G.V, G.step f v * g v + = (∑ p : G.V × G.D, f (G.rot p).1 * g p.1) / (G.deg : ℝ) := by + rw [Fintype.sum_prod_type, Finset.sum_div] + refine Finset.sum_congr rfl fun v _ => ?_ + simp only [step, div_mul_eq_mul_div, Finset.sum_mul] + rfl + have hR : ∑ v : G.V, f v * G.step g v + = (∑ p : G.V × G.D, f p.1 * g (G.rot p).1) / (G.deg : ℝ) := by + rw [Fintype.sum_prod_type, Finset.sum_div] + refine Finset.sum_congr rfl fun v _ => ?_ + simp only [step, mul_div_assoc', Finset.mul_sum] + rfl + rw [hL, hR, key] + +/-- The `t`-step walk operator. -/ +noncomputable def stepIter (t : ℕ) (f : G.V → ℝ) : G.V → ℝ := G.step^[t] f + +@[simp] theorem stepIter_zero (f : G.V → ℝ) : G.stepIter 0 f = f := rfl + +theorem stepIter_succ (t : ℕ) (f : G.V → ℝ) : + G.stepIter (t + 1) f = G.step (G.stepIter t f) := + Function.iterate_succ_apply' _ _ _ + +theorem stepIter_succ' (t : ℕ) (f : G.V → ℝ) : + G.stepIter (t + 1) f = G.stepIter t (G.step f) := + Function.iterate_succ_apply _ _ _ + +theorem sum_stepIter (t : ℕ) (f : G.V → ℝ) : + ∑ v : G.V, G.stepIter t f v = ∑ v : G.V, f v := by + induction t with + | zero => simp + | succ t ih => rw [stepIter_succ, G.sum_step, ih] + +/-- **The walk operator is a contraction.** Averaging can only shrink the +Euclidean norm — this is Cauchy–Schwarz on each vertex's average, summed with +`sum_nbr`. It holds for *every* regular graph, with no spectral assumption, and +is what lets a graph be combined with an expander: the graph's own part of the +combined walk contributes at most its full weight. -/ +theorem sum_sq_step_le (f : G.V → ℝ) : + (∑ v : G.V, (G.step f v) ^ 2) ≤ ∑ v : G.V, (f v) ^ 2 := by + have hd : (0 : ℝ) < (G.deg : ℝ) := by + have := G.deg_pos + positivity + have hpt : ∀ v : G.V, (G.step f v) ^ 2 ≤ (∑ i : G.D, (f (G.nbr v i)) ^ 2) / (G.deg : ℝ) := by + intro v + have hcs : (∑ i : G.D, f (G.nbr v i)) ^ 2 + ≤ (G.deg : ℝ) * ∑ i : G.D, (f (G.nbr v i)) ^ 2 := by + have h := sq_sum_le_card_mul_sum_sq (s := (Finset.univ : Finset G.D)) + (f := fun i => f (G.nbr v i)) + rwa [Finset.card_univ, card_eq_deg] at h + rw [step, div_pow, div_le_div_iff₀ (by positivity) hd] + calc (∑ i : G.D, f (G.nbr v i)) ^ 2 * (G.deg : ℝ) + ≤ ((G.deg : ℝ) * ∑ i : G.D, (f (G.nbr v i)) ^ 2) * (G.deg : ℝ) := by + exact mul_le_mul_of_nonneg_right hcs (le_of_lt hd) + _ = (∑ i : G.D, (f (G.nbr v i)) ^ 2) * (G.deg : ℝ) ^ 2 := by ring + calc ∑ v : G.V, (G.step f v) ^ 2 + ≤ ∑ v : G.V, (∑ i : G.D, (f (G.nbr v i)) ^ 2) / (G.deg : ℝ) := + Finset.sum_le_sum fun v _ => hpt v + _ = (∑ v : G.V, ∑ i : G.D, (f (G.nbr v i)) ^ 2) / (G.deg : ℝ) := by + rw [Finset.sum_div] + _ = ((G.deg : ℝ) * ∑ v : G.V, (f v) ^ 2) / (G.deg : ℝ) := by + rw [G.sum_nbr (fun v => (f v) ^ 2)] + _ = ∑ v : G.V, (f v) ^ 2 := by field_simp + +/-- `G` has spectral gap at least `1 - lam`: the walk operator contracts every +mean-zero function by a factor `lam` in the Euclidean norm, stated on squared +norms so that no square roots are needed. -/ +def SpectralBound (G : RegGraph) (lam : ℝ) : Prop := + ∀ f : G.V → ℝ, (∑ v : G.V, f v) = 0 → + (∑ v : G.V, (G.step f v) ^ 2) ≤ lam ^ 2 * ∑ v : G.V, (f v) ^ 2 + +/-- A weaker contraction factor is still a contraction factor. -/ +theorem SpectralBound.mono {G : RegGraph} {lam lam' : ℝ} (h : G.SpectralBound lam) + (h0 : 0 ≤ lam) (hle : lam ≤ lam') : G.SpectralBound lam' := by + intro f hf + refine le_trans (h f hf) (mul_le_mul_of_nonneg_right ?_ (by positivity)) + exact pow_le_pow_left₀ h0 hle 2 + +/-- Every graph contracts the empty family of mean-zero functions: a graph with +no vertices has any contraction factor. -/ +theorem spectralBound_of_isEmpty {G : RegGraph} (h : IsEmpty G.V) (lam : ℝ) : + G.SpectralBound lam := by + intro f _ + have he : (Finset.univ : Finset G.V) = ∅ := Finset.univ_eq_empty + rw [he, Finset.sum_empty, Finset.sum_empty, mul_zero] + +/-- The contraction self-composes: `t` steps contract a mean-zero function by +`lam ^ t`, i.e. `lam ^ (2 * t)` in squared norm. -/ +theorem sum_sq_stepIter_le {lam : ℝ} (h : G.SpectralBound lam) (t : ℕ) (f : G.V → ℝ) + (hf : (∑ v : G.V, f v) = 0) : + (∑ v : G.V, (G.stepIter t f v) ^ 2) ≤ lam ^ (2 * t) * ∑ v : G.V, (f v) ^ 2 := by + induction t with + | zero => simp + | succ t ih => + have hzero : (∑ v : G.V, G.stepIter t f v) = 0 := by rw [G.sum_stepIter, hf] + have hstep := h (G.stepIter t f) hzero + have hpow : (0 : ℝ) ≤ lam ^ 2 := by positivity + calc ∑ v : G.V, (G.stepIter (t + 1) f v) ^ 2 + = ∑ v : G.V, (G.step (G.stepIter t f) v) ^ 2 := by rw [stepIter_succ] + _ ≤ lam ^ 2 * ∑ v : G.V, (G.stepIter t f v) ^ 2 := hstep + _ ≤ lam ^ 2 * (lam ^ (2 * t) * ∑ v : G.V, (f v) ^ 2) := + mul_le_mul_of_nonneg_left ih hpow + _ = lam ^ (2 * (t + 1)) * ∑ v : G.V, (f v) ^ 2 := by + rw [← mul_assoc, ← pow_add]; ring_nf + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SecondMoment.lean b/Complexitylib/Classes/PCP/Internal/SecondMoment.lean new file mode 100644 index 00000000..ba47cd7b --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SecondMoment.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Mathlib.Algebra.Order.BigOperators.Ring.Finset +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Data.Real.Basic +public import Mathlib.Tactic.Positivity +public import Mathlib.Tactic.Linarith + +/-! +# A second-moment support bound + +The Paley–Zygmund style inequality behind Dinur's powering estimate: a +nonnegative random variable is nonzero on a set at least as large as the square +of its mean over its second moment. Written with sums rather than expectations, +so that the normalising cardinality cancels on its own: + +`(∑ N) ^ 2 ≤ |support N| · ∑ N ^ 2` + +In the powering analysis `N` counts how many *faulty* edges a random walk +traverses. The first moment is proportional to the gap, the second moment is +controlled by the expander mixing lemma, and this inequality converts the two +into a lower bound on the probability that the walk meets a faulty edge at all +— which is what the powered constraint detects. + +## Main results + +- `sq_sum_le_card_support_mul_sum_sq` — the inequality above +- `sq_sum_div_sum_sq_le_card_support` — its ratio form +- `card_ge_of_moments` — Paley–Zygmund in counting form +-/ + +@[expose] public section + +namespace Complexity + +open Classical in +/-- **Second-moment support bound.** The square of a sum is at most the size of +the summand's support times the sum of squares. -/ +theorem sq_sum_le_card_support_mul_sum_sq {ι : Type*} [Fintype ι] (N : ι → ℝ) : + (∑ i, N i) ^ 2 ≤ ((Finset.univ.filter fun i => N i ≠ 0).card : ℝ) * ∑ i, (N i) ^ 2 := by + classical + have hcross : ∑ i, (if N i ≠ 0 then (1 : ℝ) else 0) * N i = ∑ i, N i := by + refine Finset.sum_congr rfl fun i _ => ?_ + by_cases h : N i = 0 <;> simp [h] + have hfsq : ∑ i, (if N i ≠ 0 then (1 : ℝ) else 0) ^ 2 + = ((Finset.univ.filter fun i => N i ≠ 0).card : ℝ) := by + rw [Finset.card_filter] + push_cast + refine Finset.sum_congr rfl fun i _ => ?_ + by_cases h : N i = 0 <;> simp [h] + have hcs := Finset.sum_mul_sq_le_sq_mul_sq Finset.univ + (fun i => if N i ≠ 0 then (1 : ℝ) else 0) N + rwa [hcross, hfsq] at hcs + +open Classical in +/-- The ratio form: the support is at least the mean-square ratio. -/ +theorem sq_sum_div_sum_sq_le_card_support {ι : Type*} [Fintype ι] (N : ι → ℝ) + (h : 0 < ∑ i, (N i) ^ 2) : + (∑ i, N i) ^ 2 / (∑ i, (N i) ^ 2) + ≤ ((Finset.univ.filter fun i => N i ≠ 0).card : ℝ) := by + rw [div_le_iff₀ h] + exact sq_sum_le_card_support_mul_sum_sq N + +open Classical in +/-- **Paley–Zygmund, in counting form.** If a nonnegative count has first moment +at least `A` and second moment at most `B`, then at least `A ^ 2 / B` of the +indices carry a nonzero count. Any `S` containing the support inherits the +bound — in the powering argument `S` is the set of unsatisfied constraints and +the count is the number of crossings that break one. -/ +theorem card_ge_of_moments {ι : Type*} [Fintype ι] (N : ι → ℝ) (S : Finset ι) + (hsupp : ∀ i, N i ≠ 0 → i ∈ S) {A B : ℝ} (hA0 : 0 ≤ A) (hA : A ≤ ∑ i, N i) + (hB : ∑ i, (N i) ^ 2 ≤ B) (hB0 : 0 < B) : + A ^ 2 / B ≤ (S.card : ℝ) := by + classical + have h1 := sq_sum_le_card_support_mul_sum_sq N + have h2 : ((Finset.univ.filter fun i => N i ≠ 0).card : ℝ) ≤ (S.card : ℝ) := by + have hsub : (Finset.univ.filter fun i => N i ≠ 0) ⊆ S := by + intro i hi + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hi + exact hsupp i hi + exact_mod_cast Finset.card_le_card hsub + have h3 : A ^ 2 ≤ (∑ i, N i) ^ 2 := by nlinarith [hA, hA0] + have h4 : (0 : ℝ) ≤ ∑ i, (N i) ^ 2 := Finset.sum_nonneg fun i _ => sq_nonneg _ + have h5 : A ^ 2 ≤ (S.card : ℝ) * B := by + calc A ^ 2 ≤ (∑ i, N i) ^ 2 := h3 + _ ≤ ((Finset.univ.filter fun i => N i ≠ 0).card : ℝ) * ∑ i, (N i) ^ 2 := h1 + _ ≤ (S.card : ℝ) * B := by + refine mul_le_mul h2 hB h4 ?_ + positivity + rw [div_le_iff₀ hB0] + exact h5 + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SelfLoops.lean b/Complexitylib/Classes/PCP/Internal/SelfLoops.lean new file mode 100644 index 00000000..664f2b14 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SelfLoops.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.RegCSP +public import Complexitylib.Classes.PCP.Internal.Union +public import Complexitylib.Classes.PCP.Internal.WalkPath + +/-! +# Adding self-loops + +Powering names a vertex within distance `k ≤ h` of `v` by a length-`h` walk that +takes `k` real steps and then stays put, so the graph it runs on must have a +self-loop at every vertex (`RegGraph.Loops`). This module adds them. + +A self-loop at every vertex is itself a `RegGraph` — `loopGraph`, of degree one, +whose rotation map is the identity — so adding loops is just `union` with it, +and the spectral bound comes free from `spectralBound_union`: the loops +contribute their full weight `1` and the original graph its `lam`, giving +`(1 + deg · lam) / (1 + deg)`, still below one. + +On the constraint side the loops carry the trivially true constraint. They are +never violated, so the number of broken darts is unchanged while the number of +darts grows by a factor `(deg + 1) / deg`; the value is scaled by exactly +`deg / (deg + 1)`, which `unsatFrac_addLoops` records. + +## Main definitions + +- `RegGraph.loopGraph` — one self-loop at every vertex +- `RegGraph.addLoops`, `RegGraph.addLoopsLoops` — the graph with loops, and its + canonical `Loops` +- `RegCSP.addLoops` — the constraint system with loops + +## Main results + +- `RegGraph.deg_addLoops`, `RegGraph.spectralBound_addLoops` +- `RegCSP.unsatFrac_addLoops`, `unsatVal_addLoops` — the value scales by + `deg / (deg + 1)` +- `RegCSP.satisfiable_addLoops_iff` +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +/-- The graph with exactly one self-loop at each vertex. -/ +def loopGraph (V : Type) [DecidableEq V] [Fintype V] : RegGraph where + V := V + D := Unit + decEqV := inferInstance + decEqD := inferInstance + fintypeV := inferInstance + fintypeD := inferInstance + nonemptyD := ⟨()⟩ + rot p := p + rot_involutive _ := rfl + +@[simp] theorem V_loopGraph (V : Type) [DecidableEq V] [Fintype V] : + (loopGraph V).V = V := rfl + +@[simp] theorem deg_loopGraph (V : Type) [DecidableEq V] [Fintype V] : + (loopGraph V).deg = 1 := Fintype.card_unit + +variable (G : RegGraph) + +/-- `G` with a self-loop added at every vertex. -/ +def addLoops : RegGraph := union (loopGraph G.V) G (Equiv.refl G.V) + +@[simp] theorem V_addLoops : G.addLoops.V = G.V := rfl + +@[simp] theorem order_addLoops : G.addLoops.order = G.order := rfl + +@[simp] theorem deg_addLoops : G.addLoops.deg = 1 + G.deg := by + rw [addLoops, deg_union, deg_loopGraph] + +/-- The canonical self-loop at each vertex of `G.addLoops`. -/ +def addLoopsLoops : G.addLoops.Loops where + loop _ := Sum.inl () + rot_loop _ := rfl + +/-- Adding loops keeps a spectral bound below one. -/ +theorem spectralBound_addLoops {lam : ℝ} (hlam : 0 ≤ lam) (h : G.SpectralBound lam) : + G.addLoops.SpectralBound ((1 + (G.deg : ℝ) * lam) / (1 + (G.deg : ℝ))) := by + have hu := spectralBound_union (loopGraph G.V) G (Equiv.refl G.V) hlam h + rw [deg_loopGraph] at hu + simpa using hu + +theorem addLoops_bound_lt_one {lam : ℝ} (hlam1 : lam < 1) : + (1 + (G.deg : ℝ) * lam) / (1 + (G.deg : ℝ)) < 1 := by + have hd : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity + rw [div_lt_one (by positivity)] + nlinarith + +end RegGraph + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) + +/-- `R` with a trivially satisfied self-loop added at every vertex. -/ +def addLoops : RegCSP α where + graph := R.graph.addLoops + rel v d a b := + match d with + | Sum.inl _ => true + | Sum.inr i => R.rel v i a b + +@[simp] theorem graph_addLoops : R.addLoops.graph = R.graph.addLoops := rfl + +/-- The broken darts are unchanged: only the original constraints can fail. -/ +theorem card_unsatDarts_addLoops (a : R.Assignment) : + (R.addLoops.unsatDarts a).card = (R.unsatDarts a).card := by + classical + refine (Finset.card_bij (fun q _ => ((q.1, Sum.inr q.2) : R.addLoops.Dart)) ?_ ?_ ?_).symm + · intro q hq + rw [mem_unsatDarts] at hq ⊢ + intro hcon + exact hq hcon + · intro q _ q' _ heq + have h1 : q.1 = q'.1 := congrArg (fun r => (r.1 : R.graph.V)) heq + have h2 : Sum.inr q.2 = (Sum.inr q'.2 : Unit ⊕ R.graph.D) := + congrArg (fun r => (r.2 : Unit ⊕ R.graph.D)) heq + exact Prod.ext h1 (Sum.inr.inj h2) + · rintro ⟨v, _ | i⟩ hq + · exfalso + rw [mem_unsatDarts] at hq + exact hq rfl + · refine ⟨(v, i), ?_, rfl⟩ + rw [mem_unsatDarts] at hq ⊢ + intro hcon + exact hq hcon + +/-- Adding loops scales the value by `deg / (deg + 1)`. -/ +theorem unsatFrac_addLoops (a : R.Assignment) : + R.addLoops.unsatFrac a + = R.unsatFrac a * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + 1) := by + have hd : (0 : ℚ) < (R.graph.deg : ℚ) := by + have := R.graph.deg_pos + exact_mod_cast this + have hcards := R.card_unsatDarts_addLoops a + rcases Nat.eq_zero_or_pos R.graph.order with hz | hz + · -- no vertices: no darts at all + have hempty : (R.unsatDarts a).card = 0 := by + have hle : (R.unsatDarts a).card ≤ R.graph.order * R.graph.deg := + R.card_unsatDarts_le a + rw [hz] at hle + omega + have hempty' : (R.addLoops.unsatDarts a).card = 0 := by rw [hcards, hempty] + rw [unsatFrac, unsatFrac, hempty, hempty'] + simp + · have hzq : (0 : ℚ) < (R.graph.order : ℚ) := by exact_mod_cast hz + rw [unsatFrac, unsatFrac, hcards] + have hden : ((R.addLoops.graph.order * R.addLoops.graph.deg : ℕ) : ℚ) + = (R.graph.order : ℚ) * ((R.graph.deg : ℚ) + 1) := by + rw [graph_addLoops, RegGraph.order_addLoops, RegGraph.deg_addLoops] + push_cast + ring + rw [hden] + field_simp + push_cast + ring + +/-- The scaling passes to the value. -/ +theorem unsatVal_addLoops [Fintype α] [Nonempty α] : + R.addLoops.unsatVal = R.unsatVal * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + 1) := by + have hk : (0 : ℚ) ≤ (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + 1) := by positivity + obtain ⟨a, ha⟩ := R.exists_assignment_unsatFrac_eq_unsatVal + obtain ⟨b, hb⟩ := R.addLoops.exists_assignment_unsatFrac_eq_unsatVal + refine le_antisymm ?_ ?_ + · calc R.addLoops.unsatVal ≤ R.addLoops.unsatFrac a := R.addLoops.unsatVal_le a + _ = R.unsatFrac a * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + 1) := R.unsatFrac_addLoops a + _ = R.unsatVal * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + 1) := by rw [ha] + · rw [← hb, R.unsatFrac_addLoops b, mul_div_assoc, mul_div_assoc] + exact mul_le_mul_of_nonneg_right (R.unsatVal_le b) hk + +theorem satisfiable_addLoops_iff : R.addLoops.Satisfiable ↔ R.Satisfiable := by + constructor + · rintro ⟨a, ha⟩ + refine ⟨a, fun p => ?_⟩ + have h := ha (p.1, Sum.inr p.2) + rw [Satisfies, satisfies] at h ⊢ + exact h + · rintro ⟨a, ha⟩ + refine ⟨a, ?_⟩ + rintro ⟨v, _ | i⟩ + · rw [Satisfies, satisfies] + rfl + · have h := ha (v, i) + rw [Satisfies, satisfies] at h ⊢ + exact h + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SizedExpander.lean b/Complexitylib/Classes/PCP/Internal/SizedExpander.lean new file mode 100644 index 00000000..dca0d333 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SizedExpander.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ZigZagTower + +/-! +# Expanders of approximately a given size + +The zig-zag tower produces expanders only at the sizes `(deg ^ 4) ^ (k + 1)`, +which are far apart. `Pad` shows that this is no obstacle: a constraint graph +may be enlarged with isolated vertices, at no cost to anything the amplification +measures, so it is enough to have an expander on *some* size between `n` and a +constant multiple of `n`. + +This module records that weaker interface and builds one from a `ZigZagBase`, +by taking the first member of the tower large enough. Minimality of the choice +is what bounds the overshoot: the previous member was too small, and each round +multiplies the size by exactly `deg ^ 4`. + +## Main definitions + +- `Complexity.SizedExpanderFamily` — expanders of approximately prescribed size +- `Complexity.ZigZagBase.toSized` — the family the tower gives + +## Main results + +- `Complexity.ZigZagBase.order_toSized_le` — the overshoot is a constant factor +-/ + +@[expose] public section + +namespace Complexity + +/-- A family of constant-degree expanders, one of approximately each size: the +graph for `n` has between `n` and `factor * n` vertices. -/ +structure SizedExpanderFamily where + /-- The common degree. -/ + degree : ℕ + /-- The degree is positive. -/ + degree_pos : 0 < degree + /-- How far the size may overshoot. -/ + factor : ℕ + /-- The graph provided for a requested size. -/ + graph : ℕ → RegGraph + /-- Every member has the common degree. -/ + deg_graph : ∀ n, (graph n).deg = degree + /-- It is at least as large as requested. -/ + order_ge : ∀ n, n ≤ (graph n).order + /-- And not too much larger. -/ + order_le : ∀ n, 1 ≤ n → (graph n).order ≤ factor * n + /-- The uniform contraction factor. -/ + lam : ℝ + /-- It is nonnegative. -/ + lam_nonneg : 0 ≤ lam + /-- And below one. -/ + lam_lt_one : lam < 1 + /-- Every member contracts mean-zero functions by `lam`. -/ + spectral : ∀ n, (graph n).SpectralBound lam + +namespace ZigZagBase + +variable (B : ZigZagBase) (hd : 1 < B.base.deg) + +/-- The first index whose member is large enough. -/ +noncomputable def towerIndex (n : ℕ) : ℕ := + Nat.find (B.exists_order_ge hd n) + +theorem le_order_towerIndex (n : ℕ) : + n ≤ (tower B (B.towerIndex hd n)).graph.order := + Nat.find_spec (B.exists_order_ge hd n) + +theorem order_towerIndex_le (n : ℕ) (hn : 1 ≤ n) : + (tower B (B.towerIndex hd n)).graph.order ≤ B.base.deg ^ 4 * n := by + classical + rcases Nat.eq_zero_or_pos (B.towerIndex hd n) with h0 | hpos + · rw [towerIndex] at h0 ⊢ + rw [h0, order_tower] + calc (B.base.deg ^ 4) ^ (0 + 1) = B.base.deg ^ 4 := by ring + _ ≤ B.base.deg ^ 4 * n := Nat.le_mul_of_pos_right _ hn + · obtain ⟨m, hm⟩ : ∃ m, B.towerIndex hd n = m + 1 := ⟨B.towerIndex hd n - 1, by omega⟩ + have hfind : Nat.find (B.exists_order_ge hd n) = m + 1 := hm + have hlt : ¬ n ≤ (tower B m).graph.order := + Nat.find_min (B.exists_order_ge hd n) (m := m) (by rw [hfind]; omega) + have hmlt : (tower B m).graph.order < n := by omega + rw [hm, order_tower] + have hprev : (B.base.deg ^ 4) ^ (m + 1) < n := by + rw [← order_tower] + exact hmlt + calc (B.base.deg ^ 4) ^ (m + 1 + 1) = B.base.deg ^ 4 * (B.base.deg ^ 4) ^ (m + 1) := by + ring + _ ≤ B.base.deg ^ 4 * n := Nat.mul_le_mul_left _ (le_of_lt hprev) + +/-- **The tower, as a size-flexible family.** -/ +noncomputable def toSized : SizedExpanderFamily where + degree := B.base.deg ^ 2 + degree_pos := by + have := B.base.deg_pos + positivity + factor := B.base.deg ^ 4 + graph := fun n => (tower B (B.towerIndex hd n)).graph + deg_graph := fun n => deg_tower B _ + order_ge := B.le_order_towerIndex hd + order_le := B.order_towerIndex_le hd + lam := 2 / 5 + lam_nonneg := by norm_num + lam_lt_one := by norm_num + spectral := fun n => spectral_tower B _ + +/-! ### The member used for a requested size -/ + +/-- The tower member chosen for size `n`: the first one at least twice as big, +which is the overshoot the merge needs. -/ +noncomputable def fitIndex (n : ℕ) : ℕ := B.towerIndex hd (2 * n) + +theorem two_mul_le_order_fit (n : ℕ) : + 2 * n ≤ (tower B (B.fitIndex hd n)).graph.order := + B.le_order_towerIndex hd (2 * n) + +theorem order_fit_le (n : ℕ) (hn : 1 ≤ n) : + (tower B (B.fitIndex hd n)).graph.order ≤ (2 * B.base.deg ^ 4) * n := by + have h := B.order_towerIndex_le hd (2 * n) (by omega) + calc (tower B (B.fitIndex hd n)).graph.order ≤ B.base.deg ^ 4 * (2 * n) := h + _ = (2 * B.base.deg ^ 4) * n := by ring + +theorem deg_fit (n : ℕ) : (tower B (B.fitIndex hd n)).graph.deg = B.base.deg ^ 2 := + deg_tower B _ + +theorem spectral_fit (n : ℕ) : + (tower B (B.fitIndex hd n)).graph.SpectralBound (2 / 5) := + spectral_tower B _ + +end ZigZagBase + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean b/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean new file mode 100644 index 00000000..f256de21 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.SizedExpander +public import Complexitylib.Classes.PCP.Internal.PadCSP +public import Complexitylib.Classes.PCP.Internal.ExpanderizeCSP + +/-! +# Expanderizing with an approximately sized family + +`ExpanderizeCSP` superposes an expander on a constraint system, which asks for +one on exactly the system's vertex count. The zig-zag tower offers only +approximate sizes, so the system is first enlarged to meet the expander: +`PadCSP` shows the enlargement costs only the ratio of the two vertex counts, +and that ratio is bounded by the family's `factor`. + +## Main definitions + +- `Complexity.RegCSP.sizedExpanderize` — pad, then superpose + +## Main results + +- `Complexity.RegCSP.spectralBound_sizedExpanderize` — it has a spectral gap +- `Complexity.RegCSP.satisfiable_sizedExpanderize_iff` — completeness +- `Complexity.RegCSP.unsatVal_sizedExpanderize_ge` — soundness, with the two + constant losses made explicit +-/ + +@[expose] public section + +namespace Complexity + +namespace RegCSP + +variable {α : Type} (R : RegCSP α) (F : SizedExpanderFamily) + +/-- The size the family offers for this system. -/ +def fitSize : ℕ := (F.graph R.graph.order).order + +theorem le_fitSize : R.graph.order ≤ R.fitSize F := F.order_ge _ + +/-- The system, enlarged to the size the family offers. -/ +def padded : RegCSP α := R.padVerts (R.fitSize F - R.graph.order) + +theorem order_padded : (R.padded F).graph.order = R.fitSize F := by + rw [padded, graph_padVerts, RegGraph.order_padVerts] + have := R.le_fitSize F + omega + +@[simp] theorem deg_padded : (R.padded F).graph.deg = R.graph.deg := rfl + +/-- The family member's vertices name the enlarged system's. -/ +noncomputable def fitEquiv : (F.graph R.graph.order).V ≃ (R.padded F).graph.V := + Fintype.equivOfCardEq (by + show (F.graph R.graph.order).order = (R.padded F).graph.order + rw [order_padded] + rfl) + +/-- **Expanderization against an approximately sized family.** -/ +noncomputable def sizedExpanderize : RegCSP α := + (R.padded F).addTrivial (F.graph R.graph.order) (R.fitEquiv F) + +@[simp] theorem deg_sizedExpanderize : + (R.sizedExpanderize F).graph.deg = R.graph.deg + F.degree := by + rw [sizedExpanderize, graph_addTrivial, RegGraph.deg_union, deg_padded, F.deg_graph] + +/-- **The expanderized system has a spectral gap.** -/ +theorem spectralBound_sizedExpanderize : + (R.sizedExpanderize F).graph.SpectralBound + (((R.graph.deg : ℝ) + (F.degree : ℝ) * F.lam) + / ((R.graph.deg : ℝ) + (F.degree : ℝ))) := by + have h := RegGraph.spectralBound_union (R.padded F).graph (F.graph R.graph.order) + (R.fitEquiv F) F.lam_nonneg (F.spectral R.graph.order) + rw [F.deg_graph] at h + exact h + +/-- The bound is below one, which is what powering needs. -/ +theorem sizedExpanderize_bound_lt_one : + ((R.graph.deg : ℝ) + (F.degree : ℝ) * F.lam) + / ((R.graph.deg : ℝ) + (F.degree : ℝ)) < 1 := by + have hdR : (0 : ℝ) < (R.graph.deg : ℝ) := by + have := R.graph.deg_pos + positivity + have hdF : (0 : ℝ) < (F.degree : ℝ) := by exact_mod_cast F.degree_pos + rw [div_lt_one (by positivity)] + nlinarith [F.lam_lt_one, F.lam_nonneg] + +/-- **Completeness**: enlarging and superposing preserves satisfiability. -/ +theorem satisfiable_sizedExpanderize_iff [Nonempty α] : + (R.sizedExpanderize F).Satisfiable ↔ R.Satisfiable := by + rw [sizedExpanderize, satisfiable_addTrivial_iff, padded, satisfiable_padVerts_iff] + +/-- **Soundness**: the value survives, down to the two constant factors — the +dilution from enlarging, and the dilution from the superposed degree. -/ +theorem unsatVal_sizedExpanderize_ge [Fintype α] [Nonempty α] [DecidableEq α] + (hord : 0 < R.graph.order) : + R.unsatVal * ((R.graph.order : ℕ) : ℚ) / ((R.fitSize F : ℕ) : ℚ) + * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (F.degree : ℚ)) + ≤ (R.sizedExpanderize F).unsatVal := by + have hk : R.graph.order + (R.fitSize F - R.graph.order) = R.fitSize F := by + have := R.le_fitSize F + omega + have hge := R.unsatVal_padVerts_ge (R.fitSize F - R.graph.order) hord + rw [hk] at hge + have hde : (0 : ℚ) < (R.graph.deg : ℚ) + (F.degree : ℚ) := by + have h1 : (0 : ℚ) < (R.graph.deg : ℚ) := by + have := R.graph.deg_pos + exact_mod_cast this + have h2 : (0 : ℚ) ≤ (F.degree : ℚ) := by positivity + linarith + have hd : (0 : ℚ) ≤ (R.graph.deg : ℚ) := by positivity + rw [sizedExpanderize, unsatVal_addTrivial, deg_padded, F.deg_graph] + rw [div_le_div_iff_of_pos_right hde] + exact mul_le_mul_of_nonneg_right hge hd + +end RegCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean b/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean new file mode 100644 index 00000000..bfe9ed80 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PosScan +public import Complexitylib.Classes.EventProb + +/-! +# Running a verifier twice + +Dinur's amplification leaves a constant gap, which need not be as large as the +one half the `PCP` classes ask for. Independent repetition closes that: two runs +on independent coins reject a non-member with probability `1 - (1 - s)²`, and +repeating the doubling a constant number of times drives the error below any +threshold. + +The coin string of the doubled verifier is split by the *per-run* coin count, +a function of the input length, rather than by halving the string. That keeps +the split point polynomial-time computable from the input alone, which is what +the `positions` and `verdict` conditions need. + +## Main definitions + +- `Complexity.PCPVerifier.squareAt` — two independent runs +- `Complexity.PCPWith` — the class with an explicit soundness error + +## Main results + +- `Complexity.PCPVerifier.positions_squareAt`, + `Complexity.PCPVerifier.mem_verdict_squareAt` — what the doubled verifier does +- `Complexity.PCPWith_square`, `Complexity.mem_PCP_of_PCPWith` — any soundness + error below one can be driven under one half +-/ + +@[expose] public section + +namespace Complexity + +namespace PCPVerifier + +variable (V : PCPVerifier) (t : ℕ → ℕ) + +/-- The coins of the first run. -/ +def fstCoins (t : ℕ → ℕ) (x ρ : List Bool) : List Bool := ρ.take (t x.length) + +/-- The coins of the second run. -/ +def sndCoins (t : ℕ → ℕ) (x ρ : List Bool) : List Bool := ρ.drop (t x.length) + +/-- The queries of two independent runs, one after the other. -/ +def sqPositions (x ρ : List Bool) : List ℕ := + V.positions x (fstCoins t x ρ) ++ V.positions x (sndCoins t x ρ) + +/-- The input, out of a verdict argument `pair (pair x ρ) a`. -/ +def vX (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock z) + +/-- The coins, out of a verdict argument. -/ +def vR (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock z) + +/-- The answers, out of a verdict argument. -/ +def vA (z : List Bool) : List Bool := Cobham.sndBlock z + +/-- The verdict of the doubled verifier: both runs accept. The answers of the +first run are the first `|positions|` of them. -/ +def sqVerdict : Language := + {z | pair (pair (vX z) (fstCoins t (vX z) (vR z))) + ((vA z).take (V.positions (vX z) (fstCoins t (vX z) (vR z))).length) ∈ V.verdict + ∧ pair (pair (vX z) (sndCoins t (vX z) (vR z))) + ((vA z).drop (V.positions (vX z) (fstCoins t (vX z) (vR z))).length) ∈ V.verdict} + +/-! ### The pieces are polynomial time -/ + +section FP + +variable {V t} +variable {f : List Bool → List Bool} +variable (ht : (fun x : List Bool => List.replicate (t x.length) true) ∈ FP) + +theorem vX_mem_FP : vX ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +theorem vR_mem_FP : vR ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + +theorem vA_mem_FP : vA ∈ FP := Cobham.sndBlock_mem_FP + +include ht in +theorem fstCoinsFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => fstCoins t (a z) (b z)) ∈ FP := by + have hlen : (fun z => List.replicate (t (a z).length) true) ∈ FP := by + have := mem_FP_comp ha ht + simpa [Function.comp] using this + have := Cobham.takeLenFn_mem_FP hlen hb + refine mem_FP_of_eq this fun z => ?_ + rw [fstCoins, List.length_replicate] + +include ht in +theorem sndCoinsFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => sndCoins t (a z) (b z)) ∈ FP := by + have hlen : (fun z => List.replicate (t (a z).length) true) ∈ FP := by + have := mem_FP_comp ha ht + simpa [Function.comp] using this + have := dropLenFn_mem_FP hlen hb + refine mem_FP_of_eq this fun z => ?_ + rw [sndCoins, List.length_replicate] + +include ht in +/-- The doubled verifier's query list is polynomial-time computable. -/ +theorem sqPositions_mem (hf : f ∈ FP) + (hfspec : ∀ x rr : List Bool, + f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) : + ∃ g ∈ FP, ∀ x ρ : List Bool, + g (pair x ρ) = DataEncode.bitstringEncode (sqPositions V t x ρ) := by + have hx : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP + have hr : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have h1 : (fun z : List Bool => f (pair (Cobham.fstBlock z) + (fstCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ∈ FP := by + have := mem_FP_comp + (Cobham.pairFn_mem_FP hx (fstCoinsFn_mem_FP ht hx hr)) hf + simpa [Function.comp] using this + have h2 : (fun z : List Bool => f (pair (Cobham.fstBlock z) + (sndCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ∈ FP := by + have := mem_FP_comp + (Cobham.pairFn_mem_FP hx (sndCoinsFn_mem_FP ht hx hr)) hf + simpa [Function.comp] using this + refine ⟨fun z => false :: (posInner (f (pair (Cobham.fstBlock z) + (fstCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) + ++ posInner (f (pair (Cobham.fstBlock z) + (sndCoins t (Cobham.fstBlock z) (Cobham.sndBlock z))))) ++ [true], ?_, ?_⟩ + · have hcat := Cobham.appendFn_mem_FP (posInner_mem_FP h1) (posInner_mem_FP h2) + have hcons := mem_FP_comp hcat (Cobham.cons_mem_FP false) + have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) + refine mem_FP_of_eq this fun z => ?_ + simp [Function.comp] + · intro x ρ + show false :: (posInner (f (pair (Cobham.fstBlock (pair x ρ)) + (fstCoins t (Cobham.fstBlock (pair x ρ)) (Cobham.sndBlock (pair x ρ))))) + ++ posInner (f (pair (Cobham.fstBlock (pair x ρ)) + (sndCoins t (Cobham.fstBlock (pair x ρ)) (Cobham.sndBlock (pair x ρ)))))) ++ [true] + = _ + rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair, hfspec, hfspec, sqPositions, + bitstringEncode_append] + +include ht in +/-- The doubled verifier's verdict is polynomial-time decidable. -/ +theorem sqVerdict_mem_P (hf : f ∈ FP) + (hfspec : ∀ x rr : List Bool, + f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) : + sqVerdict V t ∈ P := by + have hc1 : (fun z => fstCoins t (vX z) (vR z)) ∈ FP := + fstCoinsFn_mem_FP ht vX_mem_FP vR_mem_FP + have hc2 : (fun z => sndCoins t (vX z) (vR z)) ∈ FP := + sndCoinsFn_mem_FP ht vX_mem_FP vR_mem_FP + have hfv : (fun z => f (pair (vX z) (fstCoins t (vX z) (vR z)))) ∈ FP := by + have := mem_FP_comp (Cobham.pairFn_mem_FP vX_mem_FP hc1) hf + simpa [Function.comp] using this + have hn : (fun z => posCount (f (pair (vX z) (fstCoins t (vX z) (vR z))))) ∈ FP := + posCount_mem_FP hfv + have hnlen : ∀ z, (posCount (f (pair (vX z) (fstCoins t (vX z) (vR z))))).length + = (V.positions (vX z) (fstCoins t (vX z) (vR z))).length := by + intro z + rw [hfspec, posCount_eq, List.length_replicate] + have hA : (fun z => pair (pair (vX z) (fstCoins t (vX z) (vR z))) + ((vA z).take (V.positions (vX z) (fstCoins t (vX z) (vR z))).length)) ∈ FP := by + have := Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP vX_mem_FP hc1) + (Cobham.takeLenFn_mem_FP hn vA_mem_FP) + refine mem_FP_of_eq this fun z => ?_ + rw [hnlen] + have hB : (fun z => pair (pair (vX z) (sndCoins t (vX z) (vR z))) + ((vA z).drop (V.positions (vX z) (fstCoins t (vX z) (vR z))).length)) ∈ FP := by + have := Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP vX_mem_FP hc2) + (dropLenFn_mem_FP hn vA_mem_FP) + refine mem_FP_of_eq this fun z => ?_ + rw [hnlen] + exact P_inter (mem_P_preimage hA V.verdict_mem) (mem_P_preimage hB V.verdict_mem) + +end FP + +/-- **Two independent runs**, as a verifier in its own right. -/ +noncomputable def squareAt (V : PCPVerifier) (t : ℕ → ℕ) + (ht : (fun x : List Bool => List.replicate (t x.length) true) ∈ FP) : PCPVerifier where + positions := V.sqPositions t + positions_mem := by + obtain ⟨f, hf, hfspec⟩ := V.positions_mem + exact sqPositions_mem ht hf hfspec + verdict := V.sqVerdict t + verdict_mem := by + obtain ⟨f, hf, hfspec⟩ := V.positions_mem + exact sqVerdict_mem_P ht hf hfspec + +@[simp] theorem positions_squareAt (ht : (fun x : List Bool => + List.replicate (t x.length) true) ∈ FP) (x ρ : List Bool) : + (V.squareAt t ht).positions x ρ = V.sqPositions t x ρ := rfl + +theorem mem_verdict_squareAt (ht : (fun x : List Bool => + List.replicate (t x.length) true) ∈ FP) (z : List Bool) : + z ∈ (V.squareAt t ht).verdict ↔ z ∈ V.sqVerdict t := Iff.rfl + +/-! ### Splitting the coin string -/ + +theorem toList_take (a b : ℕ) (ρ : Fin (a + b) → Bool) : + (BitString.toList ρ).take a = BitString.toList (blockFst a b ρ) := by + refine List.ext_getElem (by simp) fun i h1 h2 => ?_ + have hi : i < a := by simpa using h2 + rw [List.getElem_take] + rw [BitString.getElem_toList ρ ⟨i, by omega⟩, + BitString.getElem_toList (blockFst a b ρ) ⟨i, hi⟩] + rfl + +theorem toList_drop (a b : ℕ) (ρ : Fin (a + b) → Bool) : + (BitString.toList ρ).drop a = BitString.toList (blockSnd a b ρ) := by + refine List.ext_getElem (by simp) fun i h1 h2 => ?_ + have hi : i < b := by simpa using h2 + rw [List.getElem_drop] + rw [BitString.getElem_toList ρ ⟨a + i, by omega⟩, + BitString.getElem_toList (blockSnd a b ρ) ⟨i, hi⟩] + rfl + +/-! ### What the doubled verifier accepts -/ + +theorem accepts_squareAt (ht : (fun x : List Bool => + List.replicate (t x.length) true) ∈ FP) (x π ρ : List Bool) : + (V.squareAt t ht).Accepts x π ρ + ↔ V.Accepts x π (fstCoins t x ρ) ∧ V.Accepts x π (sndCoins t x ρ) := by + have hlen : (answers π (V.positions x (fstCoins t x ρ))).length + = (V.positions x (fstCoins t x ρ)).length := by + rw [answers, List.length_map] + rw [Accepts, positions_squareAt, sqPositions, answers, List.map_append] + show _ ∈ V.sqVerdict t ↔ _ + rw [sqVerdict, Set.mem_setOf_eq] + simp only [vX, vR, vA, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [show List.map (fun i => π.getD i false) (V.positions x (fstCoins t x ρ)) + = answers π (V.positions x (fstCoins t x ρ)) from rfl, + show List.map (fun i => π.getD i false) (V.positions x (sndCoins t x ρ)) + = answers π (V.positions x (sndCoins t x ρ)) from rfl, + ← hlen, List.take_left, List.drop_left] + rfl + +open Classical in +theorem acceptEvent_squareAt (ht : (fun x : List Bool => + List.replicate (t x.length) true) ∈ FP) (x π : List Bool) {T : ℕ} + (hT : t x.length = T) : + (V.squareAt t ht).acceptEvent (T + T) x π + = Finset.univ.filter (fun ρ : Fin (T + T) → Bool => + V.Accepts x π (BitString.toList (blockFst T T ρ)) + ∧ V.Accepts x π (BitString.toList (blockSnd T T ρ))) := by + classical + ext ρ + simp only [acceptEvent, Finset.mem_filter, Finset.mem_univ, true_and] + rw [accepts_squareAt, fstCoins, sndCoins, hT, toList_take, toList_drop] + +open Classical in +theorem eventProb_acceptEvent_squareAt (ht : (fun x : List Bool => + List.replicate (t x.length) true) ∈ FP) (x π : List Bool) {T : ℕ} + (hT : t x.length = T) : + eventProb ((V.squareAt t ht).acceptEvent (T + T) x π) + = eventProb (V.acceptEvent T x π) * eventProb (V.acceptEvent T x π) := by + classical + rw [acceptEvent_squareAt V t ht x π hT] + rw [eventProb_block (P := fun σ : Fin T → Bool => V.Accepts x π (BitString.toList σ)) + (Q := fun σ : Fin T → Bool => V.Accepts x π (BitString.toList σ))] + rfl + +end PCPVerifier + +/-! ### Amplifying the class -/ + +/-- The `PCP` class with an explicit soundness error. -/ +def PCPWith (r q : ℕ → ℕ) (s : ℚ) : Set Language := + {L | ∃ V : PCPVerifier, V.QueryBounded q ∧ + (∀ x ∈ L, ∃ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) = 1) ∧ + (∀ x ∉ L, ∀ π : List Bool, eventProb (V.acceptEvent (r x.length) x π) ≤ s)} + +theorem PCPWith_half (r q : ℕ → ℕ) : PCPWith r q (1 / 2) = PCP r q := rfl + +/-- **Two runs square the error**, at twice the randomness and twice the +queries. -/ +theorem PCPWith_square {r q : ℕ → ℕ} {s : ℚ} (hs : 0 ≤ s) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + {L : Language} (hL : L ∈ PCPWith r q s) : + L ∈ PCPWith (fun n => r n + r n) (fun n => q n + q n) (s * s) := by + obtain ⟨V, hQ, hcomp, hsound⟩ := hL + refine ⟨V.squareAt r hr, ?_, ?_, ?_⟩ + · intro x ρ + rw [PCPVerifier.positions_squareAt, PCPVerifier.sqPositions, List.length_append] + exact Nat.add_le_add (hQ _ _) (hQ _ _) + · intro x hx + obtain ⟨π, hπ⟩ := hcomp x hx + refine ⟨π, ?_⟩ + rw [PCPVerifier.eventProb_acceptEvent_squareAt V r hr x π rfl, hπ] + norm_num + · intro x hx π + rw [PCPVerifier.eventProb_acceptEvent_squareAt V r hr x π rfl] + exact mul_le_mul (hsound x hx π) (hsound x hx π) (eventProb_nonneg _) hs + +/-! ### Driving the error below one half -/ + +theorem PCPWith_congr {r r' q q' : ℕ → ℕ} {s : ℚ} (hr : ∀ n, r n = r' n) + (hq : ∀ n, q n = q' n) : PCPWith r q s = PCPWith r' q' s := by + have h1 : r = r' := funext hr + have h2 : q = q' := funext hq + rw [h1, h2] + +theorem PCPWith_mono {r q : ℕ → ℕ} {s s' : ℚ} (h : s ≤ s') : + PCPWith r q s ⊆ PCPWith r q s' := by + rintro L ⟨V, hQ, hc, hsound⟩ + exact ⟨V, hQ, hc, fun x hx π => le_trans (hsound x hx π) h⟩ + +theorem constructible_double {r : ℕ → ℕ} + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) : + (fun x : List Bool => List.replicate (r x.length + r x.length) true) ∈ FP := by + have := Cobham.appendFn_mem_FP hr hr + refine mem_FP_of_eq this fun x => ?_ + rw [← List.replicate_add] + +/-- **Repeated doubling.** After `j` doublings the error is `s ^ (2 ^ j)`. -/ +theorem PCPWith_iterate (j : ℕ) : ∀ {r q : ℕ → ℕ} {s : ℚ}, 0 ≤ s → + (fun x : List Bool => List.replicate (r x.length) true) ∈ FP → + ∀ {L : Language}, L ∈ PCPWith r q s → + L ∈ PCPWith (fun n => 2 ^ j * r n) (fun n => 2 ^ j * q n) (s ^ 2 ^ j) := by + induction j with + | zero => + intro r q s _ _ L hL + rw [PCPWith_congr (r' := r) (q' := q) (fun n => by ring) (fun n => by ring)] + simpa using hL + | succ j ih => + intro r q s hs hr L hL + have hsq := PCPWith_square hs hr hL + have hstep := ih (s := s * s) (by positivity) (constructible_double hr) hsq + have hr' : ∀ n, 2 ^ j * (r n + r n) = 2 ^ (j + 1) * r n := by + intro n; ring + have hq' : ∀ n, 2 ^ j * (q n + q n) = 2 ^ (j + 1) * q n := by + intro n; ring + rw [PCPWith_congr hr' hq'] at hstep + have hpow : (s * s) ^ 2 ^ j = s ^ 2 ^ (j + 1) := by + rw [← sq, ← pow_mul, pow_succ] + ring_nf + rwa [hpow] at hstep + +/-- **Any error below one can be driven under one half.** -/ +theorem mem_PCP_of_PCPWith {r q : ℕ → ℕ} {s : ℚ} (hs0 : 0 ≤ s) (hs1 : s < 1) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + {L : Language} (hL : L ∈ PCPWith r q s) : + ∃ j : ℕ, L ∈ PCP (fun n => 2 ^ j * r n) (fun n => 2 ^ j * q n) := by + obtain ⟨m, hm⟩ := exists_pow_lt_of_lt_one (by norm_num : (0 : ℚ) < 1 / 2) hs1 + refine ⟨m, ?_⟩ + have hle : s ^ 2 ^ m ≤ s ^ m := by + refine pow_le_pow_of_le_one hs0 (le_of_lt hs1) ?_ + exact Nat.le_of_lt (Nat.lt_two_pow_self) + rw [← PCPWith_half] + exact PCPWith_mono (le_trans hle (le_of_lt hm)) (PCPWith_iterate m hs0 hr hL) + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/StripTrailing.lean b/Complexitylib/Classes/PCP/Internal/StripTrailing.lean new file mode 100644 index 00000000..6cd0b460 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/StripTrailing.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.BinToUnary +public import Complexitylib.Classes.Containments.Internal.IPLeaf + +/-! +# The canonical bits of a number + +`DataEncode` writes a natural number as `Nat.bits`, its little-endian bits with +no trailing zero. A fixed-width counter, which is what a polynomial-time machine +can produce, carries trailing zeros; dropping them is the missing step between +the two. + +Dropping trailing zeros is a right fold — what to do with a bit depends on +whether everything after it vanished — so `recFoldClamp` expresses it directly, +with no reversal. + +## Main definitions + +- `Complexity.stripTrailing` — drop trailing zeros + +## Main results + +- `Complexity.stripTrailing_eq_bits` — the result is `Nat.bits` of the value +- `Complexity.stripTrailing_mem_FP` — it is polynomial time +-/ + +@[expose] public section + +namespace Complexity + +/-- Drop trailing zeros from a little-endian bit string. -/ +def stripTrailing : List Bool → List Bool + | [] => [] + | false :: t => if stripTrailing t = [] then [] else false :: stripTrailing t + | true :: t => true :: stripTrailing t + +@[simp] theorem stripTrailing_nil : stripTrailing [] = [] := rfl + +theorem stripTrailing_false (t : List Bool) : + stripTrailing (false :: t) = + if stripTrailing t = [] then [] else false :: stripTrailing t := rfl + +theorem stripTrailing_true (t : List Bool) : + stripTrailing (true :: t) = true :: stripTrailing t := rfl + +theorem length_stripTrailing (l : List Bool) : (stripTrailing l).length ≤ l.length := by + induction l with + | nil => simp + | cons b t ih => + cases b + · rw [stripTrailing_false] + split + · simp + · simp only [List.length_cons] + omega + · rw [stripTrailing_true] + simp only [List.length_cons] + omega + +/-- **Dropping trailing zeros gives the canonical bits.** -/ +theorem stripTrailing_eq_bits (l : List Bool) : stripTrailing l = (binValLE l).bits := by + induction l with + | nil => rfl + | cons b t ih => + cases b + · rw [stripTrailing_false, ih, binValLE_cons_false] + by_cases h : (binValLE t).bits = [] + · rw [if_pos h] + have h0 : binValLE t = 0 := by + have hb := binValLE_bits (binValLE t) + rw [h] at hb + simpa using hb.symm + rw [h0] + simp + · rw [if_neg h] + have hne : binValLE t ≠ 0 := by + intro h0 + rw [h0, Nat.zero_bits] at h + exact h rfl + rw [Nat.bit0_bits _ hne] + · rw [stripTrailing_true, ih, binValLE_cons_true, Nat.bit1_bits] + +/-! ### Polynomial time -/ + +/-- The fold step on a zero. -/ +def stripZero (z : List Bool) : List Bool := + Cobham.selectHead (emptyFlag (Cobham.sndBlock (Cobham.fstBlock z))) [] + (false :: Cobham.sndBlock (Cobham.fstBlock z)) + +/-- The fold step on a one. -/ +def stripOne (z : List Bool) : List Bool := + true :: Cobham.sndBlock (Cobham.fstBlock z) + +theorem stripZero_mem_FP : stripZero ∈ FP := by + have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP h) (constFn_mem_FP []) + (mem_FP_comp h (Cobham.cons_mem_FP false)) + +theorem stripOne_mem_FP : stripOne ∈ FP := by + have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + exact mem_FP_comp h (Cobham.cons_mem_FP true) + +/-- The fold computes `stripTrailing`, as long as the clamp allows the answer. -/ +theorem recFoldClamp_stripTrailing (bound : ℕ) (W : List Bool) : + ∀ l : List Bool, l.length ≤ bound → + Cobham.recFoldClamp stripZero stripOne bound [] W l = stripTrailing l := by + intro l + induction l with + | nil => + intro _ + rw [Cobham.recFoldClamp] + simp + | cons b t ih => + intro hb + have hb' : t.length ≤ bound := by + simp only [List.length_cons] at hb + omega + rw [Cobham.recFoldClamp, ih hb'] + have hstate : Cobham.sndBlock (Cobham.fstBlock + (pair (pair W (stripTrailing t)) t)) = stripTrailing t := by + rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hlt : (stripTrailing t).length ≤ t.length := length_stripTrailing t + cases b + · show (stripZero _).take bound = _ + rw [stripZero, hstate, stripTrailing_false] + cases hs : stripTrailing t with + | nil => + rw [emptyFlag_nil, selectHead_cons_true, if_pos rfl] + simp + | cons c s => + rw [emptyFlag_cons, selectHead_cons_false, if_neg (by simp)] + refine List.take_of_length_le ?_ + simp only [List.length_cons] + rw [hs] at hlt + simp only [List.length_cons] at hlt + simp only [List.length_cons] at hb + omega + · show (stripOne _).take bound = _ + rw [stripOne, hstate, stripTrailing_true] + refine List.take_of_length_le ?_ + simp only [List.length_cons] at hb ⊢ + omega + +/-- Dropping trailing zeros, on `pair anything bits`. -/ +def stripFn (z : List Bool) : List Bool := + Cobham.recFoldClamp stripZero stripOne z.length [] (Cobham.fstBlock z) + (Cobham.sndBlock z) + +theorem stripFn_mem_FP : stripFn ∈ FP := by + have := Cobham.recFoldClamp_mem_FP stripZero_mem_FP stripOne_mem_FP + (constFn_mem_FP []) (Polynomial.X) + refine mem_FP_of_eq this fun z => ?_ + rw [stripFn] + simp + +theorem stripFn_eq (z : List Bool) : + stripFn z = stripTrailing (Cobham.sndBlock z) := by + refine recFoldClamp_stripTrailing _ _ _ ?_ + exact sndBlock_length_le z + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SubsetNP.lean b/Complexitylib/Classes/PCP/Internal/SubsetNP.lean new file mode 100644 index 00000000..46dcdaa9 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SubsetNP.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Defs + +/-! +# From proofs to answer tables + +The combinatorial heart of `PCP[r, q] ⊆ NP`: a nondeterministic machine cannot +guess the *proof*, which may be astronomically long — the verifier's query +positions are outputs of a polynomial-time function, so they are bounded only by +`2 ^ poly`. What it can guess is the much smaller table of answers at the +positions actually queried. + +This module shows the two are interchangeable. A proof determines a table by +reading it, and conversely any table that satisfies the verifier on every coin +string can be realised by an actual proof — take the list long enough to cover +every position the verifier could ever ask about, which is a finite maximum since +there are finitely many coin strings. + +## Main definitions + +- `PCPVerifier.AcceptsWith` — acceptance when answers come from a table +- `PCPVerifier.maxQuery` — a bound past every position the verifier can query + +## Main results + +- `PCPVerifier.accepts_iff_acceptsWith` — a proof is a table +- `PCPVerifier.exists_proof_of_table` — a table is a proof +- `PCPVerifier.Consistent`, `PCPVerifier.exists_proof_of_consistent_table` — a + consistent accepted table, indexed by coin string, is a proof +- `PCPVerifier.exists_proof_iff_exists_table` — the two are interchangeable +- `PCPVerifier.coinIndex`, `PCPVerifier.tableOf`, `PCPVerifier.Witness` — the + table as a bitstring, in a fixed-stride layout +- `PCPVerifier.witnessOf`, `PCPVerifier.tableOf_witnessOf` — the witness a proof + induces +- `PCPVerifier.exists_witness_iff` — a proof exists exactly when a witness does +- `PCPVerifier.eventProb_acceptEvent_eq_one_iff` — certain acceptance, unfolded +-/ + +@[expose] public section + +namespace Complexity + +namespace PCPVerifier + +variable (V : PCPVerifier) + +/-- The verifier accepts when the answers are read off the table `f`. -/ +def AcceptsWith (V : PCPVerifier) (x : List Bool) (f : ℕ → Bool) (ρ : List Bool) : Prop := + pair (pair x ρ) ((V.positions x ρ).map f) ∈ V.verdict + +/-- Reading a proof gives a table, and acceptance is unchanged. -/ +theorem accepts_iff_acceptsWith (x π ρ : List Bool) : + V.Accepts x π ρ ↔ V.AcceptsWith x (fun i => π.getD i false) ρ := Iff.rfl + +/-! ### Realising a table by a proof -/ + +/-- Every entry of a list is at most its running maximum. -/ +theorem le_foldr_max (l : List ℕ) {p : ℕ} (hp : p ∈ l) : p ≤ l.foldr max 0 := by + induction l with + | nil => exact absurd hp (by simp) + | cons a l ih => + rcases List.mem_cons.mp hp with h | h + · subst h + exact le_max_left _ _ + · exact le_trans (ih h) (le_max_right _ _) + +/-- A bound past every position the verifier can query on `x` with `t` coins. -/ +noncomputable def maxQuery (V : PCPVerifier) (t : ℕ) (x : List Bool) : ℕ := + (Finset.univ.sup fun ρ : Fin t → Bool => + (V.positions x (BitString.toList ρ)).foldr max 0) + 1 + +theorem lt_maxQuery {t : ℕ} {x : List Bool} {ρ : Fin t → Bool} {p : ℕ} + (hp : p ∈ V.positions x (BitString.toList ρ)) : p < V.maxQuery t x := by + have h1 : p ≤ (V.positions x (BitString.toList ρ)).foldr max 0 := le_foldr_max _ hp + have h2 : (V.positions x (BitString.toList ρ)).foldr max 0 + ≤ Finset.univ.sup fun σ : Fin t → Bool => + (V.positions x (BitString.toList σ)).foldr max 0 := + Finset.le_sup (f := fun σ : Fin t → Bool => + (V.positions x (BitString.toList σ)).foldr max 0) (Finset.mem_univ ρ) + rw [maxQuery] + omega + +/-- **A table is a proof.** A table accepted on every coin string is realised by +an honest proof: the list of its values up to the largest position the verifier +could query. -/ +theorem exists_proof_of_table (t : ℕ) (x : List Bool) (f : ℕ → Bool) + (h : ∀ ρ : Fin t → Bool, V.AcceptsWith x f (BitString.toList ρ)) : + ∃ π : List Bool, ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ) := by + classical + refine ⟨(List.range (V.maxQuery t x)).map f, fun ρ => ?_⟩ + have hread : ∀ p ∈ V.positions x (BitString.toList ρ), + ((List.range (V.maxQuery t x)).map f).getD p false = f p := by + intro p hp + have hlt : p < V.maxQuery t x := V.lt_maxQuery hp + have hlen : ((List.range (V.maxQuery t x)).map f).length = V.maxQuery t x := by + simp + rw [← List.getElem_eq_getD (h := by rw [hlen]; exact hlt)] + simp [List.getElem_map] + have hmap : (V.positions x (BitString.toList ρ)).map + (fun i => ((List.range (V.maxQuery t x)).map f).getD i false) + = (V.positions x (BitString.toList ρ)).map f := + List.map_congr_left hread + rw [Accepts, answers, hmap] + exact h ρ + +/-! ### Tables indexed by coin string -/ + +/-- A table assigns answers to every coin string. It is *consistent* when two +coin strings that query the same position receive the same answer — the +condition a dishonest prover would violate, and the one that lets a table be +read back as a single proof. -/ +def Consistent (V : PCPVerifier) (t : ℕ) (x : List Bool) + (tbl : (Fin t → Bool) → List Bool) : Prop := + ∀ (ρ ρ' : Fin t → Bool) (i i' : ℕ) (p : ℕ), + (V.positions x (BitString.toList ρ))[i]? = some p → + (V.positions x (BitString.toList ρ'))[i']? = some p → + (tbl ρ)[i]? = (tbl ρ')[i']? + +open Classical in +/-- The position-indexed reading of a table. -/ +noncomputable def tableFun (V : PCPVerifier) (t : ℕ) (x : List Bool) + (tbl : (Fin t → Bool) → List Bool) (p : ℕ) : Bool := + if ∃ (ρ : Fin t → Bool) (i : ℕ), + (V.positions x (BitString.toList ρ))[i]? = some p ∧ (tbl ρ)[i]? = some true + then true else false + +/-- On a consistent table the reading returns the recorded answer. -/ +theorem tableFun_eq {t : ℕ} {x : List Bool} {tbl : (Fin t → Bool) → List Bool} + (hcons : V.Consistent t x tbl) {ρ : Fin t → Bool} {i p : ℕ} {b : Bool} + (hpos : (V.positions x (BitString.toList ρ))[i]? = some p) + (hans : (tbl ρ)[i]? = some b) : V.tableFun t x tbl p = b := by + classical + cases b with + | true => + rw [tableFun, if_pos ⟨ρ, i, hpos, hans⟩] + | false => + rw [tableFun, if_neg] + rintro ⟨ρ', i', hpos', hans'⟩ + have := hcons ρ ρ' i i' p hpos hpos' + rw [hans, hans'] at this + exact absurd this (by simp) + +/-- **A consistent accepted table is a proof.** -/ +theorem exists_proof_of_consistent_table (t : ℕ) (x : List Bool) + (tbl : (Fin t → Bool) → List Bool) + (hlen : ∀ ρ : Fin t → Bool, + (tbl ρ).length = (V.positions x (BitString.toList ρ)).length) + (hcons : V.Consistent t x tbl) + (hacc : ∀ ρ : Fin t → Bool, + pair (pair x (BitString.toList ρ)) (tbl ρ) ∈ V.verdict) : + ∃ π : List Bool, ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ) := by + classical + refine V.exists_proof_of_table t x (V.tableFun t x tbl) fun ρ => ?_ + have hmap : (V.positions x (BitString.toList ρ)).map (V.tableFun t x tbl) = tbl ρ := by + refine List.ext_getElem? fun i => ?_ + rcases hi : (V.positions x (BitString.toList ρ))[i]? with _ | p + · have hlen1 : (V.positions x (BitString.toList ρ)).length ≤ i := + List.getElem?_eq_none_iff.mp hi + rw [List.getElem?_map, hi] + exact (List.getElem?_eq_none_iff.mpr (by rw [hlen]; exact hlen1)).symm + · have hilt : i < (V.positions x (BitString.toList ρ)).length := + List.getElem?_eq_some_iff.mp hi |>.1 + have hilt' : i < (tbl ρ).length := by rw [hlen]; exact hilt + obtain ⟨b, hb⟩ : ∃ b, (tbl ρ)[i]? = some b := + ⟨(tbl ρ)[i]'hilt', List.getElem?_eq_getElem hilt'⟩ + rw [List.getElem?_map, hi, hb] + exact congrArg some (V.tableFun_eq hcons hi hb) + rw [AcceptsWith, hmap] + exact hacc ρ + +/-! ### The characterisation -/ + +/-- The table a proof induces is consistent: both entries read the same +position of the same proof. -/ +theorem consistent_of_proof (t : ℕ) (x π : List Bool) : + V.Consistent t x fun ρ => answers π (V.positions x (BitString.toList ρ)) := by + intro ρ ρ' i i' p hpos hpos' + show (List.map (fun i => π.getD i false) (V.positions x (BitString.toList ρ)))[i]? + = (List.map (fun i => π.getD i false) (V.positions x (BitString.toList ρ')))[i']? + rw [List.getElem?_map, List.getElem?_map, hpos, hpos'] + +theorem length_answers (t : ℕ) (x π : List Bool) (ρ : Fin t → Bool) : + (answers π (V.positions x (BitString.toList ρ))).length + = (V.positions x (BitString.toList ρ)).length := by + show (List.map (fun i => π.getD i false) (V.positions x (BitString.toList ρ))).length = _ + rw [List.length_map] + +/-- **Proofs and consistent tables are interchangeable.** This is what lets a +nondeterministic machine guess a polynomially long table instead of a proof it +could never write down. -/ +theorem exists_proof_iff_exists_table (t : ℕ) (x : List Bool) : + (∃ π : List Bool, ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ)) + ↔ ∃ tbl : (Fin t → Bool) → List Bool, + (∀ ρ : Fin t → Bool, + (tbl ρ).length = (V.positions x (BitString.toList ρ)).length) + ∧ V.Consistent t x tbl + ∧ ∀ ρ : Fin t → Bool, + pair (pair x (BitString.toList ρ)) (tbl ρ) ∈ V.verdict := by + constructor + · rintro ⟨π, hπ⟩ + exact ⟨fun ρ => answers π (V.positions x (BitString.toList ρ)), + V.length_answers t x π, V.consistent_of_proof t x π, hπ⟩ + · rintro ⟨tbl, hlen, hcons, hacc⟩ + exact V.exists_proof_of_consistent_table t x tbl hlen hcons hacc + +/-! ### Encoding a table as a witness -/ + +/-- The digits of a coin string, as an element of `Fin 2` per coin. -/ +def coinDigits {t : ℕ} (ρ : Fin t → Bool) : Fin t → Fin 2 := + fun i => if ρ i then 1 else 0 + +theorem coinDigits_injective {t : ℕ} : Function.Injective (coinDigits (t := t)) := by + intro ρ ρ' h + funext i + have hi := congrFun h i + rw [coinDigits, coinDigits] at hi + revert hi + cases ρ i <;> cases ρ' i <;> decide + +/-- A canonical index for each coin string: the value of its digits read as a +binary numeral. This is deliberately an explicit equivalence rather than one +obtained from `Fintype.equivFinOfCardEq`, so that the layout of a witness is +computable — the reduction of a verifier to a CNF formula depends on it. -/ +def coinIndex {t : ℕ} (ρ : Fin t → Bool) : ℕ := + (finFunctionFinEquiv (coinDigits ρ)).val + +theorem coinIndex_lt {t : ℕ} (ρ : Fin t → Bool) : coinIndex ρ < 2 ^ t := + (finFunctionFinEquiv (coinDigits ρ)).isLt + +theorem coinIndex_injective {t : ℕ} : Function.Injective (coinIndex (t := t)) := + fun _ _ h => coinDigits_injective (finFunctionFinEquiv.injective (Fin.ext h)) + +/-- The coin string with a given index — the inverse of `coinIndex`. -/ +def coinOfIndex {t : ℕ} (c : Fin (2 ^ t)) : Fin t → Bool := + fun i => finFunctionFinEquiv.symm c i == 1 + +theorem coinOfIndex_coinIndex {t : ℕ} (ρ : Fin t → Bool) (h : coinIndex ρ < 2 ^ t) : + coinOfIndex ⟨coinIndex ρ, h⟩ = ρ := by + have hfin : (⟨coinIndex ρ, h⟩ : Fin (2 ^ t)) = finFunctionFinEquiv (coinDigits ρ) := + Fin.ext rfl + funext i + rw [coinOfIndex, hfin, Equiv.symm_apply_apply] + rw [coinDigits] + cases ρ i <;> decide + +/-- The table a witness encodes: the answers for coin string `ρ` sit in the +slots `coinIndex ρ * Q, …` of the witness, a fixed stride apart. -/ +noncomputable def tableOf (V : PCPVerifier) (t Q : ℕ) (x : List Bool) (w : List Bool) : + (Fin t → Bool) → List Bool := + fun ρ => (List.range (V.positions x (BitString.toList ρ)).length).map + fun i => w.getD (coinIndex ρ * Q + i) false + +theorem length_tableOf (t Q : ℕ) (x w : List Bool) (ρ : Fin t → Bool) : + (V.tableOf t Q x w ρ).length = (V.positions x (BitString.toList ρ)).length := by + rw [tableOf, List.length_map, List.length_range] + +/-- The witness relation: the encoded table is consistent and accepted on every +coin string. -/ +def Witness (V : PCPVerifier) (t Q : ℕ) (x w : List Bool) : Prop := + V.Consistent t x (V.tableOf t Q x w) ∧ + ∀ ρ : Fin t → Bool, + pair (pair x (BitString.toList ρ)) (V.tableOf t Q x w ρ) ∈ V.verdict + +/-- A witness yields a proof. -/ +theorem exists_proof_of_witness {t Q : ℕ} {x w : List Bool} (h : V.Witness t Q x w) : + ∃ π : List Bool, ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ) := + V.exists_proof_of_consistent_table t x (V.tableOf t Q x w) (V.length_tableOf t Q x w) + h.1 h.2 + +open Classical in +/-- The witness a proof induces: each coin string's answers written into its own +stride of the witness. -/ +noncomputable def witnessOf (V : PCPVerifier) (t Q : ℕ) (x π : List Bool) : List Bool := + (List.range (2 ^ t * Q)).map fun k => + if h : k / Q < 2 ^ t then + π.getD ((V.positions x (BitString.toList (coinOfIndex ⟨k / Q, h⟩))).getD (k % Q) 0) + false + else false + +theorem length_witnessOf (t Q : ℕ) (x π : List Bool) : + (V.witnessOf t Q x π).length = 2 ^ t * Q := by + rw [witnessOf, List.length_map, List.length_range] + +/-- The witness a proof induces encodes exactly the proof's own answers. -/ +theorem tableOf_witnessOf {t Q : ℕ} (x π : List Bool) (hQ0 : 0 < Q) + (hQ : ∀ ρ : Fin t → Bool, (V.positions x (BitString.toList ρ)).length ≤ Q) + (ρ : Fin t → Bool) : + V.tableOf t Q x (V.witnessOf t Q x π) ρ + = answers π (V.positions x (BitString.toList ρ)) := by + classical + refine List.ext_getElem ?_ fun i h1 h2 => ?_ + · rw [V.length_tableOf t Q x (V.witnessOf t Q x π) ρ] + show _ = (List.map (fun i => π.getD i false) _).length + rw [List.length_map] + · have hilt : i < (V.positions x (BitString.toList ρ)).length := by + rw [V.length_tableOf t Q x (V.witnessOf t Q x π) ρ] at h1 + exact h1 + have hiQ : i < Q := lt_of_lt_of_le hilt (hQ ρ) + have hkey : coinIndex ρ * Q + i < 2 ^ t * Q := by + have hc := coinIndex_lt ρ + calc coinIndex ρ * Q + i < coinIndex ρ * Q + Q := by omega + _ = (coinIndex ρ + 1) * Q := by ring + _ ≤ 2 ^ t * Q := Nat.mul_le_mul_right _ (by omega) + have hdiv : (coinIndex ρ * Q + i) / Q = coinIndex ρ := by + rw [mul_comm, Nat.mul_add_div hQ0, Nat.div_eq_of_lt hiQ, Nat.add_zero] + have hmod : (coinIndex ρ * Q + i) % Q = i := by + rw [mul_comm, Nat.mul_add_mod, Nat.mod_eq_of_lt hiQ] + have hrho : ∀ h : (coinIndex ρ * Q + i) / Q < 2 ^ t, + coinOfIndex ⟨(coinIndex ρ * Q + i) / Q, h⟩ = ρ := by + intro h + have hfin : (⟨(coinIndex ρ * Q + i) / Q, h⟩ : Fin (2 ^ t)) + = ⟨coinIndex ρ, coinIndex_lt ρ⟩ := Fin.ext hdiv + rw [hfin, coinOfIndex_coinIndex] + have hdivlt : (coinIndex ρ * Q + i) / Q < 2 ^ t := by + rw [hdiv] + exact coinIndex_lt ρ + have hwit : (V.witnessOf t Q x π).getD (coinIndex ρ * Q + i) false + = π.getD ((V.positions x (BitString.toList ρ)).getD i 0) false := by + have hlen : coinIndex ρ * Q + i < (V.witnessOf t Q x π).length := by + rw [V.length_witnessOf t Q x π] + exact hkey + rw [← List.getElem_eq_getD (h := hlen)] + show ((List.range (2 ^ t * Q)).map _)[coinIndex ρ * Q + i] = _ + rw [List.getElem_map, List.getElem_range, dif_pos hdivlt, hrho hdivlt, hmod] + show ((List.range (V.positions x (BitString.toList ρ)).length).map + fun i => (V.witnessOf t Q x π).getD (coinIndex ρ * Q + i) false)[i] = _ + rw [List.getElem_map, List.getElem_range, hwit] + show _ = (List.map (fun i => π.getD i false) _)[i] + rw [List.getElem_map] + congr 1 + rw [← List.getElem_eq_getD (h := hilt)] + +/-- **The witness characterisation.** A proof exists exactly when a witness +does — and a witness is a bitstring of length `2 ^ t * Q`, which is polynomial +when `t = O(log n)` and `Q = O(1)`. -/ +theorem exists_witness_iff {t Q : ℕ} (x : List Bool) (hQ0 : 0 < Q) + (hQ : ∀ ρ : Fin t → Bool, (V.positions x (BitString.toList ρ)).length ≤ Q) : + (∃ w : List Bool, V.Witness t Q x w) + ↔ ∃ π : List Bool, ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ) := by + constructor + · rintro ⟨w, hw⟩ + exact V.exists_proof_of_witness hw + · rintro ⟨π, hπ⟩ + refine ⟨V.witnessOf t Q x π, ?_, ?_⟩ + · intro ρ ρ' i i' p hpos hpos' + rw [V.tableOf_witnessOf x π hQ0 hQ ρ, V.tableOf_witnessOf x π hQ0 hQ ρ'] + exact V.consistent_of_proof t x π ρ ρ' i i' p hpos hpos' + · intro ρ + rw [V.tableOf_witnessOf x π hQ0 hQ ρ] + exact hπ ρ + +/-- Certain acceptance is acceptance on every coin string. -/ +theorem eventProb_acceptEvent_eq_one_iff (t : ℕ) (x π : List Bool) : + eventProb (V.acceptEvent t x π) = 1 + ↔ ∀ ρ : Fin t → Bool, V.Accepts x π (BitString.toList ρ) := by + classical + have hcard : (Finset.univ : Finset (Fin t → Bool)).card = 2 ^ t := by + rw [Finset.card_univ, card_finArrowBool] + constructor + · intro h ρ + have huniv : V.acceptEvent t x π = Finset.univ := by + by_contra hne + have hlt : (V.acceptEvent t x π).card < 2 ^ t := by + rw [← hcard] + exact Finset.card_lt_card (Finset.ssubset_univ_iff.mpr hne) + have hpos : (0 : ℚ) < 2 ^ t := by positivity + rw [eventProb, div_eq_one_iff_eq (ne_of_gt hpos)] at h + have : ((V.acceptEvent t x π).card : ℚ) < ((2 : ℚ) ^ t) := by exact_mod_cast hlt + rw [h] at this + exact absurd this (lt_irrefl _) + have hmem : ρ ∈ V.acceptEvent t x π := by rw [huniv]; exact Finset.mem_univ ρ + rw [acceptEvent, Finset.mem_filter] at hmem + exact hmem.2 + · intro h + have huniv : V.acceptEvent t x π = Finset.univ := by + ext ρ + simp only [acceptEvent, Finset.mem_filter, Finset.mem_univ, true_and, iff_true] + exact h ρ + rw [huniv, eventProb_univ] + +end PCPVerifier + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean b/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean new file mode 100644 index 00000000..246a7db6 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConsistencyLang +public import Complexitylib.Classes.PCP.Internal.GuessVerifyGeneric + +/-! +# `PCP[O(log n), O(1)] ⊆ NP` + +A verifier with logarithmic randomness has polynomially many coin strings, so +its whole behaviour on an input is captured by a table of answers of polynomial +size. This module assembles the checks on such a table — that it has the right +width, that it is consistent, and that the verifier accepts on every coin +string — into a single polynomial-time verifier language, and hands it to the +guess-and-verify bridge. + +The completeness and soundness conditions of `PCP` do the rest: a member has a +proof accepted always, and a non-member has none, since a proof accepted always +would give acceptance probability one rather than at most one half. + +## Main results + +- `Complexity.PCP_subset_NP` — the easy inclusion of the PCP theorem +-/ + +@[expose] public section + +namespace Complexity + +section + +variable (r : ℕ → ℕ) (Q : ℕ) + +/-- The witness has exactly one block per coin string. -/ +noncomputable def lenLang : Language := + {z | (Cobham.sndBlock z).length = 2 ^ r (Cobham.fstBlock z).length * Q} + +open scoped Complexity in +theorem lenLang_mem_P + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + (hrlog : r =O fun n => Nat.log 2 n) : lenLang r Q ∈ P := by + have ha : (fun z : List Bool => List.replicate (Cobham.sndBlock z).length false) ∈ FP := + zeroBlockFn_mem_FP Cobham.sndBlock_mem_FP + have hexp : (fun z : List Bool => + List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) + simpa [Function.comp] using this + have hQ : (fun _ : List Bool => List.replicate Q false) ∈ FP := + Cobham.const_replicate_mem_FP Q + have hb : (fun z : List Bool => + List.replicate (2 ^ r (Cobham.fstBlock z).length * Q) false) ∈ FP := by + have := Cobham.mulLenFn_mem_FP hexp hQ + refine mem_FP_of_eq this fun z => ?_ + rw [List.length_replicate, List.length_replicate] + refine mem_P_of_decisionFn (eqFlagFn_mem_FP ha hb) fun z => ?_ + rw [exists_eqFlag_iff] + constructor + · intro h + rw [lenLang, Set.mem_setOf_eq] at h + rw [h] + · intro h + have := congrArg List.length h + rw [List.length_replicate, List.length_replicate] at this + exact this + +variable (V : PCPVerifier) (f : List Bool → List Bool) + +/-- **The verifier language**: the witness has the right shape, is consistent, +and is accepted on every coin string. -/ +noncomputable def witLang : Language := + lenLang r Q ∩ (consLang f r Q ∩ accLang V f r Q) + +open scoped Complexity in +theorem witLang_mem_P (hf : f ∈ FP) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + (hrlog : r =O fun n => Nat.log 2 n) : witLang r Q V f ∈ P := + P_inter (lenLang_mem_P r Q hr hrlog) + (P_inter (consLang_mem_P f r Q hf hr hrlog) (accLang_mem_P V f r Q hf hr hrlog)) + +theorem mem_witLang_iff + (hfspec : ∀ x rr : List Bool, + f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) + (hQ : ∀ x rr : List Bool, (V.positions x rr).length ≤ Q) (x w : List Bool) : + pair x w ∈ witLang r Q V f + ↔ w.length = 2 ^ r x.length * Q ∧ V.Witness (r x.length) Q x w := by + constructor + · rintro ⟨hlen, hcons, hacc⟩ + have hlen' : w.length = 2 ^ r x.length * Q := by + rw [lenLang, Set.mem_setOf_eq, Cobham.fstBlock_pair, Cobham.sndBlock_pair] at hlen + exact hlen + refine ⟨hlen', ?_, ?_⟩ + · exact (mem_consLang_iff V f r Q hfspec hlen' (hQ x)).mp hcons + · exact (mem_accLang_iff V f r Q hfspec hlen' (hQ x)).mp hacc + · rintro ⟨hlen, hcons, hacc⟩ + refine ⟨?_, ?_, ?_⟩ + · rw [lenLang, Set.mem_setOf_eq, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + exact hlen + · exact (mem_consLang_iff V f r Q hfspec hlen (hQ x)).mpr hcons + · exact (mem_accLang_iff V f r Q hfspec hlen (hQ x)).mpr hacc + +end + +open scoped Complexity in +/-- **`PCP[O(log n), O(1)] ⊆ NP`.** A verifier's whole behaviour is a table of +answers of polynomial size; guessing that table and checking it is an `NP` +computation. -/ +theorem PCP_subset_NP {r q : ℕ → ℕ} + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + (hrlog : r =O fun n => Nat.log 2 n) (hq : q =O fun _ => 1) : + PCP r q ⊆ NP := by + rintro L ⟨V, hVq, hcomp, hsound⟩ + obtain ⟨K, hK⟩ := exists_const_query_bound hVq hq + obtain ⟨f, hf, hfspec⟩ := V.positions_mem + set Q := K + 1 with hQdef + have hQ : ∀ x rr : List Bool, (V.positions x rr).length ≤ Q := fun x rr => + le_trans (hK x rr) (by omega) + have hQ0 : 0 < Q := by omega + obtain ⟨p₀, hp₀⟩ := exists_poly_two_pow_of_bigO_log hrlog + refine mem_NP_of_poly_witness (p₀ * Polynomial.C Q) + (witLang_mem_P r Q V f hf hr hrlog) ?_ ?_ + · intro x y hy + rw [mem_witLang_iff r Q V f hfspec hQ] at hy + rw [hy.1] + simp only [Polynomial.eval_mul, Polynomial.eval_C] + exact Nat.mul_le_mul_right _ (hp₀ x.length) + · intro x + constructor + · intro hx + obtain ⟨π, hπ⟩ := hcomp x hx + rw [V.eventProb_acceptEvent_eq_one_iff] at hπ + refine ⟨V.witnessOf (r x.length) Q x π, ?_⟩ + rw [mem_witLang_iff r Q V f hfspec hQ] + refine ⟨V.length_witnessOf _ _ _ _, ?_, ?_⟩ + · intro ρ ρ' i i' pp hpos hpos' + rw [V.tableOf_witnessOf x π hQ0 (fun ρ => hQ x _), + V.tableOf_witnessOf x π hQ0 (fun ρ => hQ x _)] + exact V.consistent_of_proof _ x π ρ ρ' i i' pp hpos hpos' + · intro ρ + rw [V.tableOf_witnessOf x π hQ0 (fun ρ => hQ x _)] + exact hπ ρ + · rintro ⟨w, hw⟩ + rw [mem_witLang_iff r Q V f hfspec hQ] at hw + obtain ⟨π, hπ⟩ := V.exists_proof_of_witness hw.2 + by_contra hx + have h1 : eventProb (V.acceptEvent (r x.length) x π) = 1 := + (V.eventProb_acceptEvent_eq_one_iff _ x π).mpr hπ + have h2 := hsound x hx π + rw [h1] at h2 + norm_num at h2 + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SymbolCodec.lean b/Complexitylib/Classes/PCP/Internal/SymbolCodec.lean new file mode 100644 index 00000000..fb3256db --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/SymbolCodec.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CoinEnum + +/-! +# Writing symbols as fixed-width blocks + +A proof for a constraint graph is an assignment written out, one fixed-width +block per vertex. This module supplies the block: any finite alphabet small +enough is written as its index in binary, at a width the caller chooses. + +The codec need not be computable — a verifier's *decision* has to be +polynomial-time, but the correspondence between symbols and blocks is only used +to state what the decision means. + +## Main definitions + +- `Complexity.symEnc`, `Complexity.symDec` — the block of a symbol, and back + +## Main results + +- `Complexity.symDec_symEnc` — the codec round-trips +- `Complexity.length_symEnc` — blocks have the chosen width +-/ + +@[expose] public section + +namespace Complexity + +variable (α : Type) [Fintype α] [Inhabited α] + +/-- The block a symbol occupies: its index, in binary, at width `w`. -/ +noncomputable def symEnc (w : ℕ) (s : α) : List Bool := + bitsOfLenLE w (Fintype.equivFin α s).val + +/-- The symbol a block names. -/ +noncomputable def symDec (u : List Bool) : α := + if h : binValLE u < Fintype.card α then (Fintype.equivFin α).symm ⟨binValLE u, h⟩ + else default + +variable {α} + +omit [Inhabited α] in +@[simp] theorem length_symEnc (w : ℕ) (s : α) : (symEnc α w s).length = w := by + rw [symEnc, bitsOfLenLE_length] + +/-- **The codec round-trips**, as long as the width holds the alphabet. -/ +theorem symDec_symEnc {w : ℕ} (h : Fintype.card α ≤ 2 ^ w) (s : α) : + symDec α (symEnc α w s) = s := by + have hlt : (Fintype.equivFin α s).val < 2 ^ w := + lt_of_lt_of_le (Fintype.equivFin α s).isLt h + have hval : binValLE (symEnc α w s) = (Fintype.equivFin α s).val := by + rw [symEnc, binValLE_bitsOfLenLE _ _ hlt] + rw [symDec, hval, dif_pos (Fintype.equivFin α s).isLt] + simp + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TesterChecks.lean b/Complexitylib/Classes/PCP/Internal/TesterChecks.lean new file mode 100644 index 00000000..5afe4f75 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/TesterChecks.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.HadamardTester +public import Complexitylib.Classes.PCP.Internal.Arithmetize + +/-! +# The remaining checks of the assignment tester + +`HadamardTester` proves the linearity and consistency checks. Two more are +needed for the tester to plug into Dinur's composition, and both are analysed +here on raw tables, over bundled randomness, in the same style. + +* **The constraint check on a system.** The constraint is a *system* of + quadratic equations (the one-hot arithmetization of `Arithmetize`), checked + by one random linear combination. Passing on more than half of the + coefficient vectors — after paying for the reads — forces every equation to + hold on the decoded tables. + +* **The input check, one coordinate at a time.** The tester is handed its + input as a table it may read at a single random coordinate, and compares that + bit with the corresponding coordinate of its decoded assignment, obtained by + self-correction at a basis vector. Passing often means the input table is + *close* to the decoded assignment's input part — not equal, which a single + read could never certify, but close enough that, when the input is supposed + to be a Hadamard codeword, it decodes uniquely. + +The last point is what makes the composition work with constantly many +queries: the outer graph's labels are handed to the tester as Hadamard +codewords, and a wrong label is far from every right one. + +## Main results + +- `Complexity.forall_checkValue_of_prob_combined` — the random-combination + constraint check +- `Complexity.prob_coord_eq_ge` — the single-coordinate input check +- `Complexity.decodeLabel_eq` — a table close to a codeword decodes to it +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +variable {n : ℕ} + +/-! ### The constraint check on a system -/ + +/-- **The random-combination constraint check.** Reading the combined constraint +off the raw tables passes often enough only if every constraint of the system +holds on the decoded tables. The coefficient vector is the first block, the +correction strings the second. -/ +theorem forall_checkValue_of_prob_combined {J : ℕ} (a : Cube n) (b : Cube (n * n)) + (C : Fin J → QuadConstraint n) + (f : BooleanFunction n) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (g : BooleanFunction (n * n)) (hg : IsBooleanValued g) {ε' : ℝ} + (hgc : IsClose g (signOf (hadamard b)) ε') + (haccept : 1 / 2 + (2 * ε + 2 * ε') < Pr[fun z : Cube (J + (n + n * n)) => + ConstraintAccepts f g (QuadConstraint.combine C (leftBlock z)) (rightBlock z)]) : + ∀ j, checkValue (hadamard b) (hadamard a) (C j) = 0 := by + classical + have hgood : 1 - (2 * ε + 2 * ε') ≤ Pr[fun z : Cube (J + (n + n * n)) => + f (leftBlock (rightBlock z)) + * f ((QuadConstraint.combine C (leftBlock z)).lin + leftBlock (rightBlock z)) + = chi (hadamard a (QuadConstraint.combine C (leftBlock z)).lin) + ∧ g (rightBlock (rightBlock z)) + * g ((QuadConstraint.combine C (leftBlock z)).quad + rightBlock (rightBlock z)) + = chi (hadamard b (QuadConstraint.combine C (leftBlock z)).quad)] := + prob_blocks_ge (fun c w => + f (leftBlock w) * f ((QuadConstraint.combine C c).lin + leftBlock w) + = chi (hadamard a (QuadConstraint.combine C c).lin) + ∧ g (rightBlock w) * g ((QuadConstraint.combine C c).quad + rightBlock w) + = chi (hadamard b (QuadConstraint.combine C c).quad)) _ + fun c => prob_constraint_reads a b (QuadConstraint.combine C c) f hf hfc g hg hgc + have htrans := prob_le_of_imp_of_good + (E := fun z : Cube (J + (n + n * n)) => + ConstraintAccepts f g (QuadConstraint.combine C (leftBlock z)) (rightBlock z)) + (F := fun z : Cube (J + (n + n * n)) => + checkValue (hadamard b) (hadamard a) (QuadConstraint.combine C (leftBlock z)) = 0) + (A := fun z : Cube (J + (n + n * n)) => + f (leftBlock (rightBlock z)) + * f ((QuadConstraint.combine C (leftBlock z)).lin + leftBlock (rightBlock z)) + = chi (hadamard a (QuadConstraint.combine C (leftBlock z)).lin) + ∧ g (rightBlock (rightBlock z)) + * g ((QuadConstraint.combine C (leftBlock z)).quad + rightBlock (rightBlock z)) + = chi (hadamard b (QuadConstraint.combine C (leftBlock z)).quad)) + fun z hE hA => by + have h : signBit (chi (hadamard b (QuadConstraint.combine C (leftBlock z)).quad)) + + signBit (chi (hadamard a (QuadConstraint.combine C (leftBlock z)).lin)) + + (QuadConstraint.combine C (leftBlock z)).const = 0 := by + rw [← hA.1, ← hA.2] + exact hE + rw [signBit_chi, signBit_chi] at h + exact h + have hmarg : Pr[fun z : Cube (J + (n + n * n)) => + checkValue (hadamard b) (hadamard a) (QuadConstraint.combine C (leftBlock z)) = 0] + = Pr[fun c : Cube J => checkValue (hadamard b) (hadamard a) + (QuadConstraint.combine C c) = 0] := + prob_leftBlock (fun c : Cube J => + checkValue (hadamard b) (hadamard a) (QuadConstraint.combine C c) = 0) + rw [hmarg] at htrans + exact forall_checkValue_of_prob a b C (by linarith) + +/-! ### The input check, one coordinate at a time -/ + +/-- **The single-coordinate input check**, on the raw table: a random +coordinate `r` (first block) of the input table `w` is compared with the +decoded assignment's bit at variable `idx r`, read by self-correction at the +basis vector (correction string: second block). -/ +def CoordAccepts {m : ℕ} (f : BooleanFunction n) (w : Cube m → ZMod 2) (idx : Cube m → Fin n) + (z : Cube (m + n)) : Prop := + signBit (f (rightBlock z) * f (basisVec (idx (leftBlock z)) + rightBlock z)) + = w (leftBlock z) + +/-- **Passing the coordinate check means agreeing on most coordinates.** -/ +theorem prob_coord_eq_ge {m : ℕ} (a : Cube n) (f : BooleanFunction n) (hf : IsBooleanValued f) + {ε : ℝ} (hfc : IsClose f (signOf (hadamard a)) ε) + (w : Cube m → ZMod 2) (idx : Cube m → Fin n) : + Pr[CoordAccepts f w idx] - 2 * ε ≤ Pr[fun r : Cube m => a (idx r) = w r] := by + classical + have hgood : 1 - 2 * ε ≤ Pr[fun z : Cube (m + n) => + f (rightBlock z) * f (basisVec (idx (leftBlock z)) + rightBlock z) + = chi (hadamard a (basisVec (idx (leftBlock z))))] := + prob_blocks_ge (fun r c => + f c * f (basisVec (idx r) + c) = chi (hadamard a (basisVec (idx r)))) _ + fun r => prob_read_ge f hf a hfc (basisVec (idx r)) + have htrans := prob_le_of_imp_of_good (E := CoordAccepts f w idx) + (F := fun z : Cube (m + n) => a (idx (leftBlock z)) = w (leftBlock z)) + (A := fun z : Cube (m + n) => + f (rightBlock z) * f (basisVec (idx (leftBlock z)) + rightBlock z) + = chi (hadamard a (basisVec (idx (leftBlock z))))) + fun z hE hA => by + have h : signBit (chi (hadamard a (basisVec (idx (leftBlock z))))) = w (leftBlock z) := by + rw [← hA] + exact hE + rw [signBit_chi, hadamard_basisVec] at h + exact h + have hmarg : Pr[fun z : Cube (m + n) => a (idx (leftBlock z)) = w (leftBlock z)] + = Pr[fun r : Cube m => a (idx r) = w r] := + prob_leftBlock (fun r : Cube m => a (idx r) = w r) + rw [hmarg] at htrans + linarith + +/-- The honest table passes the coordinate check everywhere, when the input +table is the decoded assignment's input part. -/ +theorem coordAccepts_of_honest {m : ℕ} (a : Cube n) (idx : Cube m → Fin n) (z : Cube (m + n)) : + CoordAccepts (signOf (hadamard a)) (fun r => a (idx r)) idx z := by + show signBit (signOf (hadamard a) (rightBlock z) + * signOf (hadamard a) (basisVec (idx (leftBlock z)) + rightBlock z)) = _ + rw [corrected_read_honest, signBit_chi, hadamard_basisVec] + +/-! ### Decoding a label from a table -/ + +/-- The distance between two bit tables: the fraction of coordinates where they +differ. -/ +noncomputable def bitDist {m : ℕ} (s t : Cube m → ZMod 2) : ℝ := Pr[fun r => s r ≠ t r] + +theorem bitDist_eq_hammingDist {m : ℕ} (s t : Cube m → ZMod 2) : + bitDist s t = hammingDist (signOf s) (signOf t) := by + unfold bitDist hammingDist + congr 1 + funext r + show (s r ≠ t r) = (chi (s r) ≠ chi (t r)) + have hinj : ∀ u v : ZMod 2, chi u = chi v ↔ u = v := by + intro u v + constructor + · intro h + by_contra hne + have h' := signBit_chi u + rw [h, signBit_chi] at h' + exact hne h'.symm + · intro h + rw [h] + rw [ne_eq, ne_eq, hinj] + +theorem bitDist_comm {m : ℕ} (s t : Cube m → ZMod 2) : bitDist s t = bitDist t s := by + rw [bitDist_eq_hammingDist, bitDist_eq_hammingDist, hammingDist_comm] + +theorem bitDist_triangle {m : ℕ} (s t u : Cube m → ZMod 2) : + bitDist s u ≤ bitDist s t + bitDist t u := by + rw [bitDist_eq_hammingDist, bitDist_eq_hammingDist, bitDist_eq_hammingDist] + exact hammingDist_triangle _ _ _ + +theorem bitDist_eq_one_sub {m : ℕ} (s t : Cube m → ZMod 2) : + bitDist s t = 1 - Pr[fun r => s r = t r] := by + have := BooleanAnalysis.Internal.prob_compl (fun r : Cube m => s r = t r) + unfold bitDist + linarith + +/-- **Distinct codewords are far apart**: at distance exactly one half. -/ +theorem bitDist_hadamard {m : ℕ} (u v : Cube m) (h : u ≠ v) : + bitDist (hadamard u) (hadamard v) = 1 / 2 := by + have hne : u + v ≠ 0 := by + intro h0 + apply h + funext i + have hi := congrFun h0 i + rcases (by decide : ∀ x y : ZMod 2, x + y = 0 → x = y) (u i) (v i) hi with h' + exact h' + have hhalf := prob_hadamard_ne_zero (u + v) hne + unfold bitDist + rw [← hhalf] + congr 1 + funext r + rw [hadamard_add] + have hiff : ∀ x y : ZMod 2, (x ≠ y) ↔ (x + y ≠ 0) := by decide + exact propext (hiff _ _) + +/-- Decoding: the label whose codeword is within a quarter of the table, if +any; an arbitrary label otherwise. -/ +noncomputable def decodeLabel {m : ℕ} {β : Type} [Nonempty β] (enc : β → Cube m) + (t : Cube m → ZMod 2) : β := + open Classical in + if h : ∃ σ : β, bitDist t (hadamard (enc σ)) < 1 / 4 then Classical.choose h + else Classical.arbitrary β + +/-- **A table close to a codeword decodes to its label.** -/ +theorem decodeLabel_eq {m : ℕ} {β : Type} [Nonempty β] (enc : β → Cube m) + (henc : Function.Injective enc) (t : Cube m → ZMod 2) (σ : β) + (h : bitDist t (hadamard (enc σ)) < 1 / 4) : decodeLabel enc t = σ := by + classical + have hex : ∃ σ : β, bitDist t (hadamard (enc σ)) < 1 / 4 := ⟨σ, h⟩ + rw [decodeLabel, dif_pos hex] + have hspec := Classical.choose_spec hex + by_contra hne + have hne' : enc (Classical.choose hex) ≠ enc σ := fun heq => hne (henc heq) + have hfar := bitDist_hadamard _ _ hne' + have htri := bitDist_triangle (hadamard (enc (Classical.choose hex))) t (hadamard (enc σ)) + rw [bitDist_comm _ t] at htri + linarith + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TesterCore.lean b/Complexitylib/Classes/PCP/Internal/TesterCore.lean new file mode 100644 index 00000000..7651c4d5 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/TesterCore.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.TesterChecks + +/-! +# The assignment tester, assembled + +The six checks of the Hadamard assignment tester, run on one bundled random +string, on raw tables, with a universal soundness constant. + +The tester is handed two **input tables** `Tt Th : Cube B → ZMod 2` — in the +composition, the Hadamard encodings of the labels at the two ends of an outer +edge — and a **proof** consisting of a linear table `F` over `n` variables and +a quadratic table `G` over `n * n`, where the `n` variables are the `2 · 2^B` +input coordinates followed by the selectors of a one-hot system. Its random +string has six blocks, one per check: + +1. linearity of `F`; 2. linearity of `G`; 3. consistency of `G` with `F`; +4. the one-hot system, by a random linear combination; 5. and 6. the two +input tables, one coordinate each. + +Every check reads a constant number of positions — never a whole table — so +the total query count is a constant independent of `B`, and the soundness +constant `1/32` is universal. That independence is the point of the tester: +the outer alphabet may be enormous, and neither the query count nor the +soundness loss may notice. + +## Main definitions + +- `Complexity.Tester.AllChecks` — the tester's verdict on a random string + +## Main results + +- `Complexity.Tester.sound` — passing with probability above `31/32` yields an + assignment satisfying the system whose input parts are within `3/32` of the + input tables +- `Complexity.Tester.complete` — the honest proof of a satisfying assignment + passes on every random string +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +namespace Tester + +/-! ### Layout -/ + +/-- The number of input variables: two tables of `2^B` coordinates. -/ +abbrev kOf (B : ℕ) : ℕ := 2 ^ B + 2 ^ B + +/-- The number of variables: input coordinates and one-hot selectors. -/ +abbrev nOf (B : ℕ) : ℕ := kOf B + 2 ^ kOf B + +/-- The number of constraints in the one-hot system. -/ +abbrev JOf (B : ℕ) : ℕ := Fintype.card (OneHotIdx (kOf B)) + +/-- The variable holding coordinate `r` of the first input table. -/ +noncomputable def inTail (B : ℕ) (r : Cube B) : Fin (nOf B) := + Fin.castAdd (2 ^ kOf B) (Fin.castAdd (2 ^ B) (candIdx B r)) + +/-- The variable holding coordinate `r` of the second input table. -/ +noncomputable def inHead (B : ℕ) (r : Cube B) : Fin (nOf B) := + Fin.castAdd (2 ^ kOf B) (Fin.natAdd (2 ^ B) (candIdx B r)) + +/-- The first input table an assignment of the variables carries. -/ +noncomputable def tailPart {B : ℕ} (a : Cube (nOf B)) : Cube B → ZMod 2 := + fun r => a (inTail B r) + +/-- The second input table an assignment of the variables carries. -/ +noncomputable def headPart {B : ℕ} (a : Cube (nOf B)) : Cube B → ZMod 2 := + fun r => a (inHead B r) + +/-- The random bits of the linearity check on `F`. -/ +abbrev R1 (B : ℕ) : ℕ := nOf B + nOf B +/-- The random bits of the linearity check on `G`. -/ +abbrev R2 (B : ℕ) : ℕ := nOf B * nOf B + nOf B * nOf B +/-- The random bits of the consistency check. -/ +abbrev R3 (B : ℕ) : ℕ := (nOf B + nOf B) + (nOf B + (nOf B + nOf B * nOf B)) +/-- The random bits of the constraint check. -/ +abbrev R4 (B : ℕ) : ℕ := JOf B + (nOf B + nOf B * nOf B) +/-- The random bits of one input check. -/ +abbrev R5 (B : ℕ) : ℕ := B + nOf B + +/-- The random bits of the last two blocks. -/ +abbrev Rest5 (B : ℕ) : ℕ := R5 B + R5 B +/-- The random bits of the last three blocks. -/ +abbrev Rest4 (B : ℕ) : ℕ := R4 B + Rest5 B +/-- The random bits of the last four blocks. -/ +abbrev Rest3 (B : ℕ) : ℕ := R3 B + Rest4 B +/-- The random bits after the first block. -/ +abbrev Rest2 (B : ℕ) : ℕ := R2 B + Rest3 B + +/-- The total number of random bits. -/ +abbrev ROf (B : ℕ) : ℕ := R1 B + Rest2 B + +variable {B : ℕ} + +/-- The first block of the random string: linearity of `F`. -/ +def blk1 (z : Cube (ROf B)) : Cube (R1 B) := leftBlock z +/-- The second block: linearity of `G`. -/ +def blk2 (z : Cube (ROf B)) : Cube (R2 B) := leftBlock (rightBlock z) +/-- The third block: consistency. -/ +def blk3 (z : Cube (ROf B)) : Cube (R3 B) := leftBlock (rightBlock (rightBlock z)) +/-- The fourth block: the constraint system. -/ +def blk4 (z : Cube (ROf B)) : Cube (R4 B) := leftBlock (rightBlock (rightBlock (rightBlock z))) +/-- The fifth block: the first input table. -/ +def blk5 (z : Cube (ROf B)) : Cube (R5 B) := + leftBlock (rightBlock (rightBlock (rightBlock (rightBlock z)))) +/-- The sixth block: the second input table. -/ +def blk6 (z : Cube (ROf B)) : Cube (R5 B) := + rightBlock (rightBlock (rightBlock (rightBlock (rightBlock z)))) + +/-! ### Each block is uniform -/ + +theorem prob_blk1 (P : Cube (R1 B) → Prop) : Pr[fun z : Cube (ROf B) => P (blk1 z)] = Pr[P] := + prob_leftBlock P + +theorem prob_blk2 (P : Cube (R2 B) → Prop) : Pr[fun z : Cube (ROf B) => P (blk2 z)] = Pr[P] := by + have h1 := prob_rightBlock (a := R1 B) (fun w : Cube (Rest2 B) => P (leftBlock w)) + rw [show (fun z : Cube (ROf B) => P (blk2 z)) = fun z => P (leftBlock (rightBlock z)) from rfl, + h1] + exact prob_leftBlock P + +theorem prob_blk3 (P : Cube (R3 B) → Prop) : Pr[fun z : Cube (ROf B) => P (blk3 z)] = Pr[P] := by + have h1 := prob_rightBlock (a := R1 B) + (fun w : Cube (Rest2 B) => P (leftBlock (rightBlock w))) + have h2 := prob_rightBlock (a := R2 B) (fun w : Cube (Rest3 B) => P (leftBlock w)) + rw [show (fun z : Cube (ROf B) => P (blk3 z)) + = fun z => P (leftBlock (rightBlock (rightBlock z))) from rfl, h1, h2] + exact prob_leftBlock P + +theorem prob_blk4 (P : Cube (R4 B) → Prop) : Pr[fun z : Cube (ROf B) => P (blk4 z)] = Pr[P] := by + have h1 := prob_rightBlock (a := R1 B) + (fun w : Cube (Rest2 B) => P (leftBlock (rightBlock (rightBlock w)))) + have h2 := prob_rightBlock (a := R2 B) + (fun w : Cube (Rest3 B) => P (leftBlock (rightBlock w))) + have h3 := prob_rightBlock (a := R3 B) (fun w : Cube (Rest4 B) => P (leftBlock w)) + rw [show (fun z : Cube (ROf B) => P (blk4 z)) + = fun z => P (leftBlock (rightBlock (rightBlock (rightBlock z)))) from rfl, h1, h2, h3] + exact prob_leftBlock P + +theorem prob_blk5 (P : Cube (R5 B) → Prop) : Pr[fun z : Cube (ROf B) => P (blk5 z)] = Pr[P] := by + have h1 := prob_rightBlock (a := R1 B) + (fun w : Cube (Rest2 B) => P (leftBlock (rightBlock (rightBlock (rightBlock w))))) + have h2 := prob_rightBlock (a := R2 B) + (fun w : Cube (Rest3 B) => P (leftBlock (rightBlock (rightBlock w)))) + have h3 := prob_rightBlock (a := R3 B) + (fun w : Cube (Rest4 B) => P (leftBlock (rightBlock w))) + have h4 := prob_rightBlock (a := R4 B) (fun w : Cube (Rest5 B) => P (leftBlock w)) + rw [show (fun z : Cube (ROf B) => P (blk5 z)) + = fun z => P (leftBlock (rightBlock (rightBlock (rightBlock (rightBlock z))))) from rfl, + h1, h2, h3, h4] + exact prob_leftBlock P + +theorem prob_blk6 (P : Cube (R5 B) → Prop) : Pr[fun z : Cube (ROf B) => P (blk6 z)] = Pr[P] := by + have h1 := prob_rightBlock (a := R1 B) + (fun w : Cube (Rest2 B) => P (rightBlock (rightBlock (rightBlock (rightBlock w))))) + have h2 := prob_rightBlock (a := R2 B) + (fun w : Cube (Rest3 B) => P (rightBlock (rightBlock (rightBlock w)))) + have h3 := prob_rightBlock (a := R3 B) + (fun w : Cube (Rest4 B) => P (rightBlock (rightBlock w))) + have h4 := prob_rightBlock (a := R4 B) (fun w : Cube (Rest5 B) => P (rightBlock w)) + rw [show (fun z : Cube (ROf B) => P (blk6 z)) + = fun z => P (rightBlock (rightBlock (rightBlock (rightBlock (rightBlock z))))) from rfl, + h1, h2, h3, h4] + exact prob_rightBlock P + +/-! ### The checks -/ + +/-- The linearity check on a table, reading at the two halves of the block and +their sum. -/ +def LinCheck {m : ℕ} (f : BooleanFunction m) (x : Cube (m + m)) : Prop := + f (leftBlock x) * f (rightBlock x) = f (leftBlock x + rightBlock x) + +theorem prob_linCheck {m : ℕ} (f : BooleanFunction m) : + Pr[LinCheck f] = blrAcceptProb f := by + unfold blrAcceptProb + rw [prob₂_eq_prob_blocks] + rfl + +/-- **The tester's verdict**: all six checks pass on the random string. -/ +def AllChecks (S : Finset (Cube (kOf B))) (Tt Th : Cube B → ZMod 2) + (F : Cube (nOf B) → ZMod 2) (G : Cube (nOf B * nOf B) → ZMod 2) (z : Cube (ROf B)) : Prop := + LinCheck (signOf F) (blk1 z) + ∧ LinCheck (signOf G) (blk2 z) + ∧ TesterAccepts (signOf F) (signOf G) (blk3 z) + ∧ ConstraintAccepts (signOf F) (signOf G) + (QuadConstraint.combine (oneHotSystem S) (leftBlock (blk4 z))) (rightBlock (blk4 z)) + ∧ CoordAccepts (signOf F) Tt (inTail B) (blk5 z) + ∧ CoordAccepts (signOf F) Th (inHead B) (blk6 z) + +theorem isBooleanValued_signOf {m : ℕ} (F : Cube m → ZMod 2) : IsBooleanValued (signOf F) := by + intro x + show chi (F x) = 1 ∨ chi (F x) = -1 + rcases (by decide : ∀ u : ZMod 2, u = 0 ∨ u = 1) (F x) with h | h <;> rw [h] <;> simp [chi] + +/-! ### Soundness -/ + +/-- **Soundness of the assembled tester.** If the six checks all pass with +probability above `31/32`, the proof decodes to an assignment of the variables +that satisfies the one-hot system and whose two input parts are within `3/32` +of the input tables. -/ +theorem sound (S : Finset (Cube (kOf B))) (Tt Th : Cube B → ZMod 2) + (F : Cube (nOf B) → ZMod 2) (G : Cube (nOf B * nOf B) → ZMod 2) + (h : 1 - 1 / 32 < Pr[AllChecks S Tt Th F G]) : + ∃ a : Cube (nOf B), (∀ j, (oneHotSystem S j).Sat a) + ∧ bitDist Tt (tailPart a) ≤ 3 / 32 ∧ bitDist Th (headPart a) ≤ 3 / 32 := by + classical + have hf := isBooleanValued_signOf F + have hg := isBooleanValued_signOf G + -- each check passes with probability above 31/32 + have h1 : 1 - 1 / 32 < Pr[LinCheck (signOf F)] := by + rw [← prob_blk1 (LinCheck (signOf F))] + exact lt_of_lt_of_le h (prob_mono fun z hz => hz.1) + have h2 : 1 - 1 / 32 < Pr[LinCheck (signOf G)] := by + rw [← prob_blk2 (LinCheck (signOf G))] + exact lt_of_lt_of_le h (prob_mono fun z hz => hz.2.1) + have h3 : 1 - 1 / 32 < Pr[TesterAccepts (signOf F) (signOf G)] := by + rw [← prob_blk3 (TesterAccepts (signOf F) (signOf G))] + exact lt_of_lt_of_le h (prob_mono fun z hz => hz.2.2.1) + have h4 : 1 - 1 / 32 < Pr[fun x : Cube (R4 B) => ConstraintAccepts (signOf F) (signOf G) + (QuadConstraint.combine (oneHotSystem S) (leftBlock x)) (rightBlock x)] := by + rw [← prob_blk4 (fun x : Cube (R4 B) => ConstraintAccepts (signOf F) (signOf G) + (QuadConstraint.combine (oneHotSystem S) (leftBlock x)) (rightBlock x))] + exact lt_of_lt_of_le h (prob_mono fun z hz => hz.2.2.2.1) + have h5 : 1 - 1 / 32 < Pr[CoordAccepts (signOf F) Tt (inTail B)] := by + rw [← prob_blk5 (CoordAccepts (signOf F) Tt (inTail B))] + exact lt_of_lt_of_le h (prob_mono fun z hz => hz.2.2.2.2.1) + have h6 : 1 - 1 / 32 < Pr[CoordAccepts (signOf F) Th (inHead B)] := by + rw [← prob_blk6 (CoordAccepts (signOf F) Th (inHead B))] + exact lt_of_lt_of_le h (prob_mono fun z hz => hz.2.2.2.2.2) + -- decode + rw [prob_linCheck] at h1 h2 + obtain ⟨a, ha⟩ := exists_assignment_of_blr (signOf F) hf (1 / 32) (le_of_lt h1) + obtain ⟨b, hb⟩ := exists_assignment_of_blr (signOf G) hg (1 / 32) (le_of_lt h2) + have hfc : IsClose (signOf F) (signOf (hadamard a)) (1 / 32) := ha + have hgc : IsClose (signOf G) (signOf (hadamard b)) (1 / 32) := hb + have hb' : b = tensorAssign a := + eq_tensorAssign_of_prob_tester a b (signOf F) hf hfc (signOf G) hg hgc (by linarith) + have hsys := forall_checkValue_of_prob_combined a b (oneHotSystem S) (signOf F) hf hfc + (signOf G) hg hgc (by linarith) + refine ⟨a, fun j => ?_, ?_, ?_⟩ + · have := hsys j + rw [hb'] at this + exact this + · have hc := prob_coord_eq_ge a (signOf F) hf hfc Tt (inTail B) + rw [bitDist_comm, bitDist_eq_one_sub] + show 1 - Pr[fun r : Cube B => a (inTail B r) = Tt r] ≤ 3 / 32 + linarith + · have hc := prob_coord_eq_ge a (signOf F) hf hfc Th (inHead B) + rw [bitDist_comm, bitDist_eq_one_sub] + show 1 - Pr[fun r : Cube B => a (inHead B r) = Th r] ≤ 3 / 32 + linarith + +/-! ### Completeness -/ + +theorem linCheck_hadamard {m : ℕ} (a : Cube m) (x : Cube (m + m)) : + LinCheck (signOf (hadamard a)) x := by + show chi (hadamard a (leftBlock x)) * chi (hadamard a (rightBlock x)) + = chi (hadamard a (leftBlock x + rightBlock x)) + rw [hadamard_add_arg, BooleanAnalysis.Internal.chi_add] + +/-- The honest tables pass the constraint check on every random string. -/ +theorem constraintAccepts_of_honest {m : ℕ} (a : Cube m) (C : QuadConstraint m) (hC : C.Sat a) + (z : Cube (m + m * m)) : + ConstraintAccepts (signOf (hadamard a)) (signOf (hadamard (tensorAssign a))) C z := by + show signBit (signOf (hadamard (tensorAssign a)) (rightBlock z) + * signOf (hadamard (tensorAssign a)) (C.quad + rightBlock z)) + + signBit (signOf (hadamard a) (leftBlock z) * signOf (hadamard a) (C.lin + leftBlock z)) + + C.const = 0 + rw [corrected_read_honest, corrected_read_honest, signBit_chi, signBit_chi] + exact hC + +/-- **Completeness of the assembled tester.** The honest proof of an assignment +satisfying the system — its Hadamard encoding and that of its tensor square, +with the input tables read off the assignment — passes every check on every +random string. -/ +theorem complete (S : Finset (Cube (kOf B))) (a : Cube (nOf B)) + (ha : ∀ j, (oneHotSystem S j).Sat a) (z : Cube (ROf B)) : + AllChecks S (tailPart a) (headPart a) (hadamard a) (hadamard (tensorAssign a)) z := + ⟨linCheck_hadamard a _, linCheck_hadamard (tensorAssign a) _, testerAccepts_of_honest a _, + constraintAccepts_of_honest a _ (QuadConstraint.sat_combine (oneHotSystem S) a ha _) _, + coordAccepts_of_honest a (inTail B) _, coordAccepts_of_honest a (inHead B) _⟩ + +end Tester + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TesterInput.lean b/Complexitylib/Classes/PCP/Internal/TesterInput.lean new file mode 100644 index 00000000..c7a98023 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/TesterInput.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.HadamardTester + +/-! +# The tester reads its input + +An *assignment tester* is not a stand-alone proof system: it is given an input +assignment — in Dinur's composition, the bits the outer constraint graph has +already committed to at the two endpoints of an edge — and must reject unless +those very bits extend to a satisfying assignment. A tester that merely +certifies *some* satisfying assignment exists is useless there, because the +outer graph's assignment would be free to disagree with it. + +So the tester needs one more check: that the assignment `a` decoded from its +proof agrees, on the input coordinates, with the input `w` it is handed. The +check is the natural one — pick a random subset of the input coordinates, add up +those bits of `w` directly (the input is a constant number of bits, so this +costs nothing), and compare with the same subset-sum read off the proof by +self-correction. + +Soundness is the same rigidity argument that runs throughout the Hadamard +analysis: two assignments whose subset-sums agree on more than half of the +subsets are equal, because their difference would otherwise be a nonzero vector, +and a nonzero vector's subset-sums are odd exactly half the time +(`prob_hadamard_ne_zero`). + +## Main definitions + +- `Complexity.embedInput` — an input string as a point of the full cube +- `Complexity.InputAccepts` — the input-consistency check on the raw table + +## Main results + +- `Complexity.eq_of_prob_hadamard_eq` — rigidity: agreeing on more than half + the subset-sums forces equality +- `Complexity.eq_input_of_prob_inputAccepts` — **the tester verifies its + input**: passing the check often enough forces the decoded assignment to + agree with the input +- `Complexity.inputAccepts_of_honest` — and the honest proof always passes +- `Complexity.exists_sat_extending` — **the Hadamard code is an assignment + tester**: all four checks passing forces the input to extend to a satisfying + assignment +-/ + +@[expose] public section + +namespace Complexity + +open BooleanAnalysis + +variable {k t : ℕ} + +/-! ### Reading the input coordinates -/ + +/-- An input string, viewed as a point of the full cube: the input coordinates +carry it and the auxiliary coordinates are zero. Reading a Hadamard table here +returns a subset-sum of the input coordinates alone. -/ +def embedInput (r : Cube k) : Cube (k + t) := Fin.append r 0 + +/-- **Reading only the input coordinates.** A subset-sum of an assignment taken +at an embedded input string sees exactly the assignment's input part. -/ +theorem hadamard_embedInput (a : Cube (k + t)) (r : Cube k) : + hadamard a (embedInput r) = hadamard (leftBlock a) r := by + show ∑ i : Fin (k + t), a i * (Fin.append r (0 : Cube t)) i + = ∑ i : Fin k, a (Fin.castAdd t i) * r i + rw [Fin.sum_univ_add] + have hleft : ∀ i : Fin k, + a (Fin.castAdd t i) * (Fin.append r (0 : Cube t)) (Fin.castAdd t i) + = a (Fin.castAdd t i) * r i := fun i => by + rw [Fin.append_left] + have hright : ∀ j : Fin t, + a (Fin.natAdd k j) * (Fin.append r (0 : Cube t)) (Fin.natAdd k j) = 0 := fun j => by + rw [Fin.append_right] + show a (Fin.natAdd k j) * (0 : ZMod 2) = 0 + ring + rw [Finset.sum_congr rfl fun i _ => hleft i, Finset.sum_congr rfl fun j _ => hright j] + simp + +/-! ### Rigidity -/ + +/-- **Subset-sums determine an assignment.** If two assignments' subset-sums +agree on more than half of the subsets they are equal: otherwise their +difference is a nonzero vector, whose subset-sums are odd on exactly half. -/ +theorem eq_of_prob_hadamard_eq {m : ℕ} (u v : Cube m) + (h : 1 / 2 < Pr[fun r : Cube m => hadamard u r = hadamard v r]) : u = v := by + classical + by_contra hne + have hsum : u + v ≠ 0 := by + intro h0 + apply hne + funext i + have hi := congrFun h0 i + show u i = v i + rcases (by decide : ∀ x y : ZMod 2, x + y = 0 → x = y) (u i) (v i) hi with h' + exact h' + have hhalf := prob_hadamard_ne_zero (u + v) hsum + have hfail : (fun r : Cube m => hadamard (u + v) r ≠ 0) + = fun r : Cube m => ¬ (hadamard u r = hadamard v r) := by + funext r + rw [hadamard_add] + have hiff : (hadamard u r + hadamard v r = 0) ↔ (hadamard u r = hadamard v r) := by + rcases (by decide : ∀ x y : ZMod 2, (x + y = 0) ↔ (x = y)) (hadamard u r) + (hadamard v r) with h' + exact h' + exact propext (not_congr hiff) + rw [hfail] at hhalf + have hcompl := BooleanAnalysis.Internal.prob_compl + (fun r : Cube m => hadamard u r = hadamard v r) + linarith + +/-! ### The input-consistency check -/ + +/-- **The tester's input check**, made on the raw table: a random subset-sum of +the input, computed directly from the input bits, must equal the same subset-sum +read off the proof by self-correction. The first block picks the subset, the +second is the correction string. -/ +def InputAccepts (f : BooleanFunction (k + t)) (w : Cube k) + (z : Cube (k + (k + t))) : Prop := + signBit (f (rightBlock z) * f (embedInput (leftBlock z) + rightBlock z)) + = hadamard w (leftBlock z) + +/-- Every read of the input check is right except with probability `2ε`. The +subset is chosen by the first block and the correction by the second, so +`prob_blocks_ge` fixes the read point before the correction is drawn. -/ +theorem prob_input_reads (a : Cube (k + t)) (f : BooleanFunction (k + t)) + (hf : IsBooleanValued f) {ε : ℝ} (hfc : IsClose f (signOf (hadamard a)) ε) : + 1 - 2 * ε ≤ Pr[fun z : Cube (k + (k + t)) => + f (rightBlock z) * f (embedInput (leftBlock z) + rightBlock z) + = chi (hadamard a (embedInput (leftBlock z)))] := by + classical + refine prob_blocks_ge (fun u c => + f c * f (embedInput u + c) = chi (hadamard a (embedInput u))) _ fun u => ?_ + exact prob_read_ge f hf a hfc (embedInput u) + +/-- **The tester verifies its input.** If the input check passes on more than +half the randomness — with room for the reads' failure probability — then the +assignment decoded from the proof agrees with the input on every input +coordinate. + +Together with `exists_sat_of_prob_tester` this is the assignment-tester +guarantee Dinur's composition consumes: the proof cannot certify a satisfying +assignment other than an extension of the bits the outer graph committed to. -/ +theorem eq_input_of_prob_inputAccepts (a : Cube (k + t)) (w : Cube k) + (f : BooleanFunction (k + t)) (hf : IsBooleanValued f) {ε : ℝ} + (hfc : IsClose f (signOf (hadamard a)) ε) + (haccept : 1 / 2 + 2 * ε < Pr[InputAccepts f w]) : + leftBlock a = w := by + classical + have hgood := prob_input_reads a f hf hfc + have htrans := prob_le_of_imp_of_good (E := InputAccepts f w) + (F := fun z : Cube (k + (k + t)) => + hadamard a (embedInput (leftBlock z)) = hadamard w (leftBlock z)) + (A := fun z : Cube (k + (k + t)) => + f (rightBlock z) * f (embedInput (leftBlock z) + rightBlock z) + = chi (hadamard a (embedInput (leftBlock z)))) + fun z hE hA => by + have hE' : signBit (chi (hadamard a (embedInput (leftBlock z)))) + = hadamard w (leftBlock z) := by + rw [← hA] + exact hE + rwa [signBit_chi] at hE' + have hblk : Pr[fun z : Cube (k + (k + t)) => + hadamard a (embedInput (leftBlock z)) = hadamard w (leftBlock z)] + = Pr[fun r : Cube k => hadamard a (embedInput r) = hadamard w r] := + prob_leftBlock (fun r : Cube k => hadamard a (embedInput r) = hadamard w r) + rw [hblk] at htrans + have hrew : (fun r : Cube k => hadamard a (embedInput r) = hadamard w r) + = fun r : Cube k => hadamard (leftBlock a) r = hadamard w r := by + funext r + rw [hadamard_embedInput] + rw [hrew] at htrans + exact eq_of_prob_hadamard_eq (leftBlock a) w (by linarith) + +/-- **Completeness of the input check.** The honest proof for an assignment +extending the input passes on every random string. -/ +theorem inputAccepts_of_honest (a : Cube (k + t)) (z : Cube (k + (k + t))) : + InputAccepts (signOf (hadamard a)) (leftBlock a) z := by + show signBit (signOf (hadamard a) (rightBlock z) + * signOf (hadamard a) (embedInput (leftBlock z) + rightBlock z)) = _ + rw [corrected_read_honest, signBit_chi, hadamard_embedInput] + +/-- The honest proof passes the input check with probability one. -/ +theorem prob_inputAccepts_of_honest (a : Cube (k + t)) : + Pr[InputAccepts (signOf (hadamard a)) (leftBlock a)] = 1 := + prob_of_forall (inputAccepts_of_honest a) + +/-! ### The assignment tester -/ + +/-- **The Hadamard code is an assignment tester.** Given an input `w` and a +proof consisting of two tables, if all four checks — linearity of each table, +consistency of the quadratic table with the linear one, the constraint itself, +and agreement with the input — pass often enough, then the input extends to a +satisfying assignment of the constraint. + +Nothing is assumed about the tables. This is the whole guarantee Dinur's +alphabet-reduction step asks of its inner verifier: completeness is +`prob_testerAccepts_of_honest` together with `prob_inputAccepts_of_honest`, and +the query count and proof length depend only on the constraint's size, not on +the outer system's. -/ +theorem exists_sat_extending (C : QuadConstraint (k + t)) (w : Cube k) + (f : BooleanFunction (k + t)) (hf : IsBooleanValued f) + (g : BooleanFunction ((k + t) * (k + t))) (hg : IsBooleanValued g) {ε ε' : ℝ} + (hblrf : blrAcceptProb f ≥ 1 - ε) (hblrg : blrAcceptProb g ≥ 1 - ε') + (hcons : 3 / 4 + (4 * ε + 2 * ε') < Pr[TesterAccepts f g]) + (hchk : 2 * ε + 2 * ε' < Pr[ConstraintAccepts f g C]) + (hinp : 1 / 2 + 2 * ε < Pr[InputAccepts f w]) : + ∃ a : Cube (k + t), C.Sat a ∧ leftBlock a = w := by + classical + obtain ⟨a, ha⟩ := exists_assignment_of_blr f hf ε hblrf + obtain ⟨b, hb⟩ := exists_assignment_of_blr g hg ε' hblrg + have hfc : IsClose f (signOf (hadamard a)) ε := ha + have hgc : IsClose g (signOf (hadamard b)) ε' := hb + exact ⟨a, sat_of_prob_tester a b C f hf hfc g hg hgc hcons + (checkValue_eq_zero_of_prob a b C f hf hfc g hg hgc hchk), + eq_input_of_prob_inputAccepts a w f hf hfc hinp⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean b/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean new file mode 100644 index 00000000..8622d394 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ConstraintGraph +public import Complexitylib.SAT.ThreeCNF + +/-! +# From 3CNF-SAT to binary constraint graphs + +The standard reduction turning a 3CNF formula into a constraint graph over the +alphabet `Fin 3 → Bool`, together with its correctness proof. This is the entry +point of Dinur's proof of the PCP theorem: it produces the constraint graph +whose unsatisfiability value the amplification step then boosts. + +## The construction + +Given `φ : CNF`, the graph `toGraph φ` has + +* one **variable vertex** for each variable index `0 … φ.maxVar`, and +* one **clause vertex** for each clause of `φ`, numbered `(φ.maxVar + 1) + j`; +* one edge for each (clause, position) pair, so `3 * φ.length` edges in all. + +A variable vertex is meant to carry the value of its variable in bit `0` of its +label; a clause vertex is meant to carry the values of the three variables its +clause mentions, one per coordinate. The edge for clause `j` and position `p` +checks both that the clause vertex's triple satisfies clause `j` and that its +`p`-th coordinate agrees with the `p`-th variable vertex — the usual +consistency-plus-satisfaction pair of constraints. + +## Main definitions + +- `litOf` — a total lookup of the literal at a given clause and position +- `numVerts`, `numEdges`, `varVertex`, `clauseVertex`, `edgeClause`, `edgePos` +- `clauseSat` — whether a triple of bits satisfies a clause +- `toGraph` — the constraint graph produced by the reduction +- `vertexLabel`, `mkAssign` — the two translations between assignments + +## Main results + +- `numVerts_toGraph`, `numEdges_toGraph` — the size of the produced graph +- `satisfiable_toGraph_iff` — correctness of the reduction on 3CNF inputs +-/ + +@[expose] public section + +namespace Complexity + +namespace ThreeSATCSP + +open SAT + +/-! ### Indexing helpers -/ + +/-- The literal at position `p` of clause `j` of `φ`, defaulting to the positive +literal on variable `0` when either index is out of range. Totality keeps the +reduction free of dependent-index bookkeeping. -/ +def litOf (φ : CNF) (j : ℕ) (p : Fin 3) : Lit := + ((φ[j]?).getD []).getD p.val ⟨false, 0⟩ + +/-- The number of vertices of the constraint graph of `φ`: one per variable +index `0 … φ.maxVar`, then one per clause. -/ +def numVerts (φ : CNF) : ℕ := (φ.maxVar + 1) + φ.length + +/-- The number of edges of the constraint graph of `φ`: three per clause. -/ +def numEdges (φ : CNF) : ℕ := 3 * φ.length + +/-- The constraint graph of `φ` always has at least one vertex, namely the +variable vertex `0`. -/ +theorem numVerts_pos (φ : CNF) : 0 < numVerts φ := by + unfold numVerts; omega + +/-- The vertex carrying the value of variable `v`; out-of-range indices are +folded onto vertex `0`. -/ +def varVertex (φ : CNF) (v : ℕ) : Fin (numVerts φ) := + if h : v < numVerts φ then ⟨v, h⟩ else ⟨0, numVerts_pos φ⟩ + +/-- The vertex carrying the claimed values of the variables of clause `j`; +out-of-range indices are folded onto vertex `0`. -/ +def clauseVertex (φ : CNF) (j : ℕ) : Fin (numVerts φ) := + if h : (φ.maxVar + 1) + j < numVerts φ then ⟨(φ.maxVar + 1) + j, h⟩ + else ⟨0, numVerts_pos φ⟩ + +/-- The clause that edge number `e` belongs to. -/ +def edgeClause (e : ℕ) : ℕ := e / 3 + +/-- The position inside its clause that edge number `e` checks. -/ +def edgePos (e : ℕ) : Fin 3 := ⟨e % 3, Nat.mod_lt _ (by omega)⟩ + +/-- Whether the triple `cl` of claimed variable values satisfies clause `j`: +some position's claimed value matches that literal's sign. -/ +def clauseSat (φ : CNF) (j : ℕ) (cl : Fin 3 → Bool) : Bool := + decide (∃ q : Fin 3, cl q = (litOf φ j q).sign) + +/-- `clauseSat` reflects the existential it decides. -/ +theorem clauseSat_eq_true_iff {φ : CNF} {j : ℕ} {cl : Fin 3 → Bool} : + clauseSat φ j cl = true ↔ ∃ q : Fin 3, cl q = (litOf φ j q).sign := by + simp [clauseSat] + +/-! ### The reduction -/ + +/-- The constraint graph of a 3CNF formula `φ`. Variable vertices come first, +clause vertices after them; edge `e` links clause vertex `edgeClause e` to the +variable vertex of the literal at position `edgePos e` of that clause, and its +constraint demands both that the clause vertex's triple satisfies the clause and +that it agrees with the variable vertex on bit `0`. -/ +def toGraph (φ : CNF) : ConstraintGraph (Fin 3 → Bool) where + numVerts := numVerts φ + numEdges := numEdges φ + tail e := clauseVertex φ (edgeClause e.val) + head e := varVertex φ (litOf φ (edgeClause e.val) (edgePos e.val)).var + rel e cl va := clauseSat φ (edgeClause e.val) cl && (cl (edgePos e.val) == va 0) + +/-- The reduction produces `3 * φ.length` edges. -/ +theorem numEdges_toGraph (φ : CNF) : (toGraph φ).numEdges = 3 * φ.length := rfl + +/-- The reduction produces `(φ.maxVar + 1) + φ.length` vertices. -/ +theorem numVerts_toGraph (φ : CNF) : + (toGraph φ).numVerts = (φ.maxVar + 1) + φ.length := rfl + +/-! ### Basic facts about the indexing helpers -/ + +/-- A variable vertex within range keeps its index. -/ +theorem varVertex_val {φ : CNF} {v : ℕ} (hv : v ≤ φ.maxVar) : + (varVertex φ v).val = v := by + have h : v < numVerts φ := by unfold numVerts; omega + simp [varVertex, h] + +/-- A clause vertex of an existing clause sits at index `(φ.maxVar + 1) + j`. -/ +theorem clauseVertex_val {φ : CNF} {j : ℕ} (hj : j < φ.length) : + (clauseVertex φ j).val = (φ.maxVar + 1) + j := by + have h : (φ.maxVar + 1) + j < numVerts φ := by unfold numVerts; omega + simp [clauseVertex, h] + +/-- `litOf` really reads the list entry it is meant to read. -/ +theorem litOf_eq {φ : CNF} {j : ℕ} {c : Clause} (hc : φ[j]? = some c) {p : Fin 3} + (hp : p.val < c.length) : litOf φ j p = c[p.val] := by + rw [litOf, hc, Option.getD_some, List.getD_eq_getElem?_getD, + List.getElem?_eq_getElem hp, Option.getD_some] + +/-- Every literal produced by `litOf` at an existing clause really occurs in +that clause, provided the clause has three literals. -/ +theorem litOf_mem {φ : CNF} {j : ℕ} {c : Clause} (hc : φ[j]? = some c) + (hlen : c.length = 3) (p : Fin 3) : litOf φ j p ∈ c := by + have hp : p.val < c.length := by omega + rw [litOf_eq hc hp] + exact List.getElem_mem hp + +/-- Every edge belongs to a clause that exists. -/ +theorem edgeClause_lt {φ : CNF} (e : Fin (toGraph φ).numEdges) : + edgeClause e.val < φ.length := by + have h : e.val < 3 * φ.length := e.isLt + unfold edgeClause + omega + +/-- Every (clause, position) pair is realized by an edge. -/ +theorem exists_edge {φ : CNF} {j : ℕ} (hj : j < φ.length) (q : Fin 3) : + ∃ e : Fin (toGraph φ).numEdges, edgeClause e.val = j ∧ edgePos e.val = q := by + have hq := q.isLt + refine ⟨⟨3 * j + q.val, ?_⟩, ?_, ?_⟩ + · show 3 * j + q.val < 3 * φ.length; omega + · show (3 * j + q.val) / 3 = j; omega + · apply Fin.ext; show (3 * j + q.val) % 3 = q.val; omega + +/-- The edge constraint of `toGraph`, spelled out. -/ +theorem satisfies_iff {φ : CNF} {a : (toGraph φ).Assignment} + (e : Fin (toGraph φ).numEdges) : + (toGraph φ).Satisfies a e ↔ + (clauseSat φ (edgeClause e.val) (a (clauseVertex φ (edgeClause e.val))) = true ∧ + a (clauseVertex φ (edgeClause e.val)) (edgePos e.val) + = a (varVertex φ (litOf φ (edgeClause e.val) (edgePos e.val)).var) 0) := by + simp [ConstraintGraph.Satisfies, ConstraintGraph.satisfies, toGraph] + +/-- Every literal of a 3CNF formula mentions a variable at most `φ.maxVar`. -/ +theorem var_litOf_le_maxVar {φ : CNF} (h3 : φ.Is3CNF) {j : ℕ} (hj : j < φ.length) + (p : Fin 3) : (litOf φ j p).var ≤ φ.maxVar := by + have hmem : φ[j] ∈ φ := List.getElem_mem hj + have hc : φ[j]? = some φ[j] := List.getElem?_eq_getElem hj + have hlen : (φ[j]).length = 3 := h3 _ hmem + calc (litOf φ j p).var ≤ (φ[j]).maxVar := + Clause.var_le_maxVar (litOf_mem hc hlen p) + _ ≤ φ.maxVar := CNF.clause_maxVar_le_maxVar hmem + +/-! ### Translating assignments -/ + +/-- The label the graph assignment induced by a CNF assignment `α` puts on +vertex number `w`: a variable vertex gets the constant value of its variable, a +clause vertex gets the values of the three variables its clause mentions. -/ +def vertexLabel (φ : CNF) (α : SAT.Assignment) (w : ℕ) : Fin 3 → Bool := + if w < φ.maxVar + 1 then (fun _ => Assignment.get α w) + else (fun q => Assignment.get α (litOf φ (w - (φ.maxVar + 1)) q).var) + +/-- The label of a variable vertex. -/ +theorem vertexLabel_var {φ : CNF} {α : SAT.Assignment} {v : ℕ} (hv : v ≤ φ.maxVar) : + vertexLabel φ α v = fun _ => Assignment.get α v := by + have h : v < φ.maxVar + 1 := by omega + simp [vertexLabel, h] + +/-- The label of a clause vertex. -/ +theorem vertexLabel_clause {φ : CNF} {α : SAT.Assignment} {j : ℕ} : + vertexLabel φ α ((φ.maxVar + 1) + j) + = fun q => Assignment.get α (litOf φ j q).var := by + have h : ¬ ((φ.maxVar + 1) + j < φ.maxVar + 1) := by omega + simp [vertexLabel, h] + +/-- The CNF assignment read off from a graph assignment: variable `v` takes the +value of bit `0` of the label of its variable vertex. -/ +def mkAssign (φ : CNF) (a : (toGraph φ).Assignment) : SAT.Assignment := + (List.range (φ.maxVar + 1)).map (fun v => a (varVertex φ v) 0) + +/-- `mkAssign` reads back the label bit it was built from. -/ +theorem get_mkAssign {φ : CNF} {a : (toGraph φ).Assignment} {v : ℕ} + (hv : v ≤ φ.maxVar) : Assignment.get (mkAssign φ a) v = a (varVertex φ v) 0 := by + have hlen : v < (mkAssign φ a).length := by + simp [mkAssign]; omega + have hr : v < (List.range (φ.maxVar + 1)).length := by simp; omega + simp [Assignment.get, mkAssign, List.getElem?_map, + List.getElem?_eq_getElem hr] + +/-! ### Correctness -/ + +/-- **Correctness of the reduction.** For a 3CNF formula, the constraint graph +produced by `toGraph` is satisfiable exactly when the formula is. -/ +theorem satisfiable_toGraph_iff {φ : CNF} (h3 : φ.Is3CNF) : + (toGraph φ).Satisfiable ↔ φ.Satisfiable := by + constructor + · rintro ⟨a, ha⟩ + refine ⟨mkAssign φ a, ?_⟩ + rw [CNF.eval, List.all_eq_true] + intro c hcmem + obtain ⟨j, hj, rfl⟩ := List.getElem_of_mem hcmem + obtain ⟨e0, hc0, -⟩ := exists_edge (φ := φ) hj 0 + have h0 := (satisfies_iff e0).mp (ha e0) + rw [hc0] at h0 + obtain ⟨q, hq⟩ := clauseSat_eq_true_iff.mp h0.1 + obtain ⟨e1, hc1, hp1⟩ := exists_edge (φ := φ) hj q + have h1 := (satisfies_iff e1).mp (ha e1) + rw [hc1, hp1] at h1 + have hvar : (litOf φ j q).var ≤ φ.maxVar := var_litOf_le_maxVar h3 hj q + have hval : Assignment.get (mkAssign φ a) (litOf φ j q).var = (litOf φ j q).sign := by + rw [get_mkAssign hvar, ← h1.2, hq] + rw [Clause.eval, List.any_eq_true] + refine ⟨litOf φ j q, litOf_mem (List.getElem?_eq_getElem hj) (h3 _ hcmem) q, ?_⟩ + simp [Lit.eval, hval] + · rintro ⟨α, hα⟩ + refine ⟨fun w => vertexLabel φ α w.val, ?_⟩ + intro e + have hj : edgeClause e.val < φ.length := edgeClause_lt e + rw [satisfies_iff] + set j := edgeClause e.val with hjd + set p := edgePos e.val with hpd + have hvar : (litOf φ j p).var ≤ φ.maxVar := var_litOf_le_maxVar h3 hj p + have hcl : vertexLabel φ α (clauseVertex φ j).val + = fun q => Assignment.get α (litOf φ j q).var := by + rw [clauseVertex_val hj]; exact vertexLabel_clause + have hhead : vertexLabel φ α (varVertex φ (litOf φ j p).var).val + = fun _ => Assignment.get α (litOf φ j p).var := by + rw [varVertex_val hvar]; exact vertexLabel_var hvar + simp only [hcl, hhead] + refine ⟨clauseSat_eq_true_iff.mpr ?_, trivial⟩ + have hlen : (φ[j]).length = 3 := h3 _ (List.getElem_mem hj) + have hcls : Clause.eval α φ[j] = true := by + rw [CNF.eval, List.all_eq_true] at hα + exact hα _ (List.getElem_mem hj) + rw [Clause.eval, List.any_eq_true] at hcls + obtain ⟨ℓ, hℓmem, hℓ⟩ := hcls + obtain ⟨i, hi, rfl⟩ := List.getElem_of_mem hℓmem + refine ⟨⟨i, by omega⟩, ?_⟩ + rw [litOf_eq (p := ⟨i, by omega⟩) (List.getElem?_eq_getElem hj) hi] + simpa [Lit.eval] using hℓ + +end ThreeSATCSP + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TowerFamily.lean b/Complexitylib/Classes/PCP/Internal/TowerFamily.lean new file mode 100644 index 00000000..f63b27a2 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/TowerFamily.lean @@ -0,0 +1,281 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.SizedExpander +public import Complexitylib.Classes.PCP.Internal.MergeGen + +/-! +# The exact-size family a tower gives + +Assembling the pieces: for a requested size `n`, take the first tower member at +least twice as large, number its vertices and darts, fold it onto `n` at the +width the overshoot dictates, and pad the degree up to a bound that does not +depend on `n`. + +Each step has been justified separately — `toFinForm` numbers the types, +`spectralBound_mergedN` folds at any width, `spectralBound_padLoops` pads the +degree — and this module only has to supply the arithmetic linking them. + +## Main definitions + +- `Complexity.ZigZagBase.famGraph` — the member for a requested size + +## Main results + +- `Complexity.ZigZagBase.order_famGraph`, `deg_famGraph` — it has exactly the + requested size, and a degree independent of it +-/ + +@[expose] public section + +namespace Complexity + +namespace ZigZagBase + +variable (B : ZigZagBase) (hd : 1 < B.base.deg) + +/-- The width bound: the overshoot of the tower is at most `2 deg ^ 4`. -/ +def widthBound : ℕ := 2 * B.base.deg ^ 4 + 1 + +/-- The family's degree: the width bound times the tower's degree. -/ +def famDegree : ℕ := B.widthBound * B.base.deg ^ 2 + +theorem famDegree_pos : 0 < B.famDegree := by + have h1 : 0 < B.widthBound := by + rw [widthBound] + omega + have h2 : 0 < B.base.deg ^ 2 := by + have := B.base.deg_pos + positivity + rw [famDegree] + exact Nat.mul_pos h1 h2 + +/-- The size of the tower member used for `n`. -/ +noncomputable def fitN (n : ℕ) : ℕ := (tower B (B.fitIndex hd n)).graph.order + +/-- The degree of every tower member. -/ +def fitD : ℕ := B.base.deg ^ 2 + +theorem fitD_pos : 0 < B.fitD := by + have := B.base.deg_pos + rw [fitD] + positivity + +/-- The tower member used for size `n`, with both its types numbered. -/ +noncomputable def fitGraph (n : ℕ) : RegGraph := + (tower B (B.fitIndex hd n)).graph.toFinFormOf (B.fitN hd n) B.fitD rfl (deg_fit B hd n) + +@[simp] theorem order_fitGraph (n : ℕ) : (B.fitGraph hd n).order = B.fitN hd n := + RegGraph.order_toFinFormOf _ _ _ _ _ + +@[simp] theorem deg_fitGraph (n : ℕ) : (B.fitGraph hd n).deg = B.fitD := + RegGraph.deg_toFinFormOf _ _ _ _ _ + +theorem spectral_fitGraph (n : ℕ) : (B.fitGraph hd n).SpectralBound (2 / 5) := + RegGraph.spectralBound_toFinFormOf _ _ _ _ _ (spectral_fit B hd n) + +/-- The width used to fold that member onto `n`. -/ +noncomputable def fitWidth (n : ℕ) : ℕ := RegGraph.mergeWidth (B.fitN hd n) n + +theorem three_le_fitWidth {n : ℕ} (hn : 0 < n) : 3 ≤ B.fitWidth hd n := + RegGraph.three_le_mergeWidth hn (two_mul_le_order_fit B hd n) + +theorem fitWidth_pos {n : ℕ} (hn : 0 < n) : 0 < B.fitWidth hd n := by + have := B.three_le_fitWidth hd hn + omega + +theorem fitWidth_le {n : ℕ} (hn : 0 < n) : B.fitWidth hd n ≤ B.widthBound := by + rw [fitWidth, widthBound] + exact RegGraph.mergeWidth_le hn (order_fit_le B hd n hn) + +theorem fitN_le_fitWidth_mul {n : ℕ} (hn : 0 < n) : B.fitN hd n ≤ B.fitWidth hd n * n := + RegGraph.le_mergeWidth_mul _ hn + +theorem fitWidth_sub_one_mul_le (n : ℕ) : (B.fitWidth hd n - 1) * n ≤ B.fitN hd n := + RegGraph.mergeWidth_sub_one_mul_le _ _ + +theorem two_mul_le_fitN (n : ℕ) : 2 * n ≤ B.fitN hd n := two_mul_le_order_fit B hd n + +/-- The rotation map of that member, at the numeric type it lives on. -/ +noncomputable def fitRot (n : ℕ) : + Fin (B.fitN hd n) × Fin B.fitD → Fin (B.fitN hd n) × Fin B.fitD := + (B.fitGraph hd n).rot + +theorem fitRot_involutive (n : ℕ) : Function.Involutive (B.fitRot hd n) := + (B.fitGraph hd n).rot_involutive + +theorem base_fitGraph (n : ℕ) : + RegGraph.ofRot B.fitD B.fitD_pos (B.fitN hd n) (B.fitRot hd n) (B.fitRot_involutive hd n) + = B.fitGraph hd n := rfl + +/-! ### The fold -/ + +/-- The tower member folded onto exactly `n` vertices. -/ +noncomputable def mergedGraph {n : ℕ} (hn : 0 < n) : RegGraph := + RegGraph.mergedN hn B.fitD_pos (B.fitWidth_pos hd hn) (B.fitN_le_fitWidth_mul hd hn) + (B.fitRot hd n) (B.fitRot_involutive hd n) + +@[simp] theorem order_mergedGraph {n : ℕ} (hn : 0 < n) : (B.mergedGraph hd hn).order = n := + RegGraph.order_mergedN _ _ _ _ _ _ + +@[simp] theorem deg_mergedGraph {n : ℕ} (hn : 0 < n) : + (B.mergedGraph hd hn).deg = B.fitWidth hd n * B.fitD := + RegGraph.deg_mergedN _ _ _ _ _ _ + +/-- Folding at width at least three keeps the contraction below `4/5`. -/ +theorem spectral_mergedGraph {n : ℕ} (hn : 0 < n) : + (B.mergedGraph hd hn).SpectralBound (4 / 5) := by + have hspec : (RegGraph.base B.fitD_pos (B.fitRot hd n) + (B.fitRot_involutive hd n)).SpectralBound (2 / 5) := by + rw [show RegGraph.base B.fitD_pos (B.fitRot hd n) (B.fitRot_involutive hd n) + = B.fitGraph hd n from B.base_fitGraph hd n] + exact B.spectral_fitGraph hd n + have hmerged := RegGraph.spectralBound_mergedN hn B.fitD_pos (B.fitWidth_pos hd hn) + (B.fitN_le_fitWidth_mul hd hn) (B.fitWidth_sub_one_mul_le hd n) (B.two_mul_le_fitN hd n) + (B.fitRot hd n) (B.fitRot_involutive hd n) (by norm_num) hspec + refine hmerged.mono (Real.sqrt_nonneg _) ?_ + rw [show (4 : ℝ) / 5 = Real.sqrt ((4 / 5) ^ 2) by + rw [Real.sqrt_sq (by norm_num)]] + refine Real.sqrt_le_sqrt ?_ + have hm3 : (3 : ℝ) ≤ (B.fitWidth hd n : ℝ) := by + exact_mod_cast B.three_le_fitWidth hd hn + have hm0 : (0 : ℝ) < (B.fitWidth hd n : ℝ) := by linarith + set m : ℝ := (B.fitWidth hd n : ℝ) + have h1 : (1 - (2 / 5 : ℝ) ^ 2) / (2 * m) ≤ (1 - (2 / 5 : ℝ) ^ 2) / (2 * 3) := by + apply div_le_div_of_nonneg_left (by norm_num) (by norm_num) (by linarith) + have h2 : (1 : ℝ) / m ≤ 1 / 3 := by + apply div_le_div_of_nonneg_left (by norm_num) (by norm_num) hm3 + nlinarith [h1, h2] + +/-! ### The padding -/ + +theorem fitWidth_mul_fitD_le {n : ℕ} (hn : 0 < n) : + B.fitWidth hd n * B.fitD ≤ B.famDegree := + Nat.mul_le_mul_right _ (B.fitWidth_le hd hn) + +/-- The fold padded up to the family's uniform degree. -/ +noncomputable def paddedGraph {n : ℕ} (hn : 0 < n) : RegGraph := + (B.mergedGraph hd hn).padLoops (B.famDegree - B.fitWidth hd n * B.fitD) + +@[simp] theorem order_paddedGraph {n : ℕ} (hn : 0 < n) : (B.paddedGraph hd hn).order = n := + B.order_mergedGraph hd hn + +@[simp] theorem deg_paddedGraph {n : ℕ} (hn : 0 < n) : + (B.paddedGraph hd hn).deg = B.famDegree := by + rw [paddedGraph, RegGraph.deg_padLoops, deg_mergedGraph] + have := B.fitWidth_mul_fitD_le hd hn + omega + +/-- The uniform contraction factor of the family. -/ +noncomputable def famLam : ℝ := Real.sqrt (1 - 27 / (25 * B.widthBound)) + +theorem three_le_widthBound : 3 ≤ B.widthBound := by + have := B.base.deg_pos + have : 1 ≤ B.base.deg ^ 4 := Nat.one_le_pow _ _ this + rw [widthBound] + omega + +theorem famLam_nonneg : 0 ≤ B.famLam := Real.sqrt_nonneg _ + +theorem famLam_lt_one : B.famLam < 1 := by + have hW : (3 : ℝ) ≤ (B.widthBound : ℝ) := by exact_mod_cast B.three_le_widthBound + have hWpos : (0 : ℝ) < (B.widthBound : ℝ) := by linarith + have h0 : (0 : ℝ) ≤ 1 - 27 / (25 * B.widthBound) := by + rw [sub_nonneg, div_le_one (by linarith)] + linarith + have hlt : (1 : ℝ) - 27 / (25 * B.widthBound) < 1 := by + have : (0 : ℝ) < 27 / (25 * B.widthBound) := by positivity + linarith + calc B.famLam = Real.sqrt (1 - 27 / (25 * B.widthBound)) := rfl + _ < Real.sqrt 1 := Real.sqrt_lt_sqrt h0 hlt + _ = 1 := Real.sqrt_one + +theorem spectral_paddedGraph {n : ℕ} (hn : 0 < n) : + (B.paddedGraph hd hn).SpectralBound B.famLam := by + have hpad := RegGraph.spectralBound_padLoops (G := B.mergedGraph hd hn) + (B.famDegree - B.fitWidth hd n * B.fitD) (B.spectral_mergedGraph hd hn) + refine hpad.mono (Real.sqrt_nonneg _) ?_ + rw [famLam] + refine Real.sqrt_le_sqrt ?_ + have hle : B.fitWidth hd n * B.fitD ≤ B.famDegree := B.fitWidth_mul_fitD_le hd hn + have hF : (0 : ℝ) < (B.fitD : ℝ) := by exact_mod_cast B.fitD_pos + have hW : (3 : ℝ) ≤ (B.widthBound : ℝ) := by exact_mod_cast B.three_le_widthBound + have hm : (3 : ℝ) ≤ (B.fitWidth hd n : ℝ) := by exact_mod_cast B.three_le_fitWidth hd hn + have hDeg : ((B.famDegree : ℝ)) = (B.widthBound : ℝ) * (B.fitD : ℝ) := by + rw [famDegree, fitD]; push_cast; ring + have hk : (((B.famDegree - B.fitWidth hd n * B.fitD : ℕ) : ℝ)) + = (B.famDegree : ℝ) - (B.fitWidth hd n : ℝ) * (B.fitD : ℝ) := by + rw [Nat.cast_sub hle]; push_cast; ring + have hWpos : (0 : ℝ) < (B.widthBound : ℝ) := by linarith + have hDpos : (0 : ℝ) < (B.widthBound : ℝ) * (B.fitD : ℝ) := by positivity + rw [B.deg_mergedGraph hd hn, hk] + push_cast + rw [hDeg, show ((B.fitWidth hd n : ℝ) * (B.fitD : ℝ) + + ((B.widthBound : ℝ) * (B.fitD : ℝ) - (B.fitWidth hd n : ℝ) * (B.fitD : ℝ))) + = (B.widthBound : ℝ) * (B.fitD : ℝ) from by ring, div_le_iff₀ hDpos, sub_mul, one_mul, + show 27 / (25 * (B.widthBound : ℝ)) * ((B.widthBound : ℝ) * (B.fitD : ℝ)) + = 27 * (B.fitD : ℝ) / 25 from by field_simp] + nlinarith [mul_le_mul_of_nonneg_right hm (le_of_lt hF)] + +/-! ### The family -/ + +/-- The member of the family on `n` vertices, for `n` positive: the padded fold, +with its darts numbered by the family's uniform degree. -/ +noncomputable def famGraphPos {n : ℕ} (hn : 0 < n) : RegGraph := + (B.paddedGraph hd hn).relabel + (Fintype.equivFinOfCardEq (B.deg_paddedGraph hd hn)) + +theorem famGraphPos_V {n : ℕ} (hn : 0 < n) : (B.famGraphPos hd hn).V = Fin n := rfl + +theorem famGraphPos_D {n : ℕ} (hn : 0 < n) : (B.famGraphPos hd hn).D = Fin B.famDegree := rfl + +theorem spectral_famGraphPos {n : ℕ} (hn : 0 < n) : + (B.famGraphPos hd hn).SpectralBound B.famLam := + RegGraph.spectralBound_relabel _ _ (B.spectral_paddedGraph hd hn) + +/-- The family's rotation map: the padded fold when there is anything to fold, +and the identity on the empty vertex set otherwise. -/ +noncomputable def famRot (n : ℕ) : + Fin n × Fin B.famDegree → Fin n × Fin B.famDegree := + if hn : 0 < n then (B.famGraphPos hd hn).rot else id + +theorem famRot_involutive (n : ℕ) : Function.Involutive (B.famRot hd n) := by + rw [famRot] + split + · exact (B.famGraphPos hd ‹_›).rot_involutive + · exact fun x => rfl + +theorem famRot_eq {n : ℕ} (hn : 0 < n) : B.famRot hd n = (B.famGraphPos hd hn).rot := by + rw [famRot, dif_pos hn] + +theorem spectral_famRot (n : ℕ) : + (RegGraph.ofRot B.famDegree B.famDegree_pos n (B.famRot hd n) + (B.famRot_involutive hd n)).SpectralBound B.famLam := by + rcases Nat.eq_zero_or_pos n with h | hn + · subst h + exact RegGraph.spectralBound_of_isEmpty (by exact Fin.isEmpty' ) _ + · have key : ∀ (r : Fin n × Fin B.famDegree → Fin n × Fin B.famDegree) + (hr : Function.Involutive r), r = (B.famGraphPos hd hn).rot → + (RegGraph.ofRot B.famDegree B.famDegree_pos n r hr).SpectralBound B.famLam := by + rintro r hr rfl + exact B.spectral_famGraphPos hd hn + exact key _ _ (B.famRot_eq hd hn) + +/-- The expander family a zig-zag base generates: one member at every size, of a +degree that does not depend on the size, all contracting by the same factor. -/ +noncomputable def family : ExpanderFamily where + degree := B.famDegree + degree_pos := B.famDegree_pos + rot := B.famRot hd + rot_involutive := B.famRot_involutive hd + lam := B.famLam + lam_nonneg := B.famLam_nonneg + lam_lt_one := B.famLam_lt_one + spectral := B.spectral_famRot hd + +end ZigZagBase + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TowerFin.lean b/Complexitylib/Classes/PCP/Internal/TowerFin.lean new file mode 100644 index 00000000..c24d6222 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/TowerFin.lean @@ -0,0 +1,497 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ZigZagBaseExists + +/-! +# The zig-zag tower, numbered + +`ZigZagTower` builds its members out of nested product types and names the +base's vertices by an arbitrary bijection. That is enough for the mathematics, +but an algorithm has to be handed numbers. This module rebuilds the tower with +every vertex and dart numbered, and with each naming chosen explicitly: pairs +are packed by `finProdFinEquiv`, so a level-`k` vertex is a mixed-radix numeral +with `k + 1` digits in base `deg ^ 4`. + +The recursion carries its own involutivity proof, which is what lets the next +level's types be `Fin` on the nose rather than up to a transport. + +## Main definitions + +- `Complexity.FinBase` — a numbered zig-zag base +- `Complexity.FinBase.data` — the rotation map at each level, with its proof +- `Complexity.FinBase.graphAt` — the level's graph +- `Complexity.FinBase.rotVal` — the same rotation map on raw numbers + +## Main results + +- `Complexity.FinBase.graphAt_succ` — one level is a zig-zag of the previous +- `Complexity.FinBase.spectral_graphAt` — every level has bound `2 / 5` +- `Complexity.FinBase.rotVal_eq` — the numeric recursion computes it +- `Complexity.FinBase.toSized` — the numbered tower as a size-flexible family +- `Complexity.nonempty_finBase` — a numbered base exists +-/ + +@[expose] public section + +namespace Complexity + +/-! ### The recursion, in the open -/ + +namespace RegGraph + +/-- The rotation map of the square: walk two darts, and hand back the two +return labels in the opposite order. -/ +theorem rot_power_two (G : RegGraph) (v : G.V) (s : Fin 2 → G.D) : + (G.power 2).rot (v, s) = + ((G.rot ((G.rot (v, s 0)).1, s 1)).1, + ![(G.rot ((G.rot (v, s 0)).1, s 1)).2, (G.rot (v, s 0)).2]) := by + have hw1 : G.walkAt 2 v s 1 = (G.rot (v, s 0)).1 := by + rw [G.walkAt_succ_of_lt v s (by norm_num : (0 : ℕ) < 2)] + rfl + have hw2 : G.walkAt 2 v s 2 = (G.rot ((G.rot (v, s 0)).1, s 1)).1 := by + rw [G.walkAt_succ_of_lt v s (by norm_num : (1 : ℕ) < 2), hw1] + rfl + refine Prod.ext ?_ ?_ + · show G.walkEnd 2 v s = _ + rw [← G.walkAt_self_eq_walkEnd] + exact hw2 + · show G.revWalk v s = _ + funext j + fin_cases j + · show G.backLabel v s (Fin.rev 0) = _ + show (G.rot (G.walkAt 2 v s (Fin.rev (0 : Fin 2)).val, s (Fin.rev 0))).2 = _ + norm_num [hw1] + rfl + · show G.backLabel v s (Fin.rev 1) = _ + show (G.rot (G.walkAt 2 v s (Fin.rev (1 : Fin 2)).val, s (Fin.rev 1))).2 = _ + norm_num + rfl + +end RegGraph + +/-- A zig-zag base with its vertices and darts numbered: `deg ^ 4` vertices, +`deg` darts, and a spectral bound of a fifth. -/ +structure FinBase where + /-- The degree. -/ + deg : ℕ + /-- The degree is positive. -/ + deg_pos : 0 < deg + /-- The rotation map. -/ + rot : Fin (deg ^ 4) × Fin deg → Fin (deg ^ 4) × Fin deg + /-- It is an involution. -/ + rot_involutive : Function.Involutive rot + /-- The spectral bound. -/ + lam : ℝ + /-- It is nonnegative. -/ + lam_nonneg : 0 ≤ lam + /-- And at most a fifth. -/ + lam_le : lam ≤ 1 / 5 + /-- The bound holds. -/ + spectral : (RegGraph.ofRot deg deg_pos (deg ^ 4) rot rot_involutive).SpectralBound lam + +namespace FinBase + +variable (F : FinBase) + +/-- The base graph. -/ +def graph : RegGraph := RegGraph.ofRot F.deg F.deg_pos (F.deg ^ 4) F.rot F.rot_involutive + +@[simp] theorem V_graph : F.graph.V = Fin (F.deg ^ 4) := rfl + +@[simp] theorem D_graph : F.graph.D = Fin F.deg := rfl + +@[simp] theorem deg_graph : F.graph.deg = F.deg := Fintype.card_fin _ + +theorem sq_pos : 0 < F.deg ^ 2 := pow_pos F.deg_pos 2 + +/-- The number of vertices at level `k`. -/ +def size (k : ℕ) : ℕ := (F.deg ^ 4) ^ (k + 1) + +theorem size_succ (k : ℕ) : F.size (k + 1) = F.size k * F.deg ^ 4 := by + rw [size, size, pow_succ] + +/-- **The numbered base is a zig-zag base.** -/ +def toBase : ZigZagBase where + base := F.graph + card_eq := by + show Fintype.card (Fin (F.deg ^ 4)) = F.graph.deg ^ 4 + rw [Fintype.card_fin, deg_graph] + lam := F.lam + lam_nonneg := F.lam_nonneg + lam_le := F.lam_le + spectral := F.spectral + +/-! ### The chosen namings -/ + +/-- Two darts of the base, as one dart of the level. -/ +def dartName : Fin F.deg × Fin F.deg ≃ Fin (F.deg ^ 2) := + finProdFinEquiv.trans (finCongr (by ring)) + +/-- The base's vertices name the pairs of darts of a level. -/ +def baseName : Fin (F.deg ^ 4) ≃ (Fin 2 → Fin (F.deg ^ 2)) := + (finCongr (show F.deg ^ 4 = F.deg ^ 2 * F.deg ^ 2 by ring)).trans + (finProdFinEquiv.symm.trans (finTwoArrowEquiv _).symm) + +/-- A level-`k` vertex together with a base vertex, as a level-`(k+1)` vertex. -/ +def vertName (k : ℕ) : + Fin (F.size k) × (Fin 2 → Fin (F.deg ^ 2)) ≃ Fin (F.size (k + 1)) := + ((Equiv.refl _).prodCongr F.baseName.symm).trans + (finProdFinEquiv.trans (finCongr (by simp only [size]; ring))) + +/-- The two darts of the squared base, as one. -/ +def zeroDartName : (Fin 2 → Fin F.deg) ≃ Fin (F.deg ^ 2) := + (finTwoArrowEquiv _).trans F.dartName + +/-- The squared base's vertices, numbered as level zero's. -/ +def zeroVertName : Fin (F.deg ^ 4) ≃ Fin (F.size 0) := + finCongr (by simp [size]) + +/-! ### The namings, in numbers -/ + +@[simp] theorem val_dartName (a b : Fin F.deg) : + (F.dartName (a, b)).val = b.val + F.deg * a.val := rfl + +@[simp] theorem val_dartName_symm_fst (i : Fin (F.deg ^ 2)) : + (F.dartName.symm i).1.val = i.val / F.deg := rfl + +@[simp] theorem val_dartName_symm_snd (i : Fin (F.deg ^ 2)) : + (F.dartName.symm i).2.val = i.val % F.deg := rfl + +@[simp] theorem val_baseName_zero (x : Fin (F.deg ^ 4)) : + (F.baseName x 0).val = x.val / F.deg ^ 2 := rfl + +@[simp] theorem val_baseName_one (x : Fin (F.deg ^ 4)) : + (F.baseName x 1).val = x.val % F.deg ^ 2 := rfl + +@[simp] theorem val_baseName_symm (s : Fin 2 → Fin (F.deg ^ 2)) : + (F.baseName.symm s).val = (s 1).val + F.deg ^ 2 * (s 0).val := rfl + +@[simp] theorem val_vertName (k : ℕ) (u : Fin (F.size k)) (s : Fin 2 → Fin (F.deg ^ 2)) : + (F.vertName k (u, s)).val = (F.baseName.symm s).val + F.deg ^ 4 * u.val := rfl + +@[simp] theorem val_vertName_symm_fst (k : ℕ) (v : Fin (F.size (k + 1))) : + ((F.vertName k).symm v).1.val = v.val / F.deg ^ 4 := rfl + +@[simp] theorem val_vertName_symm_snd_zero (k : ℕ) (v : Fin (F.size (k + 1))) : + (((F.vertName k).symm v).2 0).val = v.val % F.deg ^ 4 / F.deg ^ 2 := rfl + +@[simp] theorem val_vertName_symm_snd_one (k : ℕ) (v : Fin (F.size (k + 1))) : + (((F.vertName k).symm v).2 1).val = v.val % F.deg ^ 4 % F.deg ^ 2 := rfl + +theorem val_baseName_symm_vertName_symm (k : ℕ) (v : Fin (F.size (k + 1))) : + (F.baseName.symm ((F.vertName k).symm v).2).val = v.val % F.deg ^ 4 := by + have hlt : v.val % F.deg ^ 4 < F.deg ^ 4 := Nat.mod_lt _ (pow_pos F.deg_pos 4) + have hy : ((F.vertName k).symm v).2 = F.baseName ⟨v.val % F.deg ^ 4, hlt⟩ := rfl + rw [hy, Equiv.symm_apply_apply] + +@[simp] theorem val_zeroVertName (x : Fin (F.deg ^ 4)) : (F.zeroVertName x).val = x.val := rfl + +@[simp] theorem val_zeroVertName_symm (v : Fin (F.size 0)) : + (F.zeroVertName.symm v).val = v.val := rfl + +@[simp] theorem val_zeroDartName (s : Fin 2 → Fin F.deg) : + (F.zeroDartName s).val = (s 1).val + F.deg * (s 0).val := rfl + +@[simp] theorem val_zeroDartName_symm_zero (i : Fin (F.deg ^ 2)) : + (F.zeroDartName.symm i 0).val = i.val / F.deg := rfl + +@[simp] theorem val_zeroDartName_symm_one (i : Fin (F.deg ^ 2)) : + (F.zeroDartName.symm i 1).val = i.val % F.deg := rfl + +/-! ### The tower -/ + +/-- **The rotation map at each level**, carrying its involutivity so that the +next level's types are numbered on the nose. -/ +noncomputable def data (F : FinBase) : (k : ℕ) → + { f : Fin (F.size k) × Fin (F.deg ^ 2) → Fin (F.size k) × Fin (F.deg ^ 2) // + Function.Involutive f } + | 0 => + let W := ((F.graph.power 2).relabelV F.zeroVertName).relabel F.zeroDartName + ⟨W.rot, W.rot_involutive⟩ + | k + 1 => + let G := RegGraph.ofRot (F.deg ^ 2) F.sq_pos (F.size k) (data F k).1 (data F k).2 + let W := ((RegGraph.zigzag (G.power 2) F.graph F.baseName).relabelV + (F.vertName k)).relabel F.dartName + ⟨W.rot, W.rot_involutive⟩ + +/-- The level-`k` graph. -/ +noncomputable def graphAt (k : ℕ) : RegGraph := + RegGraph.ofRot (F.deg ^ 2) F.sq_pos (F.size k) (F.data k).1 (F.data k).2 + +@[simp] theorem order_graphAt (k : ℕ) : (F.graphAt k).order = F.size k := Fintype.card_fin _ + +@[simp] theorem deg_graphAt (k : ℕ) : (F.graphAt k).deg = F.deg ^ 2 := Fintype.card_fin _ + +theorem graphAt_zero : + F.graphAt 0 = ((F.graph.power 2).relabelV F.zeroVertName).relabel F.zeroDartName := by + simp only [graphAt, data] + rfl + +/-- **One level is the zig-zag of the previous with the base**, renumbered. -/ +theorem graphAt_succ (k : ℕ) : + F.graphAt (k + 1) = + ((RegGraph.zigzag ((F.graphAt k).power 2) F.graph F.baseName).relabelV + (F.vertName k)).relabel F.dartName := by + simp only [graphAt, data] + rfl + +/-- **Every level has spectral bound `2 / 5`.** -/ +theorem spectral_graphAt (F : FinBase) : ∀ k : ℕ, (F.graphAt k).SpectralBound (2 / 5) + | 0 => by + rw [graphAt_zero] + exact RegGraph.spectralBound_relabel _ _ + (RegGraph.spectralBound_relabelV _ _ F.toBase.towerZero.spec) + | k + 1 => by + rw [graphAt_succ] + exact RegGraph.spectralBound_relabel _ _ + (RegGraph.spectralBound_relabelV _ _ + (F.toBase.towerSuccOf ⟨F.graphAt k, by simp [toBase], spectral_graphAt F k⟩ + F.baseName).spec) + +/-- **One level of the recursion, in coordinates.** A level-`(k+1)` vertex is a +level-`k` vertex together with a base vertex, and a level-`(k+1)` dart is a pair +of base darts; in those coordinates a step is: turn in the base, walk two darts +of the level below, turn in the base again. -/ +theorem data_succ_apply (k : ℕ) (v : Fin (F.size (k + 1))) (i : Fin (F.deg ^ 2)) + {us : Fin (F.size k) × (Fin 2 → Fin (F.deg ^ 2))} (hus : us = (F.vertName k).symm v) + {ab : Fin F.deg × Fin F.deg} (hab : ab = F.dartName.symm i) + {p : Fin (F.deg ^ 4) × Fin F.deg} (hp : p = F.rot (F.baseName.symm us.2, ab.1)) + {q : Fin (F.size k) × (Fin 2 → Fin (F.deg ^ 2))} + (hq : q = ((F.graphAt k).power 2).rot (us.1, F.baseName p.1)) + {r : Fin (F.deg ^ 4) × Fin F.deg} (hr : r = F.rot (F.baseName.symm q.2, ab.2)) : + (F.data (k + 1)).1 (v, i) + = (F.vertName k (q.1, F.baseName r.1), F.dartName (r.2, p.2)) := by + subst hus hab hp hq hr + simp only [data, RegGraph.relabel, RegGraph.relabelV, RegGraph.zigzag, RegGraph.zigzagRot, + graphAt, graph, RegGraph.ofRot] + rfl + +@[simp] theorem rot_graphAt (k : ℕ) : (F.graphAt k).rot = (F.data k).1 := rfl + +/-- **The bottom of the recursion, in coordinates.** Level zero is the base +squared: walk two base darts, and return the labels in the opposite order. -/ +theorem data_zero_apply (v : Fin (F.size 0)) (i : Fin (F.deg ^ 2)) + {s : Fin 2 → Fin F.deg} (hs : s = F.zeroDartName.symm i) + {p₀ : Fin (F.deg ^ 4) × Fin F.deg} (h0 : p₀ = F.rot (F.zeroVertName.symm v, s 0)) + {p₁ : Fin (F.deg ^ 4) × Fin F.deg} (h1 : p₁ = F.rot (p₀.1, s 1)) : + (F.data 0).1 (v, i) = (F.zeroVertName p₁.1, F.zeroDartName ![p₁.2, p₀.2]) := by + subst hs h0 h1 + simp only [data, RegGraph.relabel, RegGraph.relabelV, RegGraph.rot_power_two, graph, + RegGraph.ofRot] + rfl + +/-- **The step in full**, with the two walks of the level below spelled out. -/ +theorem data_succ_apply' (k : ℕ) (v : Fin (F.size (k + 1))) (i : Fin (F.deg ^ 2)) + {us : Fin (F.size k) × (Fin 2 → Fin (F.deg ^ 2))} (hus : us = (F.vertName k).symm v) + {ab : Fin F.deg × Fin F.deg} (hab : ab = F.dartName.symm i) + {p : Fin (F.deg ^ 4) × Fin F.deg} (hp : p = F.rot (F.baseName.symm us.2, ab.1)) + {q₀ : Fin (F.size k) × Fin (F.deg ^ 2)} + (hq₀ : q₀ = (F.data k).1 (us.1, F.baseName p.1 0)) + {q₁ : Fin (F.size k) × Fin (F.deg ^ 2)} + (hq₁ : q₁ = (F.data k).1 (q₀.1, F.baseName p.1 1)) + {r : Fin (F.deg ^ 4) × Fin F.deg} + (hr : r = F.rot (F.baseName.symm ![q₁.2, q₀.2], ab.2)) : + (F.data (k + 1)).1 (v, i) + = (F.vertName k (q₁.1, F.baseName r.1), F.dartName (r.2, p.2)) := by + refine F.data_succ_apply k v i hus hab hp (q := (q₁.1, ![q₁.2, q₀.2])) ?_ hr + rw [RegGraph.rot_power_two, rot_graphAt, hq₁, hq₀] + rfl + +/-! ### The recursion, in numbers -/ + +/-- The base's rotation map, on raw numbers. -/ +noncomputable def baseVal (x a : ℕ) : ℕ × ℕ := + if h : x < F.deg ^ 4 ∧ a < F.deg then + ((F.rot (⟨x, h.1⟩, ⟨a, h.2⟩)).1.val, (F.rot (⟨x, h.1⟩, ⟨a, h.2⟩)).2.val) + else (0, 0) + +@[simp] theorem baseVal_apply (x : Fin (F.deg ^ 4)) (a : Fin F.deg) : + F.baseVal x.val a.val = ((F.rot (x, a)).1.val, (F.rot (x, a)).2.val) := by + rw [baseVal, dif_pos ⟨x.isLt, a.isLt⟩] + +/-- **The tower's rotation map, on raw numbers.** A level-`(k+1)` vertex `v` +splits as `v / deg^4` (the level below) and `v % deg^4` (the base); a dart `i` +splits as `i / deg` and `i % deg`. The step turns in the base, walks two darts +of the level below, and turns in the base again. -/ +noncomputable def rotVal (F : FinBase) : ℕ → ℕ × ℕ → ℕ × ℕ + | 0, (v, i) => + let p₀ := F.baseVal v (i / F.deg) + let p₁ := F.baseVal p₀.1 (i % F.deg) + (p₁.1, p₀.2 + F.deg * p₁.2) + | k + 1, (v, i) => + let p := F.baseVal (v % F.deg ^ 4) (i / F.deg) + let q₀ := rotVal F k (v / F.deg ^ 4, p.1 / F.deg ^ 2) + let q₁ := rotVal F k (q₀.1, p.1 % F.deg ^ 2) + let r := F.baseVal (q₀.2 + F.deg ^ 2 * q₁.2) (i % F.deg) + (r.1 + F.deg ^ 4 * q₁.1, p.2 + F.deg * r.2) + +/-- **The numbers compute the tower.** -/ +theorem rotVal_eq (k : ℕ) (v : Fin (F.size k)) (i : Fin (F.deg ^ 2)) : + F.rotVal k (v.val, i.val) + = (((F.data k).1 (v, i)).1.val, ((F.data k).1 (v, i)).2.val) := by + induction k generalizing i with + | zero => + have e0 : F.baseVal v.val (i.val / F.deg) + = ((F.rot (F.zeroVertName.symm v, F.zeroDartName.symm i 0)).1.val, + (F.rot (F.zeroVertName.symm v, F.zeroDartName.symm i 0)).2.val) := + F.baseVal_apply (F.zeroVertName.symm v) (F.zeroDartName.symm i 0) + have e1 : F.baseVal (F.rot (F.zeroVertName.symm v, F.zeroDartName.symm i 0)).1.val + (i.val % F.deg) + = ((F.rot ((F.rot (F.zeroVertName.symm v, F.zeroDartName.symm i 0)).1, + F.zeroDartName.symm i 1)).1.val, + (F.rot ((F.rot (F.zeroVertName.symm v, F.zeroDartName.symm i 0)).1, + F.zeroDartName.symm i 1)).2.val) := + F.baseVal_apply (F.rot (F.zeroVertName.symm v, F.zeroDartName.symm i 0)).1 + (F.zeroDartName.symm i 1) + rw [F.data_zero_apply v i rfl rfl rfl] + simp only [rotVal] + rw [e0, e1] + simp + | succ k ih => + have hp := F.baseVal_apply (F.baseName.symm ((F.vertName k).symm v).2) + (F.dartName.symm i).1 + rw [F.val_baseName_symm_vertName_symm k v, val_dartName_symm_fst] at hp + have hq0 := ih ((F.vertName k).symm v).1 + (F.baseName (F.rot (F.baseName.symm ((F.vertName k).symm v).2, + (F.dartName.symm i).1)).1 0) + have hq1 := ih ((F.data k).1 (((F.vertName k).symm v).1, + F.baseName (F.rot (F.baseName.symm ((F.vertName k).symm v).2, + (F.dartName.symm i).1)).1 0)).1 + (F.baseName (F.rot (F.baseName.symm ((F.vertName k).symm v).2, + (F.dartName.symm i).1)).1 1) + have hr := F.baseVal_apply (F.baseName.symm + ![((F.data k).1 (((F.data k).1 (((F.vertName k).symm v).1, + F.baseName (F.rot (F.baseName.symm ((F.vertName k).symm v).2, + (F.dartName.symm i).1)).1 0)).1, + F.baseName (F.rot (F.baseName.symm ((F.vertName k).symm v).2, + (F.dartName.symm i).1)).1 1)).2, + ((F.data k).1 (((F.vertName k).symm v).1, + F.baseName (F.rot (F.baseName.symm ((F.vertName k).symm v).2, + (F.dartName.symm i).1)).1 0)).2]) (F.dartName.symm i).2 + rw [val_baseName_symm, val_dartName_symm_snd] at hr + simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hr + rw [val_vertName_symm_fst, val_baseName_zero] at hq0 + rw [val_baseName_one] at hq1 + rw [F.data_succ_apply' k v i rfl rfl rfl rfl rfl rfl] + simp only [rotVal] + rw [hp] + dsimp only + rw [hq0] + dsimp only + rw [hq1] + dsimp only + rw [hr] + simp [Equiv.symm_apply_apply] + +theorem baseVal_lt {x a : ℕ} (hx : x < F.deg ^ 4) (ha : a < F.deg) : + (F.baseVal x a).1 < F.deg ^ 4 ∧ (F.baseVal x a).2 < F.deg := by + rw [baseVal, dif_pos ⟨hx, ha⟩] + exact ⟨Fin.isLt _, Fin.isLt _⟩ + +theorem rotVal_lt (k : ℕ) {v i : ℕ} (hv : v < F.size k) (hi : i < F.deg ^ 2) : + (F.rotVal k (v, i)).1 < F.size k ∧ (F.rotVal k (v, i)).2 < F.deg ^ 2 := by + rw [show v = (⟨v, hv⟩ : Fin (F.size k)).val from rfl, + show i = (⟨i, hi⟩ : Fin (F.deg ^ 2)).val from rfl, F.rotVal_eq k] + exact ⟨Fin.isLt _, Fin.isLt _⟩ + +/-! ### Choosing a level -/ + +theorem one_lt_pow_four (hd : 1 < F.deg) : 1 < F.deg ^ 4 := Nat.one_lt_pow (by norm_num) hd + +theorem exists_size_ge (hd : 1 < F.deg) (n : ℕ) : ∃ k, n ≤ F.size k := by + refine ⟨n, ?_⟩ + calc n ≤ (F.deg ^ 4) ^ n := (Nat.lt_pow_self (F.one_lt_pow_four hd)).le + _ ≤ (F.deg ^ 4) ^ (n + 1) := + Nat.pow_le_pow_right (Nat.zero_lt_of_lt (F.one_lt_pow_four hd)) (by omega) + +theorem le_size_self (hd : 1 < F.deg) (n : ℕ) : n ≤ F.size n := by + calc n ≤ (F.deg ^ 4) ^ n := (Nat.lt_pow_self (F.one_lt_pow_four hd)).le + _ ≤ (F.deg ^ 4) ^ (n + 1) := + Nat.pow_le_pow_right (Nat.zero_lt_of_lt (F.one_lt_pow_four hd)) (by omega) + +/-- The first level large enough for a requested size. -/ +noncomputable def level (F : FinBase) (hd : 1 < F.deg) (n : ℕ) : ℕ := + Nat.find (F.exists_size_ge hd n) + +theorem le_size_level (hd : 1 < F.deg) (n : ℕ) : n ≤ F.size (F.level hd n) := + Nat.find_spec (F.exists_size_ge hd n) + +/-- **The level a size needs is at most that size.** -/ +theorem level_le (hd : 1 < F.deg) (n : ℕ) : F.level hd n ≤ n := + Nat.find_le (F.le_size_self hd n) + +theorem size_level_le (hd : 1 < F.deg) (n : ℕ) (hn : 1 ≤ n) : + F.size (F.level hd n) ≤ F.deg ^ 4 * n := by + classical + rcases Nat.eq_zero_or_pos (F.level hd n) with h0 | hpos + · rw [level] at h0 ⊢ + rw [h0, size] + calc (F.deg ^ 4) ^ (0 + 1) = F.deg ^ 4 := by ring + _ ≤ F.deg ^ 4 * n := Nat.le_mul_of_pos_right _ hn + · obtain ⟨m, hm⟩ : ∃ m, F.level hd n = m + 1 := ⟨F.level hd n - 1, by omega⟩ + have hfind : Nat.find (F.exists_size_ge hd n) = m + 1 := hm + have hlt : ¬ n ≤ F.size m := + Nat.find_min (F.exists_size_ge hd n) (m := m) (by rw [hfind]; omega) + have hprev : F.size m < n := by omega + rw [hm, size] + rw [size] at hprev + calc (F.deg ^ 4) ^ (m + 1 + 1) = F.deg ^ 4 * (F.deg ^ 4) ^ (m + 1) := by ring + _ ≤ F.deg ^ 4 * n := Nat.mul_le_mul_left _ hprev.le + +/-- **The numbered tower, as a size-flexible family.** -/ +noncomputable def toSized (hd : 1 < F.deg) : SizedExpanderFamily where + degree := F.deg ^ 2 + degree_pos := F.sq_pos + factor := F.deg ^ 4 + graph := fun n => F.graphAt (F.level hd n) + deg_graph := fun n => F.deg_graphAt _ + order_ge := fun n => by rw [order_graphAt]; exact F.le_size_level hd n + order_le := fun n hn => by rw [order_graphAt]; exact F.size_level_le hd n hn + lam := 2 / 5 + lam_nonneg := by norm_num + lam_lt_one := by norm_num + spectral := fun n => spectral_graphAt F _ + +end FinBase + +/-! ### Numbering a base -/ + +namespace ZigZagBase + +variable (B : ZigZagBase) + +theorem card_base_darts : Fintype.card B.base.D = B.base.deg := rfl + +/-- **A zig-zag base, numbered.** -/ +noncomputable def toFin : FinBase where + deg := B.base.deg + deg_pos := B.base.deg_pos + rot := (B.base.toFinFormOf (B.base.deg ^ 4) B.base.deg B.card_eq B.card_base_darts).rot + rot_involutive := + (B.base.toFinFormOf (B.base.deg ^ 4) B.base.deg B.card_eq B.card_base_darts).rot_involutive + lam := B.lam + lam_nonneg := B.lam_nonneg + lam_le := B.lam_le + spectral := + RegGraph.spectralBound_toFinFormOf B.base (B.base.deg ^ 4) B.base.deg B.card_eq + B.card_base_darts B.spectral + +end ZigZagBase + +/-- **A numbered base exists.** -/ +theorem nonempty_finBase : Nonempty FinBase := + ⟨randExpander.toZigZagBase.toFin⟩ + +/-- **And one whose degree is above one**, which is what folding a tower onto a +requested size needs. -/ +theorem exists_finBase : ∃ F : FinBase, 1 < F.deg := + ⟨randExpander.toZigZagBase.toFin, + randExpander.one_lt_deg_toZigZagBase (by + show 1 < 120 + norm_num)⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TowerTable.lean b/Complexitylib/Classes/PCP/Internal/TowerTable.lean new file mode 100644 index 00000000..42e89b42 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/TowerTable.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.TowerFin +public import Complexitylib.Classes.PCP.Internal.Materialize +public import Complexitylib.Classes.P.FinsetDomain +public import Complexitylib.Classes.PCP.Internal.FiniteKey + +/-! +# The tower's rotation table + +`TowerFin` gives the tower's rotation map as arithmetic on numbers; this module +runs that arithmetic. A level is held as a table — one record for each vertex +and dart, holding the vertex reached and the label to come back by, both in +unary — and one level is computed from the one below by writing a new table +whose every record needs two lookups in the old one. + +The base graph's own rotation map is a table on a bounded key, so it is +polynomial time however it was chosen (`FiniteKey`). + +## Main definitions + +- `Complexity.FinBase.tableList`, `Complexity.FinBase.table` — a level's table +- `Complexity.FinBase.baseRec` — the base's rotation map, as a record +- `Complexity.FinBase.stepRec` — one record of the next level + +## Main results + +- `Complexity.FinBase.baseRec_mem_FP`, `Complexity.FinBase.stepRec_mem_FP` +- `Complexity.FinBase.stepRec_eq` — the rule computes the level above +- `Complexity.FinBase.tableStep_eq`, `Complexity.FinBase.tableStep_mem_FP` — and + writing out every record climbs one level +- `Complexity.FinBase.table_mem_FP` — so the table of any level is polynomial + time, given room for it +-/ + +@[expose] public section + +namespace Complexity + +theorem mul_add_div_of_lt {a b c : ℕ} (hc : 0 < c) (h : b < c) : (a * c + b) / c = a := by + rw [show a * c + b = b + c * a by ring, Nat.add_mul_div_left _ _ hc, + Nat.div_eq_of_lt h, Nat.zero_add] + +theorem mul_add_mod_of_lt {a b c : ℕ} (h : b < c) : (a * c + b) % c = b := by + rw [show a * c + b = b + c * a by ring, Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt h] + +namespace FinBase + +variable (F : FinBase) + +/-! ### The table -/ + +/-- The records of the level-`k` table: for each vertex and dart, the vertex +reached and the label pointing back, both in unary. -/ +noncomputable def tableList (k : ℕ) : List (List Bool × List Bool) := + (List.range (F.size k * F.deg ^ 2)).map fun j => + (List.replicate (F.rotVal k (j / F.deg ^ 2, j % F.deg ^ 2)).1 true, + List.replicate (F.rotVal k (j / F.deg ^ 2, j % F.deg ^ 2)).2 true) + +@[simp] theorem length_tableList (k : ℕ) : + (F.tableList k).length = F.size k * F.deg ^ 2 := by + rw [tableList, List.length_map, List.length_range] + +/-- The level-`k` table. -/ +noncomputable def table (k : ℕ) : List Bool := DataEncode.bitstringEncode (F.tableList k) + +theorem tableFst_table {k j : ℕ} (hj : j < F.size k * F.deg ^ 2) : + tableFst (F.table k) j + = List.replicate (F.rotVal k (j / F.deg ^ 2, j % F.deg ^ 2)).1 true := by + rw [table] + refine tableFst_eq (l := F.tableList k) + (c := (F.rotVal k (j / F.deg ^ 2, j % F.deg ^ 2)).2) + (by rw [length_tableList]; exact hj) ?_ + simp only [tableList, List.getElem_map, List.getElem_range] + +theorem tableSnd_table {k j : ℕ} (hj : j < F.size k * F.deg ^ 2) : + tableSnd (F.table k) j + = List.replicate (F.rotVal k (j / F.deg ^ 2, j % F.deg ^ 2)).2 true := by + rw [table] + refine tableSnd_eq (l := F.tableList k) + (w := (F.rotVal k (j / F.deg ^ 2, j % F.deg ^ 2)).1) + (by rw [length_tableList]; exact hj) ?_ + simp only [tableList, List.getElem_map, List.getElem_range] + +/-! ### The base graph's own table -/ + +/-- The record the base's rotation map gives, before the key is bounded. -/ +noncomputable def baseRaw (z : List Bool) : List Bool := + encPair + (List.replicate + (F.baseVal (Cobham.fstBlock z).length (Cobham.sndBlock z).length).1 true) + (List.replicate + (F.baseVal (Cobham.fstBlock z).length (Cobham.sndBlock z).length).2 true) + +/-- How long an argument to the base's table can be. -/ +def baseKeyBound : ℕ := 2 * F.deg ^ 4 + 2 + F.deg + +/-- **The base's rotation map, as a record.** -/ +noncomputable def baseRec (z : List Bool) : List Bool := + if z ∈ keySet F.baseKeyBound (fun _ => True) then F.baseRaw z else [] + +theorem baseRec_mem_FP : F.baseRec ∈ FP := + ite_mem_finset_mem_FP F.baseRaw (keySet F.baseKeyBound (fun _ => True)) + +theorem baseRec_eq {x a : ℕ} (hx : x < F.deg ^ 4) (ha : a < F.deg) : + F.baseRec (pair (List.replicate x true) (List.replicate a true)) + = encPair (List.replicate (F.baseVal x a).1 true) + (List.replicate (F.baseVal x a).2 true) := by + have hlen : (pair (List.replicate x true) (List.replicate a true)).length + ≤ F.baseKeyBound := by + rw [pair_length, List.length_replicate, List.length_replicate, baseKeyBound] + omega + rw [baseRec, if_pos (mem_keySet.mpr ⟨hlen, trivial⟩), baseRaw, + Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, + List.length_replicate] + +/-! ### One record of the next level -/ + +/-- One record of the level above, from the table below. The argument is +`pair table (unary index)`: the index splits into a vertex and a dart, the +vertex into a vertex of the level below and a base vertex, and the dart into two +base darts. -/ +noncomputable def stepRec (z : List Bool) : List Bool := + let T := Cobham.fstBlock z + let J := Cobham.sndBlock z + let V := divC (F.deg ^ 2) J + let I := modC (F.deg ^ 2) J + let U := divC (F.deg ^ 4) V + let X := modC (F.deg ^ 4) V + let A := divC F.deg I + let B := modC F.deg I + let P := F.baseRec (pair X A) + let P1 := unaryOf (fstEnc P) + let P2 := unaryOf (sndEnc P) + let Q0 := posAt T (mulC (F.deg ^ 2) U ++ divC (F.deg ^ 2) P1).length + let W0 := unaryOf (fstEnc Q0) + let C0 := unaryOf (sndEnc Q0) + let Q1 := posAt T (mulC (F.deg ^ 2) W0 ++ modC (F.deg ^ 2) P1).length + let W1 := unaryOf (fstEnc Q1) + let C1 := unaryOf (sndEnc Q1) + let R := F.baseRec (pair (marks (C0 ++ mulC (F.deg ^ 2) C1)) B) + let R1 := unaryOf (fstEnc R) + let R2 := unaryOf (sndEnc R) + encPair (marks (R1 ++ mulC (F.deg ^ 4) W1)) (marks (P2 ++ mulC F.deg R2)) + +theorem stepRec_mem_FP : F.stepRec ∈ FP := by + have hT := Cobham.fstBlock_mem_FP + have hJ := Cobham.sndBlock_mem_FP + have hV := divC_mem_FP hJ (F.deg ^ 2) + have hI := modC_mem_FP hJ (F.deg ^ 2) + have hU := divC_mem_FP hV (F.deg ^ 4) + have hX := modC_mem_FP hV (F.deg ^ 4) + have hA := divC_mem_FP hI F.deg + have hB := modC_mem_FP hI F.deg + have hP := mem_FP_comp (Cobham.pairFn_mem_FP hX hA) F.baseRec_mem_FP + have hP1 := unaryOf_mem_FP (fstEnc_mem_FP hP) + have hP2 := unaryOf_mem_FP (sndEnc_mem_FP hP) + have hIdx0 := Cobham.appendFn_mem_FP (mulC_mem_FP hU (F.deg ^ 2)) + (divC_mem_FP hP1 (F.deg ^ 2)) + have hQ0 := posAt_mem_FP hIdx0 hT + have hW0 := unaryOf_mem_FP (fstEnc_mem_FP hQ0) + have hC0 := unaryOf_mem_FP (sndEnc_mem_FP hQ0) + have hIdx1 := Cobham.appendFn_mem_FP (mulC_mem_FP hW0 (F.deg ^ 2)) + (modC_mem_FP hP1 (F.deg ^ 2)) + have hQ1 := posAt_mem_FP hIdx1 hT + have hW1 := unaryOf_mem_FP (fstEnc_mem_FP hQ1) + have hC1 := unaryOf_mem_FP (sndEnc_mem_FP hQ1) + have hRarg := Cobham.pairFn_mem_FP + (marks_mem_FP (Cobham.appendFn_mem_FP hC0 (mulC_mem_FP hC1 (F.deg ^ 2)))) hB + have hR := mem_FP_comp hRarg F.baseRec_mem_FP + have hR1 := unaryOf_mem_FP (fstEnc_mem_FP hR) + have hR2 := unaryOf_mem_FP (sndEnc_mem_FP hR) + have hOut := encPair_mem_FP + (marks_mem_FP (Cobham.appendFn_mem_FP hR1 (mulC_mem_FP hW1 (F.deg ^ 4)))) + (marks_mem_FP (Cobham.appendFn_mem_FP hP2 (mulC_mem_FP hR2 F.deg))) + exact mem_FP_of_eq hOut fun _ => rfl + +/-- **The record rule computes the level above.** -/ +theorem stepRec_eq {k j : ℕ} (hj : j < F.size (k + 1) * F.deg ^ 2) : + F.stepRec (pair (F.table k) (List.replicate j true)) + = encPair + (List.replicate (F.rotVal (k + 1) (j / F.deg ^ 2, j % F.deg ^ 2)).1 true) + (List.replicate (F.rotVal (k + 1) (j / F.deg ^ 2, j % F.deg ^ 2)).2 true) := by + have hd1 : 0 < F.deg := F.deg_pos + have hd2 : 0 < F.deg ^ 2 := F.sq_pos + have hd4 : 0 < F.deg ^ 4 := pow_pos F.deg_pos 4 + have hsq : F.deg ^ 4 = F.deg ^ 2 * F.deg ^ 2 := by ring + -- the vertex and the dart + have hvlt : j / F.deg ^ 2 < F.size (k + 1) := (Nat.div_lt_iff_lt_mul hd2).mpr hj + have hxlt : j / F.deg ^ 2 % F.deg ^ 4 < F.deg ^ 4 := Nat.mod_lt _ hd4 + have halt : j % F.deg ^ 2 / F.deg < F.deg := by + refine (Nat.div_lt_iff_lt_mul hd1).mpr ?_ + have := Nat.mod_lt j hd2 + nlinarith [this] + have hult : j / F.deg ^ 2 / F.deg ^ 4 < F.size k := by + refine (Nat.div_lt_iff_lt_mul hd4).mpr ?_ + rw [← F.size_succ k] + exact hvlt + -- the base turn + obtain ⟨p1, p2, hp⟩ : ∃ p1 p2, + F.baseVal (j / F.deg ^ 2 % F.deg ^ 4) (j % F.deg ^ 2 / F.deg) = (p1, p2) := ⟨_, _, rfl⟩ + have hp1 : p1 < F.deg ^ 4 := by + have := (F.baseVal_lt hxlt halt).1 + rwa [hp] at this + have hp2 : p2 < F.deg := by + have := (F.baseVal_lt hxlt halt).2 + rwa [hp] at this + rw [stepRec] + simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, divC_eq hd2, modC_eq hd2, + divC_eq hd4, modC_eq hd4, divC_eq hd1, modC_eq hd1, List.length_replicate, + F.baseRec_eq hxlt halt, hp, unaryOf_fstEnc_encPair, unaryOf_sndEnc_encPair, + length_mulC_append, ← tableFst_def, ← tableSnd_def] + -- the first lookup + have hs0 : p1 / F.deg ^ 2 < F.deg ^ 2 := + (Nat.div_lt_iff_lt_mul hd2).mpr (by rw [← hsq]; exact hp1) + have hs1 : p1 % F.deg ^ 2 < F.deg ^ 2 := Nat.mod_lt _ hd2 + have hidx0 : j / F.deg ^ 2 / F.deg ^ 4 * F.deg ^ 2 + p1 / F.deg ^ 2 < F.size k * F.deg ^ 2 := by + have h2 : j / F.deg ^ 2 / F.deg ^ 4 + 1 ≤ F.size k := hult + nlinarith + obtain ⟨w0, c0, hq0⟩ : ∃ w0 c0, + F.rotVal k (j / F.deg ^ 2 / F.deg ^ 4, p1 / F.deg ^ 2) = (w0, c0) := ⟨_, _, rfl⟩ + have hw0 : w0 < F.size k := by + have := (F.rotVal_lt k hult hs0).1 + rwa [hq0] at this + have hc0 : c0 < F.deg ^ 2 := by + have := (F.rotVal_lt k hult hs0).2 + rwa [hq0] at this + rw [F.tableFst_table hidx0, F.tableSnd_table hidx0, + mul_add_div_of_lt hd2 hs0, mul_add_mod_of_lt hs0, hq0] + simp only [length_mulC_append] + -- the second lookup + have hidx1 : w0 * F.deg ^ 2 + p1 % F.deg ^ 2 < F.size k * F.deg ^ 2 := by + have h2 : w0 + 1 ≤ F.size k := hw0 + nlinarith + obtain ⟨w1, c1, hq1⟩ : ∃ w1 c1, + F.rotVal k (w0, p1 % F.deg ^ 2) = (w1, c1) := ⟨_, _, rfl⟩ + have hc1 : c1 < F.deg ^ 2 := by + have := (F.rotVal_lt k hw0 hs1).2 + rwa [hq1] at this + rw [F.tableFst_table hidx1, F.tableSnd_table hidx1, + mul_add_div_of_lt hd2 hs1, mul_add_mod_of_lt hs1, hq1] + simp only [marks_append_mulC] + -- the base turn back + have hblt : j % F.deg ^ 2 % F.deg < F.deg := Nat.mod_lt _ hd1 + have hrlt : c0 + F.deg ^ 2 * c1 < F.deg ^ 4 := by + rw [hsq] + nlinarith + rw [show c0 + c1 * F.deg ^ 2 = c0 + F.deg ^ 2 * c1 from by ring] + obtain ⟨r1, r2, hr⟩ : ∃ r1 r2, + F.baseVal (c0 + F.deg ^ 2 * c1) (j % F.deg ^ 2 % F.deg) = (r1, r2) := ⟨_, _, rfl⟩ + rw [F.baseRec_eq hrlt hblt, hr] + simp only [unaryOf_fstEnc_encPair, unaryOf_sndEnc_encPair, marks_append_mulC] + simp only [rotVal, hp, hq0, hq1, hr] + rw [show r1 + w1 * F.deg ^ 4 = r1 + F.deg ^ 4 * w1 from by ring, + show p2 + r2 * F.deg = p2 + F.deg * r2 from by ring] + +/-! ### One level of the table -/ + +/-- **One level of the table**: write out every record of the level above. -/ +noncomputable def tableStep (T : List Bool) : List Bool := + listEncFn F.stepRec (pair (marks (mulC (F.deg ^ 4) (posCount T))) T) + +theorem tableStep_mem_FP : F.tableStep ∈ FP := by + have hcount := marks_mem_FP (mulC_mem_FP (posCount_mem_FP id_mem_FP) (F.deg ^ 4)) + have harg := Cobham.pairFn_mem_FP hcount id_mem_FP + exact mem_FP_of_eq (mem_FP_comp harg (materialize_mem_FP F.stepRec_mem_FP)) fun _ => rfl + +theorem tableStep_eq (k : ℕ) : F.tableStep (F.table k) = F.table (k + 1) := by + have hcount : marks (mulC (F.deg ^ 4) (posCount (F.table k))) + = List.replicate (F.tableList (k + 1)).length true := by + rw [table, posCount_eq, marks_eq, length_mulC, List.length_replicate, length_tableList, + length_tableList, F.size_succ k] + ring_nf + rw [tableStep, hcount, table] + refine materialize_eq (F.tableList (k + 1)) (F.table k) fun i hi => ?_ + rw [length_tableList] at hi + rw [F.stepRec_eq hi] + simp only [tableList, List.getElem_map, List.getElem_range] + rw [encPair_eq] + +/-- How long a level's table is: one record a vertex and dart, and a record +holds two numbers below the level's size. -/ +theorem length_table_le (l : ℕ) : + (F.table l).length + ≤ 2 + F.size l * F.deg ^ 2 * (4 * F.size l + 4 * F.deg ^ 2 + 6) := by + rw [table, length_bitstringEncode_list] + have hbound : ∀ x ∈ (F.tableList l).map + (fun a => (DataEncode.bitstringEncode a).length), + x ≤ 4 * F.size l + 4 * F.deg ^ 2 + 6 := by + intro x hx + simp only [List.mem_map] at hx + obtain ⟨a, ha, rfl⟩ := hx + simp only [tableList, List.mem_map, List.mem_range] at ha + obtain ⟨j, hj, rfl⟩ := ha + have hv : j / F.deg ^ 2 < F.size l := (Nat.div_lt_iff_lt_mul F.sq_pos).mpr hj + have hi : j % F.deg ^ 2 < F.deg ^ 2 := Nat.mod_lt _ F.sq_pos + have hlt := F.rotVal_lt l hv hi + rw [← encPair_eq, length_encPair] + omega + have hsum := List.sum_le_card_nsmul _ _ hbound + rw [List.length_map, length_tableList] at hsum + simp only [smul_eq_mul] at hsum + omega + +/-! ### Climbing to a level -/ + +theorem tableStep_iterate : ∀ l : ℕ, F.tableStep^[l] (F.table 0) = F.table l + | 0 => rfl + | l + 1 => by + rw [Function.iterate_succ_apply', tableStep_iterate l, tableStep_eq] + +/-- **The table of a requested level is polynomial time**, as soon as there is +room to write it down. -/ +theorem table_mem_FP {ruler width : List Bool → List Bool} (hr : ruler ∈ FP) (hw : width ∈ FP) + (hbound : ∀ z, ∀ l ≤ (ruler z).length, (F.table l).length ≤ (width z).length) : + (fun z => F.table (ruler z).length) ∈ FP := by + have hiter := Cobham.iterate_mem_FP F.tableStep_mem_FP (constFn_mem_FP (F.table 0)) hr hw + (fun z l hl => by rw [F.tableStep_iterate l]; exact hbound z l hl) + exact mem_FP_of_eq hiter fun z => by rw [F.tableStep_iterate] + +end FinBase + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean new file mode 100644 index 00000000..9f5eed1a --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.CoinEnum +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble + +/-! +# Division with remainder, in unary + +Every index decomposition in an algorithmic constraint graph is a division: +which edge of the original graph, which step of the walk, which copy of the +gadget. This module divides one unary number by another in polynomial time, by +counting up and rolling the remainder over. + +## Main definitions + +- `Complexity.dmStep` — one tick of the count + +## Main results + +- `Complexity.dmStep_iterate` — the count divides +- `Complexity.halfFn_mem_FP`, `Complexity.halfFn_eq` — halving a length +-/ + +@[expose] public section + +namespace Complexity + +/-- One tick: extend the remainder, and roll it over into the quotient when it +reaches the divisor. The state is `pair (pair quotient remainder) divisor`. -/ +def dmStep (st : List Bool) : List Bool := + pair (pair + (Cobham.selectHead + (Cobham.lenEqFlag (true :: Cobham.sndBlock (Cobham.fstBlock st)) (Cobham.sndBlock st)) + (true :: Cobham.fstBlock (Cobham.fstBlock st)) + (Cobham.fstBlock (Cobham.fstBlock st))) + (Cobham.selectHead + (Cobham.lenEqFlag (true :: Cobham.sndBlock (Cobham.fstBlock st)) (Cobham.sndBlock st)) + [] (true :: Cobham.sndBlock (Cobham.fstBlock st)))) + (Cobham.sndBlock st) + +theorem dmStep_mem_FP : dmStep ∈ FP := by + have hq : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + have hr : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + have hb : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hr' : (fun st : List Bool => true :: Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + mem_FP_comp hr (Cobham.cons_mem_FP true) + have hflag : (fun st : List Bool => + Cobham.lenEqFlag (true :: Cobham.sndBlock (Cobham.fstBlock st)) + (Cobham.sndBlock st)) ∈ FP := by + exact andBitFn_mem_FP (lenLeFlagFn_mem_FP hr' hb) (lenLeFlagFn_mem_FP hb hr') + exact Cobham.pairFn_mem_FP + (Cobham.pairFn_mem_FP + (Cobham.selectHeadFn_mem_FP hflag (mem_FP_comp hq (Cobham.cons_mem_FP true)) hq) + (Cobham.selectHeadFn_mem_FP hflag (constFn_mem_FP []) hr')) hb + +/-- **The count divides.** After `a` ticks the state holds `a / b` and `a % b`. -/ +theorem dmStep_iterate {B : List Bool} (hb : 0 < B.length) : + ∀ a : ℕ, dmStep^[a] (pair (pair [] []) B) + = pair (pair (List.replicate (a / B.length) true) + (List.replicate (a % B.length) true)) B := by + intro a + induction a with + | zero => simp + | succ a ih => + rw [Function.iterate_succ_apply', ih, dmStep, Cobham.sndBlock_pair, + Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + set b := B.length with hbdef + have hlen : (true :: List.replicate (a % b) true).length = a % b + 1 := by simp + have hmod : a % b < b := Nat.mod_lt _ hb + by_cases hcase : a % b + 1 = b + · have hflag : Cobham.lenEqFlag (true :: List.replicate (a % b) true) B = [true] := by + rw [Cobham.lenEqFlag_eq_true_iff, hlen] + exact hcase + rw [hflag, selectHead_cons_true, selectHead_cons_true] + have hdm := Nat.div_add_mod a b + have h1 : a + 1 = b * (a / b + 1) := by + rw [Nat.mul_add, Nat.mul_one] + omega + have hq : (a + 1) / b = a / b + 1 := by + rw [h1, Nat.mul_div_cancel_left _ hb] + have hr : (a + 1) % b = 0 := by + rw [h1, Nat.mul_mod_right] + rw [hq, hr, List.replicate_succ] + simp + · have hflag : Cobham.lenEqFlag (true :: List.replicate (a % b) true) B = [false] := by + rcases Cobham.lenEqFlag_flag (true :: List.replicate (a % b) true) B with h | h + · rw [Cobham.lenEqFlag_eq_true_iff, hlen] at h + exact absurd h hcase + · exact h + rw [hflag, selectHead_cons_false, selectHead_cons_false] + have hdm := Nat.div_add_mod a b + have hlt : a % b + 1 < b := by omega + have h1 : a + 1 = b * (a / b) + (a % b + 1) := by omega + have hq : (a + 1) / b = a / b := by + rw [h1, Nat.mul_add_div hb, Nat.div_eq_of_lt hlt] + omega + have hr : (a + 1) % b = a % b + 1 := by + rw [h1, Nat.mul_add_mod, Nat.mod_eq_of_lt hlt] + rw [hq, hr, List.replicate_succ] + +/-! ### Halving -/ + +theorem length_selectHead_le' (s x y : List Bool) : + (Cobham.selectHead s x y).length ≤ max x.length y.length := by + rw [Cobham.selectHead] + split + · exact le_max_left _ _ + · split + · exact le_max_right _ _ + · simp + +theorem dmStep_one (q r b : List Bool) : + ∃ q' r', dmStep (pair (pair q r) b) = pair (pair q' r') b + ∧ q'.length ≤ q.length + 1 ∧ r'.length ≤ r.length + 1 := by + have hq : Cobham.fstBlock (Cobham.fstBlock (pair (pair q r) b)) = q := by + rw [Cobham.fstBlock_pair, Cobham.fstBlock_pair] + have hr : Cobham.sndBlock (Cobham.fstBlock (pair (pair q r) b)) = r := by + rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hb : Cobham.sndBlock (pair (pair q r) b) = b := Cobham.sndBlock_pair _ _ + rw [dmStep, hq, hr, hb] + refine ⟨_, _, rfl, ?_, ?_⟩ + · refine le_trans (length_selectHead_le' _ _ _) ?_ + simp + · refine le_trans (length_selectHead_le' _ _ _) ?_ + simp + +theorem dmStep_shape : ∀ (k : ℕ) (q r b : List Bool), + ∃ q' r', dmStep^[k] (pair (pair q r) b) = pair (pair q' r') b + ∧ q'.length ≤ q.length + k ∧ r'.length ≤ r.length + k := by + intro k + induction k with + | zero => intro q r b; exact ⟨q, r, rfl, by omega, by omega⟩ + | succ k ih => + intro q r b + rw [Function.iterate_succ_apply] + obtain ⟨q₁, r₁, h1, hq1, hr1⟩ := dmStep_one q r b + rw [h1] + obtain ⟨q', r', h2, hq2, hr2⟩ := ih q₁ r₁ b + exact ⟨q', r', h2, by omega, by omega⟩ + +/-- The counting run: divide a length by a fixed divisor. -/ +noncomputable def dmRun (b s : List Bool) : List Bool := + dmStep^[s.length] (pair (pair [] []) b) + +/-- The quotient of a length by a fixed divisor, in unary. -/ +noncomputable def divFn (b s : List Bool) : List Bool := + Cobham.fstBlock (Cobham.fstBlock (dmRun b s)) + +/-- The remainder of a length by a fixed divisor, in unary. -/ +noncomputable def modFn (b s : List Bool) : List Bool := + Cobham.sndBlock (Cobham.fstBlock (dmRun b s)) + +theorem dmRun_mem_FP (b : List Bool) : dmRun b ∈ FP := by + have hinit : (fun _ : List Bool => pair (pair [] []) b) ∈ FP := constFn_mem_FP _ + have hwidth : (fun z : List Bool => polyRuler (Polynomial.C 6 * Polynomial.X + + Polynomial.C (b.length + 6)) (id z)) ∈ FP := polyRulerFn_mem_FP _ id_mem_FP + have hbound : ∀ z : List Bool, ∀ k ≤ z.length, + (dmStep^[k] (pair (pair [] []) b)).length + ≤ (polyRuler (Polynomial.C 6 * Polynomial.X + + Polynomial.C (b.length + 6)) (id z)).length := by + intro z k hk + obtain ⟨q', r', h1, hq, hr⟩ := dmStep_shape k [] [] b + rw [h1, pair_length, pair_length, polyRuler_length] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * + omega + have hiter := Cobham.iterate_mem_FP dmStep_mem_FP hinit id_mem_FP hwidth hbound + simpa [Function.comp, dmRun] using hiter + +theorem divFn_mem_FP (b : List Bool) : divFn b ∈ FP := by + have := mem_FP_comp (mem_FP_comp (dmRun_mem_FP b) Cobham.fstBlock_mem_FP) + Cobham.fstBlock_mem_FP + simpa [Function.comp, divFn] using this + +theorem modFn_mem_FP (b : List Bool) : modFn b ∈ FP := by + have := mem_FP_comp (mem_FP_comp (dmRun_mem_FP b) Cobham.fstBlock_mem_FP) + Cobham.sndBlock_mem_FP + simpa [Function.comp, modFn] using this + +theorem divFn_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : + divFn b s = List.replicate (s.length / b.length) true := by + rw [divFn, dmRun, dmStep_iterate hb s.length, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + +theorem modFn_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : + modFn b s = List.replicate (s.length % b.length) true := by + rw [modFn, dmRun, dmStep_iterate hb s.length, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + +/-! ### Dividing by a length read from the input -/ + +theorem fstBlock_len_le (z : List Bool) : (Cobham.fstBlock z).length ≤ z.length := by + induction z using Cobham.fstBlock.induct <;> simp [Cobham.fstBlock] <;> omega + +theorem sndBlock_len_le (z : List Bool) : (Cobham.sndBlock z).length ≤ z.length := by + rcases hu : unpair? z with _ | ⟨p, q⟩ + · rw [show Cobham.sndBlock z = [] from by rw [Cobham.sndBlock, hu]] + simp + · have hz : z = pair p q := unpair?_eq_some_iff.mp hu + rw [show Cobham.sndBlock z = q from by rw [Cobham.sndBlock, hu], hz, pair_length] + omega + +/-- The counting run with the divisor read from the argument: `pair b s`. -/ +noncomputable def dmRun2 (z : List Bool) : List Bool := + dmStep^[(Cobham.sndBlock z).length] (pair (pair [] []) (Cobham.fstBlock z)) + +/-- The quotient of one length by another, in unary. -/ +noncomputable def divFn2 (z : List Bool) : List Bool := + Cobham.fstBlock (Cobham.fstBlock (dmRun2 z)) + +/-- The remainder of one length by another, in unary. -/ +noncomputable def modFn2 (z : List Bool) : List Bool := + Cobham.sndBlock (Cobham.fstBlock (dmRun2 z)) + +theorem dmRun2_mem_FP : dmRun2 ∈ FP := by + have hinit : (fun z : List Bool => pair (pair [] []) (Cobham.fstBlock z)) ∈ FP := + Cobham.pairFn_mem_FP (constFn_mem_FP (pair [] [])) Cobham.fstBlock_mem_FP + have hwidth : (fun z : List Bool => polyRuler (Polynomial.C 7 * Polynomial.X + + Polynomial.C 6) (id z)) ∈ FP := polyRulerFn_mem_FP _ id_mem_FP + have hbound : ∀ z : List Bool, ∀ k ≤ (Cobham.sndBlock z).length, + (dmStep^[k] (pair (pair [] []) (Cobham.fstBlock z))).length + ≤ (polyRuler (Polynomial.C 7 * Polynomial.X + Polynomial.C 6) (id z)).length := by + intro z k hk + obtain ⟨q', r', h1, hq, hr⟩ := dmStep_shape k [] [] (Cobham.fstBlock z) + have hf : (Cobham.fstBlock z).length ≤ z.length := fstBlock_len_le z + have hs : (Cobham.sndBlock z).length ≤ z.length := sndBlock_len_le z + rw [h1, pair_length, pair_length, polyRuler_length] + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * + omega + have hiter := Cobham.iterate_mem_FP dmStep_mem_FP hinit Cobham.sndBlock_mem_FP hwidth hbound + simpa [Function.comp, dmRun2] using hiter + +theorem divFn2_mem_FP : divFn2 ∈ FP := by + have := mem_FP_comp (mem_FP_comp dmRun2_mem_FP Cobham.fstBlock_mem_FP) + Cobham.fstBlock_mem_FP + simpa [Function.comp, divFn2] using this + +theorem modFn2_mem_FP : modFn2 ∈ FP := by + have := mem_FP_comp (mem_FP_comp dmRun2_mem_FP Cobham.fstBlock_mem_FP) + Cobham.sndBlock_mem_FP + simpa [Function.comp, modFn2] using this + +theorem divFn2_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : + divFn2 (pair b s) = List.replicate (s.length / b.length) true := by + rw [divFn2, dmRun2, Cobham.sndBlock_pair, Cobham.fstBlock_pair, dmStep_iterate hb s.length, + Cobham.fstBlock_pair, Cobham.fstBlock_pair] + +theorem modFn2_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : + modFn2 (pair b s) = List.replicate (s.length % b.length) true := by + rw [modFn2, dmRun2, Cobham.sndBlock_pair, Cobham.fstBlock_pair, dmStep_iterate hb s.length, + Cobham.fstBlock_pair, Cobham.sndBlock_pair] + +/-- **Halving a length**, in unary. -/ +noncomputable def halfFn (s : List Bool) : List Bool := divFn [false, false] s + +theorem halfFn_mem_FP : halfFn ∈ FP := divFn_mem_FP _ + +theorem halfFn_eq (s : List Bool) : halfFn s = List.replicate (s.length / 2) true := by + rw [halfFn, divFn_eq (by simp)] + rfl + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/UnaryExp.lean b/Complexitylib/Classes/PCP/Internal/UnaryExp.lean new file mode 100644 index 00000000..580f57b4 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/UnaryExp.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.P.Cobham.Internal +public import Complexitylib.Classes.Containments.Internal.NLSearchAssemble +public import Complexitylib.Asymptotics + +/-! +# Counting out `2 ^ r n` in unary + +A verifier using `r n` coins has `2 ^ r n` coin strings, and an algorithm that +has to look at all of them needs that many steps counted out somewhere. When +`r` is logarithmic the count is polynomial, so a polynomial-time function can +write it down — by starting from a single mark and doubling `r n` times. + +The hypothesis is the one `Constructible` supplies: `r n` itself is available in +unary in polynomial time. + +## Main definitions + +- `Complexity.dbl` — doubling a string + +## Main results + +- `Complexity.exists_poly_two_pow_of_bigO_log` — `2 ^ O(log n)` is polynomial +- `Complexity.unaryExp_mem_FP` — `2 ^ r n` marks, in polynomial time +-/ + +@[expose] public section + +namespace Complexity + +/-- Doubling: the string followed by itself. -/ +def dbl (s : List Bool) : List Bool := s ++ s + +theorem dbl_mem_FP : dbl ∈ FP := Cobham.appendFn_mem_FP id_mem_FP id_mem_FP + +theorem dbl_iterate (n : ℕ) : dbl^[n] [true] = List.replicate (2 ^ n) true := by + induction n with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply', ih, dbl, ← List.replicate_add] + congr 1 + rw [pow_succ] + omega + +open scoped Complexity in +/-- **A logarithmic exponent gives a polynomial.** This is what makes a +`O(log n)` randomness bound usable: the number of coin strings stays +polynomial. -/ +theorem exists_poly_two_pow_of_bigO_log {r : ℕ → ℕ} (h : r =O fun n => Nat.log 2 n) : + ∃ p : Polynomial ℕ, ∀ n, 2 ^ r n ≤ p.eval n := by + rw [BigO, Asymptotics.isBigO_iff] at h + obtain ⟨C, hC⟩ := h + rw [Filter.eventually_atTop] at hC + obtain ⟨N, hN⟩ := hC + refine ⟨Polynomial.X ^ ⌈C⌉₊ + + Polynomial.C ((Finset.range (N + 1)).sup fun n => 2 ^ r n), ?_⟩ + intro n + simp only [Polynomial.eval_add, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X] + by_cases hn : n < N + 1 + · have : 2 ^ r n ≤ (Finset.range (N + 1)).sup fun n => 2 ^ r n := + Finset.le_sup (f := fun n => 2 ^ r n) (Finset.mem_range.mpr hn) + omega + · have hnN : N ≤ n := by omega + have hn0 : n ≠ 0 := by omega + have hb := hN n hnN + simp only [Real.norm_natCast] at hb + have hC_le : C ≤ (⌈C⌉₊ : ℝ) := Nat.le_ceil C + have hlog_nonneg : (0 : ℝ) ≤ ((Nat.log 2 n : ℕ) : ℝ) := by positivity + have h_real : (r n : ℝ) ≤ (⌈C⌉₊ : ℝ) * ((Nat.log 2 n : ℕ) : ℝ) := + le_trans hb (mul_le_mul_of_nonneg_right hC_le hlog_nonneg) + have h_nat : r n ≤ ⌈C⌉₊ * Nat.log 2 n := by exact_mod_cast h_real + have h1 : 2 ^ r n ≤ 2 ^ (⌈C⌉₊ * Nat.log 2 n) := Nat.pow_le_pow_right (by omega) h_nat + have h2 : 2 ^ (⌈C⌉₊ * Nat.log 2 n) = (2 ^ Nat.log 2 n) ^ ⌈C⌉₊ := by + rw [← pow_mul, Nat.mul_comm] + have h3 : (2 ^ Nat.log 2 n) ^ ⌈C⌉₊ ≤ n ^ ⌈C⌉₊ := + Nat.pow_le_pow_left (Nat.pow_log_le_self 2 hn0) _ + omega + +/-- **Writing `2 ^ r n` marks.** If the number of coins is available in unary in +polynomial time and the number of coin strings is polynomially bounded, then +that many marks can be written in polynomial time. -/ +theorem unaryExp_mem_FP {r : ℕ → ℕ} + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + (p : Polynomial ℕ) (hp : ∀ n, 2 ^ r n ≤ p.eval n) : + (fun x : List Bool => List.replicate (2 ^ r x.length) true) ∈ FP := by + have hwidth : (fun z : List Bool => polyRuler p (id z)) ∈ FP := + polyRulerFn_mem_FP p id_mem_FP + have hbound : ∀ z : List Bool, ∀ n ≤ (List.replicate (r z.length) true).length, + (dbl^[n] [true]).length ≤ (polyRuler p (id z)).length := by + intro z n hn + rw [List.length_replicate] at hn + rw [dbl_iterate, List.length_replicate, polyRuler_length] + exact le_trans (Nat.pow_le_pow_right (by omega) hn) (hp z.length) + have hiter := Cobham.iterate_mem_FP dbl_mem_FP (constFn_mem_FP [true]) hr hwidth hbound + refine mem_FP_of_eq hiter fun x => ?_ + rw [List.length_replicate, dbl_iterate] + +open scoped Complexity in +/-- **The form the assembly uses.** A constructible logarithmic randomness bound +lets the number of coin strings be counted out in polynomial time. -/ +theorem unaryExp_mem_FP_of_bigO_log {r : ℕ → ℕ} + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + (h : r =O fun n => Nat.log 2 n) : + (fun x : List Bool => List.replicate (2 ^ r x.length) true) ∈ FP := by + obtain ⟨p, hp⟩ := exists_poly_two_pow_of_bigO_log h + exact unaryExp_mem_FP hr p hp + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/UnaryList.lean b/Complexitylib/Classes/PCP/Internal/UnaryList.lean new file mode 100644 index 00000000..e5c31fbd --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/UnaryList.lean @@ -0,0 +1,417 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PosScan +public import Complexitylib.Classes.PCP.Internal.UnaryDivMod +public import Complexitylib.Classes.PCP.Internal.NatEncode + +/-! +# Reading a table of unary numbers + +An algorithm that materializes a graph writes a list of records and reads them +back. `PosScan` reads an entry of an encoded list, and `DataEncode` writes the +entries; what is missing is getting a *number* back out, in the unary form the +loops of the toolkit consume. + +Storing the number in unary makes that a length computation: the encoding of a +unary string of `w` marks is `4 * w + 2` bits long — two brackets, and four bits +a mark — so dividing the length by four recovers the marks. No parsing of the +encoding is needed, and no binary arithmetic. + +The same scan reads the two halves of an encoded pair, since a pair is encoded +as the two-element list of its halves. + +## Main definitions + +- `Complexity.unaryOf` — the marks an encoded unary string stands for +- `Complexity.fstEnc`, `Complexity.sndEnc` — the halves of an encoded pair + +## Main results + +- `Complexity.unaryOf_encode`, `Complexity.unaryOf_mem_FP` +- `Complexity.fstEnc_eq`, `Complexity.sndEnc_eq`, and their `FP` versions +- `Complexity.tableFst_eq`, `Complexity.tableSnd_eq` — an entry of a table of + pairs of unary numbers, read back in unary +- `Complexity.recFst_eq`, `Complexity.recSnd_eq`, `Complexity.recThd_eq` — the + same for records of three numbers +- `Complexity.encPair_eq` — and written out +-/ + +@[expose] public section + +namespace Complexity + +/-! ### Numbers -/ + +/-- The size of an encoded unary string: two brackets and four bits a mark. -/ +theorem size_encode_replicate (w : ℕ) : + (DataEncode.encode (List.replicate w true)).size = 4 * w + 2 := by + have hone : (DataEncode.encode true).size = 4 := by + show (Data.l [Data.l []]).size = 4 + rw [Data.cons_size] + simp + induction w with + | zero => simp + | succ w ih => + have h : DataEncode.encode (List.replicate (w + 1) true) + = Data.l (DataEncode.encode true :: (List.replicate w true).map DataEncode.encode) := by + show Data.l ((List.replicate (w + 1) true).map DataEncode.encode) = _ + rw [List.replicate_succ, List.map_cons] + rw [h, Data.cons_size, hone, + show (Data.l ((List.replicate w true).map DataEncode.encode)).size + = (DataEncode.encode (List.replicate w true)).size from rfl, ih] + omega + +theorem length_bitstringEncode_replicate (w : ℕ) : + (DataEncode.bitstringEncode (List.replicate w true)).length = 4 * w + 2 := by + rw [DataEncode.bitstringEncode_def, Data.length_toBits, size_encode_replicate] + +/-- The unary number an encoded unary string stands for. -/ +noncomputable def unaryOf (e : List Bool) : List Bool := + divFn [false, false, false, false] (dropOne (dropOne e)) + +theorem unaryOf_encode (w : ℕ) : + unaryOf (DataEncode.bitstringEncode (List.replicate w true)) = List.replicate w true := by + rw [unaryOf, divFn_eq (by norm_num)] + congr 1 + have hlen : (dropOne (dropOne + (DataEncode.bitstringEncode (List.replicate w true)))).length = 4 * w := by + rw [dropOne, dropOne, List.length_drop, List.length_drop, + length_bitstringEncode_replicate] + omega + rw [hlen] + norm_num + +theorem unaryOf_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => unaryOf (a z)) ∈ FP := by + have h := mem_FP_comp (dropOneFn_mem_FP (dropOneFn_mem_FP ha)) + (divFn_mem_FP [false, false, false, false]) + exact mem_FP_of_eq h fun z => rfl + +/-! ### Pairs -/ + +/-- The first half of an encoded pair. -/ +noncomputable def fstEnc (e : List Bool) : List Bool := posAt e 0 + +/-- The second half of an encoded pair. -/ +noncomputable def sndEnc (e : List Bool) : List Bool := posAt e 1 + +theorem bitstringEncode_prod {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : + DataEncode.bitstringEncode (a, b) + = DataEncode.bitstringEncode + ([DataEncode.encode a, DataEncode.encode b] : List Data) := by + rw [DataEncode.bitstringEncode_def, DataEncode.bitstringEncode_def, DataEncode_pair] + show _ = (Data.l (([DataEncode.encode a, DataEncode.encode b] : List Data).map id)).toBits + rw [List.map_id] + +theorem fstEnc_eq {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : + fstEnc (DataEncode.bitstringEncode (a, b)) = DataEncode.bitstringEncode a := by + rw [fstEnc, bitstringEncode_prod, + posAt_eq_of_lt (l := ([DataEncode.encode a, DataEncode.encode b] : List Data)) + (by norm_num)] + rfl + +theorem sndEnc_eq {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : + sndEnc (DataEncode.bitstringEncode (a, b)) = DataEncode.bitstringEncode b := by + rw [sndEnc, bitstringEncode_prod, + posAt_eq_of_lt (l := ([DataEncode.encode a, DataEncode.encode b] : List Data)) + (by norm_num)] + rfl + +theorem fstEnc_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => fstEnc (a z)) ∈ FP := by + have h := posAt_mem_FP (constFn_mem_FP ([] : List Bool)) ha + exact mem_FP_of_eq h fun z => rfl + +theorem sndEnc_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => sndEnc (a z)) ∈ FP := by + have h := posAt_mem_FP (constFn_mem_FP ([true] : List Bool)) ha + exact mem_FP_of_eq h fun z => rfl + +/-! ### Unary arithmetic with constants -/ + +/-- Any string, as that many marks. -/ +noncomputable def marks (s : List Bool) : List Bool := divFn [false] s + +theorem marks_eq (s : List Bool) : marks s = List.replicate s.length true := by + rw [marks, divFn_eq (by norm_num)] + simp + +theorem marks_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => marks (a z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp ha (divFn_mem_FP [false])) fun _ => rfl + +/-- Division by a constant. -/ +noncomputable def divC (c : ℕ) (s : List Bool) : List Bool := + divFn (List.replicate c false) s + +theorem divC_eq {c : ℕ} (hc : 0 < c) (s : List Bool) : + divC c s = List.replicate (s.length / c) true := by + rw [divC, divFn_eq (by simpa using hc), List.length_replicate] + +theorem divC_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) (c : ℕ) : + (fun z => divC c (a z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp ha (divFn_mem_FP _)) fun _ => rfl + +/-- Remainder by a constant. -/ +noncomputable def modC (c : ℕ) (s : List Bool) : List Bool := + modFn (List.replicate c false) s + +theorem modC_eq {c : ℕ} (hc : 0 < c) (s : List Bool) : + modC c s = List.replicate (s.length % c) true := by + rw [modC, modFn_eq (by simpa using hc), List.length_replicate] + +theorem modC_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) (c : ℕ) : + (fun z => modC c (a z)) ∈ FP := + mem_FP_of_eq (mem_FP_comp ha (modFn_mem_FP _)) fun _ => rfl + +/-- The product of two lengths. -/ +def mulLen (a b : List Bool) : List Bool := List.replicate (a.length * b.length) false + +@[simp] theorem length_mulLen (a b : List Bool) : + (mulLen a b).length = a.length * b.length := by + rw [mulLen, List.length_replicate] + +theorem mulLen_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => mulLen (f z) (g z)) ∈ FP := + Cobham.mulLenFn_mem_FP hf hg + +/-- Multiplication by a constant, as a length. -/ +def mulC (c : ℕ) (s : List Bool) : List Bool := List.replicate (s.length * c) false + +@[simp] theorem length_mulC (c : ℕ) (s : List Bool) : (mulC c s).length = s.length * c := by + rw [mulC, List.length_replicate] + +theorem mulC_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) (c : ℕ) : + (fun z => mulC c (a z)) ∈ FP := by + have := Cobham.mulLenFn_mem_FP ha (constFn_mem_FP (List.replicate c false)) + refine mem_FP_of_eq this fun z => ?_ + rw [mulC, List.length_replicate] + +/-! ### Writing records -/ + +/-- The encoding of a unary string. -/ +def encUnary (s : List Bool) : List Bool := false :: s.flatMap boolBits ++ [true] + +theorem encUnary_eq (s : List Bool) : encUnary s = DataEncode.bitstringEncode s := + (bitstringEncode_list s).symm + +theorem encUnary_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : + (fun z => encUnary (a z)) ∈ FP := by + have hflat : (fun z => (a z).flatMap boolBits) ∈ FP := by + have hpair : (fun z => pair z (a z)) ∈ FP := Cobham.pairFn_mem_FP id_mem_FP ha + have := mem_FP_comp hpair flatBitsFn_mem_FP + refine mem_FP_of_eq this fun z => ?_ + rw [Function.comp_apply, flatBitsFn_eq, Cobham.sndBlock_pair] + have hcons := mem_FP_comp hflat (Cobham.cons_mem_FP false) + have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) + exact mem_FP_of_eq this fun z => rfl + +/-- The encoding of a pair of unary strings. -/ +def encPair (a b : List Bool) : List Bool := false :: (encUnary a ++ encUnary b) ++ [true] + +theorem bitstringEncode_prod_eq {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : + DataEncode.bitstringEncode ((a, b) : α × β) + = false :: (DataEncode.bitstringEncode a ++ DataEncode.bitstringEncode b) ++ [true] := by + rw [DataEncode.bitstringEncode_def, DataEncode_pair, Data.toBits_l] + simp [DataEncode.bitstringEncode_def] + +theorem encPair_eq (a b : List Bool) : + encPair a b = DataEncode.bitstringEncode ((a, b) : List Bool × List Bool) := by + rw [bitstringEncode_prod_eq, encPair, encUnary_eq, encUnary_eq] + +theorem encPair_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => encPair (a z) (b z)) ∈ FP := by + have happ := Cobham.appendFn_mem_FP (encUnary_mem_FP ha) (encUnary_mem_FP hb) + have hcons := mem_FP_comp happ (Cobham.cons_mem_FP false) + have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) + exact mem_FP_of_eq this fun z => rfl + +theorem unaryOf_fstEnc_encPair (w c : ℕ) : + unaryOf (fstEnc (encPair (List.replicate w true) (List.replicate c true))) + = List.replicate w true := by + rw [encPair_eq, fstEnc_eq, unaryOf_encode] + +theorem unaryOf_sndEnc_encPair (w c : ℕ) : + unaryOf (sndEnc (encPair (List.replicate w true) (List.replicate c true))) + = List.replicate c true := by + rw [encPair_eq, sndEnc_eq, unaryOf_encode] + +@[simp] theorem marks_append_mulC (w m c : ℕ) : + marks (List.replicate w true ++ mulC c (List.replicate m true)) + = List.replicate (w + m * c) true := by + rw [marks_eq, List.length_append, List.length_replicate, length_mulC, + List.length_replicate] + +theorem length_mulC_append (m c w : ℕ) : + (mulC c (List.replicate m true) ++ List.replicate w true).length = m * c + w := by + rw [List.length_append, length_mulC, List.length_replicate, List.length_replicate] + +/-- The encoding of a list is two brackets and its entries' encodings. -/ +theorem length_bitstringEncode_list {α : Type} [DataEncode α] (l : List α) : + (DataEncode.bitstringEncode l).length + = 2 + (l.map fun a => (DataEncode.bitstringEncode a).length).sum := by + induction l with + | nil => simp [DataEncode.bitstringEncode_def] + | cons a l ih => + have hcons : DataEncode.encode (a :: l) + = Data.l (DataEncode.encode a :: l.map DataEncode.encode) := rfl + have htail : DataEncode.encode l = Data.l (l.map DataEncode.encode) := rfl + rw [DataEncode.bitstringEncode_def, hcons, Data.length_toBits, Data.cons_size, + ← htail, ← Data.length_toBits, ← Data.length_toBits, + ← DataEncode.bitstringEncode_def, ← DataEncode.bitstringEncode_def, ih] + simp + omega + +@[simp] theorem length_encPair (w c : ℕ) : + (encPair (List.replicate w true) (List.replicate c true)).length = 4 * w + 4 * c + 6 := by + rw [encPair_eq, ← encPair_eq, encPair, encUnary_eq, encUnary_eq] + simp only [List.length_append, List.length_cons, List.length_nil, + length_bitstringEncode_replicate] + omega + +/-! ### Tables of pairs of numbers -/ + +/-- The first number of the `j`-th record of a table, in unary. -/ +noncomputable def tableFst (T : List Bool) (j : ℕ) : List Bool := unaryOf (fstEnc (posAt T j)) + +/-- The second number of the `j`-th record of a table, in unary. -/ +noncomputable def tableSnd (T : List Bool) (j : ℕ) : List Bool := unaryOf (sndEnc (posAt T j)) + +variable {l : List (List Bool × List Bool)} {j w c : ℕ} + +theorem tableFst_def (T : List Bool) (j : ℕ) : + tableFst T j = unaryOf (fstEnc (posAt T j)) := rfl + +theorem tableSnd_def (T : List Bool) (j : ℕ) : + tableSnd T j = unaryOf (sndEnc (posAt T j)) := rfl + +theorem tableFst_eq (hj : j < l.length) + (h : l[j]'hj = (List.replicate w true, List.replicate c true)) : + tableFst (DataEncode.bitstringEncode l) j = List.replicate w true := by + rw [tableFst, posAt_eq_of_lt hj, h, fstEnc_eq, unaryOf_encode] + +theorem tableSnd_eq (hj : j < l.length) + (h : l[j]'hj = (List.replicate w true, List.replicate c true)) : + tableSnd (DataEncode.bitstringEncode l) j = List.replicate c true := by + rw [tableSnd, posAt_eq_of_lt hj, h, sndEnc_eq, unaryOf_encode] + +theorem tableFst_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => tableFst (b z) (a z).length) ∈ FP := + unaryOf_mem_FP (fstEnc_mem_FP (posAt_mem_FP ha hb)) + +theorem tableSnd_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => tableSnd (b z) (a z).length) ∈ FP := + unaryOf_mem_FP (sndEnc_mem_FP (posAt_mem_FP ha hb)) + +/-! ### Records of three numbers -/ + +/-- The encoding of three unary strings. -/ +def encTriple (a b c : List Bool) : List Bool := false :: (encUnary a ++ encPair b c) ++ [true] + +theorem encTriple_eq (a b c : List Bool) : + encTriple a b c + = DataEncode.bitstringEncode ((a, (b, c)) : List Bool × List Bool × List Bool) := by + rw [bitstringEncode_prod_eq, encTriple, encUnary_eq, ← encPair_eq] + +@[simp] theorem length_encTriple (a b c : ℕ) : + (encTriple (List.replicate a true) (List.replicate b true) + (List.replicate c true)).length = 4 * a + 4 * b + 4 * c + 10 := by + rw [encTriple, encUnary_eq] + simp only [List.length_append, List.length_cons, List.length_nil, + length_bitstringEncode_replicate, length_encPair] + omega + +theorem encTriple_mem_FP {a b c : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) + (hc : c ∈ FP) : (fun z => encTriple (a z) (b z) (c z)) ∈ FP := by + have happ := Cobham.appendFn_mem_FP (encUnary_mem_FP ha) (encPair_mem_FP hb hc) + have hcons := mem_FP_comp happ (Cobham.cons_mem_FP false) + have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) + exact mem_FP_of_eq this fun _ => rfl + +/-- The first number of the `j`-th record of a table of triples. -/ +noncomputable def recFst (T : List Bool) (j : ℕ) : List Bool := unaryOf (fstEnc (posAt T j)) + +/-- The second. -/ +noncomputable def recSnd (T : List Bool) (j : ℕ) : List Bool := + unaryOf (fstEnc (sndEnc (posAt T j))) + +/-- The third. -/ +noncomputable def recThd (T : List Bool) (j : ℕ) : List Bool := + unaryOf (sndEnc (sndEnc (posAt T j))) + +variable {l3 : List (List Bool × List Bool × List Bool)} {a b c : ℕ} + +theorem recFst_eq (hj : j < l3.length) + (h : l3[j]'hj = (List.replicate a true, List.replicate b true, List.replicate c true)) : + recFst (DataEncode.bitstringEncode l3) j = List.replicate a true := by + rw [recFst, posAt_eq_of_lt hj, h, fstEnc_eq, unaryOf_encode] + +theorem recSnd_eq (hj : j < l3.length) + (h : l3[j]'hj = (List.replicate a true, List.replicate b true, List.replicate c true)) : + recSnd (DataEncode.bitstringEncode l3) j = List.replicate b true := by + rw [recSnd, posAt_eq_of_lt hj, h, sndEnc_eq, fstEnc_eq, unaryOf_encode] + +theorem recThd_eq (hj : j < l3.length) + (h : l3[j]'hj = (List.replicate a true, List.replicate b true, List.replicate c true)) : + recThd (DataEncode.bitstringEncode l3) j = List.replicate c true := by + rw [recThd, posAt_eq_of_lt hj, h, sndEnc_eq, sndEnc_eq, unaryOf_encode] + +theorem recFst_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => recFst (g z) (f z).length) ∈ FP := + unaryOf_mem_FP (fstEnc_mem_FP (posAt_mem_FP hf hg)) + +theorem recSnd_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => recSnd (g z) (f z).length) ∈ FP := + unaryOf_mem_FP (fstEnc_mem_FP (sndEnc_mem_FP (posAt_mem_FP hf hg))) + +theorem recThd_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : + (fun z => recThd (g z) (f z).length) ∈ FP := + unaryOf_mem_FP (sndEnc_mem_FP (sndEnc_mem_FP (posAt_mem_FP hf hg))) + +/-! ### Digit sums -/ + +/-- A number from its digits: `∑ j < n, digit j · radix ^ j`, written in marks. +The digits are read from the input, so this is how an algorithm assembles a +mixed-radix number out of constantly many pieces. -/ +noncomputable def digitSum (radix : ℕ) (digit : ℕ → List Bool → List Bool) : + ℕ → List Bool → List Bool + | 0, _ => [] + | n + 1, w => digitSum radix digit n w ++ mulC (radix ^ n) (digit n w) + +theorem digitSum_mem_FP {radix : ℕ} {digit : ℕ → List Bool → List Bool} + (hd : ∀ i, digit i ∈ FP) : ∀ n, digitSum radix digit n ∈ FP := by + intro n + induction n with + | zero => exact mem_FP_of_eq (constFn_mem_FP []) fun w => by rw [digitSum] + | succ n ih => + refine mem_FP_of_eq (Cobham.appendFn_mem_FP ih + (mulC_mem_FP (hd n) (radix ^ n))) fun w => ?_ + rw [digitSum] + +@[simp] theorem length_digitSum (radix : ℕ) (digit : ℕ → List Bool → List Bool) + (w : List Bool) : ∀ n, (digitSum radix digit n w).length + = ∑ j ∈ Finset.range n, (digit j w).length * radix ^ j := by + intro n + induction n with + | zero => rw [digitSum, Finset.range_zero, Finset.sum_empty, List.length_nil] + | succ n ih => + rw [digitSum, List.length_append, ih, Finset.sum_range_succ, length_mulC] + +theorem length_digitSum_le {radix : ℕ} (hr : 0 < radix) + {digit : ℕ → List Bool → List Bool} {d : ℕ} (hd : ∀ j w, (digit j w).length ≤ d) + (n : ℕ) (w : List Bool) : + (digitSum radix digit n w).length ≤ n * (d * radix ^ n) := by + rw [length_digitSum] + calc ∑ j ∈ Finset.range n, (digit j w).length * radix ^ j + ≤ ∑ _j ∈ Finset.range n, d * radix ^ n := by + refine Finset.sum_le_sum fun j hj => ?_ + rw [Finset.mem_range] at hj + exact Nat.mul_le_mul (hd j w) (Nat.pow_le_pow_right hr (le_of_lt hj)) + _ = n * (d * radix ^ n) := by + rw [Finset.sum_const, Finset.card_range, smul_eq_mul] + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Union.lean b/Complexitylib/Classes/PCP/Internal/Union.lean new file mode 100644 index 00000000..91e9e3ce --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Union.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.RegularGraph + +/-! +# Superposing two graphs, and expanderization + +Dinur's preprocessing turns an arbitrary regular constraint graph into one that +is also an *expander*, by laying an expander over the same vertex set and taking +the union of the two edge sets. This module builds that union and bounds its +spectral gap. + +The union of a graph `G` with a graph `H` — identified with `G`'s vertices along +a bijection `e` — has label type `G.D ⊕ H.D` and degree `G.deg + H.deg`. Its +walk operator is the weighted average of the two: + +`step_U f = (G.deg • step_G f + H.deg • step_H (f ∘ e)) / (G.deg + H.deg)` + +so if `H` contracts mean-zero functions by `lam`, the union contracts them by +`(G.deg + H.deg * lam) / (G.deg + H.deg)` — strictly below one whenever `lam` is +— using nothing about `G` beyond `sum_sq_step_le`, that its own walk operator is +a contraction. + +## Staying square-root-free + +The triangle inequality looks unavailable in the squared-norm formulation, but +it is not needed. Expanding `‖aX + bY‖²` leaves a cross term `⟨X, Y⟩`, and +Cauchy–Schwarz bounds its *square* by `‖X‖² ‖Y‖² ≤ A · lam² A = (lam A)²` — +whose square root, `lam A`, is rational in the data. So the cross term is +bounded with one application of `le_of_sq_le_sq` and no `Real.sqrt` ever +appears. + +## Main definitions + +- `RegGraph.unionRot` — the rotation map of the union +- `RegGraph.union` — the union graph + +## Main results + +- `RegGraph.deg_union`, `RegGraph.step_union` +- `RegGraph.sum_sq_step_union_le` — the combined contraction bound +- `RegGraph.spectralBound_union` — expanderization: laying an expander over any + regular graph gives a spectral bound strictly below one +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G H : RegGraph) (e : H.V ≃ G.V) + +/-- The rotation map of the union: reverse within `G`, or within `H` after +transporting along `e`. -/ +def unionRot : G.V × (G.D ⊕ H.D) → G.V × (G.D ⊕ H.D) + | (v, Sum.inl i) => ((G.rot (v, i)).1, Sum.inl (G.rot (v, i)).2) + | (v, Sum.inr j) => (e (H.rot (e.symm v, j)).1, Sum.inr (H.rot (e.symm v, j)).2) + +theorem unionRot_involutive : Function.Involutive (unionRot G H e) := by + rintro ⟨v, i | j⟩ + · show ((G.rot ((G.rot (v, i)).1, (G.rot (v, i)).2)).1, + Sum.inl (G.rot ((G.rot (v, i)).1, (G.rot (v, i)).2)).2) = (v, Sum.inl i) + rw [Prod.mk.eta, G.rot_involutive (v, i)] + · show (e (H.rot (e.symm (e (H.rot (e.symm v, j)).1), (H.rot (e.symm v, j)).2)).1, + Sum.inr (H.rot (e.symm (e (H.rot (e.symm v, j)).1), (H.rot (e.symm v, j)).2)).2) + = (v, Sum.inr j) + rw [Equiv.symm_apply_apply, Prod.mk.eta, H.rot_involutive (e.symm v, j)] + simp + +/-- The union of `G` with `H`, whose vertices are identified with `G`'s along +`e`: the edge sets are superposed. -/ +def union : RegGraph where + V := G.V + D := G.D ⊕ H.D + decEqV := G.decEqV + decEqD := inferInstance + fintypeV := G.fintypeV + fintypeD := inferInstance + nonemptyD := ⟨Sum.inl (Classical.arbitrary G.D)⟩ + rot := unionRot G H e + rot_involutive := unionRot_involutive G H e + +@[simp] theorem V_union : (union G H e).V = G.V := rfl + +@[simp] theorem order_union : (union G H e).order = G.order := rfl + +@[simp] theorem deg_union : (union G H e).deg = G.deg + H.deg := by + show Fintype.card (G.D ⊕ H.D) = G.deg + H.deg + rw [Fintype.card_sum] + rfl + +theorem nbr_union_inl (v : G.V) (i : G.D) : (union G H e).nbr v (Sum.inl i) = G.nbr v i := rfl + +theorem nbr_union_inr (v : G.V) (j : H.D) : + (union G H e).nbr v (Sum.inr j) = e (H.nbr (e.symm v) j) := rfl + +/-- The union's walk operator is the degree-weighted average of the two walk +operators, the second read through the identification `e`. -/ +theorem step_union (f : G.V → ℝ) (v : G.V) : + (union G H e).step f v + = ((G.deg : ℝ) * G.step f v + (H.deg : ℝ) * H.step (fun u => f (e u)) (e.symm v)) + / ((G.deg : ℝ) + (H.deg : ℝ)) := by + have hdG : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + have hdH : (H.deg : ℝ) ≠ 0 := H.deg_ne_zero + have hsum : ∑ i : (union G H e).D, f ((union G H e).nbr v i) + = (∑ i : G.D, f (G.nbr v i)) + ∑ j : H.D, f (e (H.nbr (e.symm v) j)) := by + show ∑ i : G.D ⊕ H.D, f ((union G H e).nbr v i) = _ + rw [Fintype.sum_sum_type] + rfl + rw [step, hsum, deg_union] + push_cast + rw [step, step] + field_simp + +/-! ### The combined contraction bound -/ + +/-- The cross term in the expansion of the union's walk operator, bounded by +Cauchy–Schwarz without any square root. -/ +private theorem sum_mul_le_of_sq_le {X Y : G.V → ℝ} {A lam : ℝ} (hlam : 0 ≤ lam) + (hA : 0 ≤ A) (hX : (∑ v : G.V, (X v) ^ 2) ≤ A) + (hY : (∑ v : G.V, (Y v) ^ 2) ≤ lam ^ 2 * A) : + (∑ v : G.V, X v * Y v) ≤ lam * A := by + have hcs : (∑ v : G.V, X v * Y v) ^ 2 + ≤ (∑ v : G.V, (X v) ^ 2) * ∑ v : G.V, (Y v) ^ 2 := + Finset.sum_mul_sq_le_sq_mul_sq _ _ _ + have hprod : (∑ v : G.V, (X v) ^ 2) * (∑ v : G.V, (Y v) ^ 2) ≤ (lam * A) ^ 2 := by + have h1 : (0 : ℝ) ≤ ∑ v : G.V, (X v) ^ 2 := Finset.sum_nonneg fun _ _ => sq_nonneg _ + have h2 : (0 : ℝ) ≤ ∑ v : G.V, (Y v) ^ 2 := Finset.sum_nonneg fun _ _ => sq_nonneg _ + calc (∑ v : G.V, (X v) ^ 2) * (∑ v : G.V, (Y v) ^ 2) + ≤ A * (lam ^ 2 * A) := by + exact mul_le_mul hX hY h2 hA + _ = (lam * A) ^ 2 := by ring + exact le_of_sq_le_sq (le_trans hcs hprod) (by positivity) + +/-- **Expanderization, quantitatively.** If `H` contracts mean-zero functions by +`lam`, then the union contracts them by the degree-weighted average of `1` and +`lam`. -/ +theorem sum_sq_step_union_le {lam : ℝ} (hlam : 0 ≤ lam) (hH : H.SpectralBound lam) + (f : G.V → ℝ) (hf : (∑ v : G.V, f v) = 0) : + (∑ v : G.V, ((union G H e).step f v) ^ 2) + ≤ (((G.deg : ℝ) + (H.deg : ℝ) * lam) / ((G.deg : ℝ) + (H.deg : ℝ))) ^ 2 + * ∑ v : G.V, (f v) ^ 2 := by + set A : ℝ := ∑ v : G.V, (f v) ^ 2 with hAdef + have hA : 0 ≤ A := Finset.sum_nonneg fun _ _ => sq_nonneg _ + have hdG : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity + have hdH : (0 : ℝ) < (H.deg : ℝ) := by have := H.deg_pos; positivity + set X : G.V → ℝ := fun v => G.step f v with hXdef + set Y : G.V → ℝ := fun v => H.step (fun u => f (e u)) (e.symm v) with hYdef + -- the two individual bounds + have hX : (∑ v : G.V, (X v) ^ 2) ≤ A := G.sum_sq_step_le f + have hfe : (∑ u : H.V, f (e u)) = 0 := by + rw [Equiv.sum_comp e f, hf] + have hYtrans : (∑ v : G.V, (Y v) ^ 2) + = ∑ u : H.V, (H.step (fun u => f (e u)) u) ^ 2 := by + rw [← Equiv.sum_comp e (fun v => (H.step (fun u => f (e u)) (e.symm v)) ^ 2)] + exact Finset.sum_congr rfl fun u _ => by rw [Equiv.symm_apply_apply] + have hY : (∑ v : G.V, (Y v) ^ 2) ≤ lam ^ 2 * A := by + rw [hYtrans] + have h := hH (fun u => f (e u)) hfe + calc ∑ u : H.V, (H.step (fun u => f (e u)) u) ^ 2 + ≤ lam ^ 2 * ∑ u : H.V, (f (e u)) ^ 2 := h + _ = lam ^ 2 * A := by rw [hAdef, Equiv.sum_comp e (fun v => (f v) ^ 2)] + have hcross : (∑ v : G.V, X v * Y v) ≤ lam * A := + sum_mul_le_of_sq_le G hlam hA hX hY + -- expand the union's operator + have hexp : ∀ v : G.V, ((union G H e).step f v) ^ 2 + = ((G.deg : ℝ) ^ 2 * (X v) ^ 2 + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (X v * Y v) + + (H.deg : ℝ) ^ 2 * (Y v) ^ 2) / ((G.deg : ℝ) + (H.deg : ℝ)) ^ 2 := by + intro v + rw [step_union] + field_simp + ring + have hden : (0 : ℝ) < ((G.deg : ℝ) + (H.deg : ℝ)) ^ 2 := by positivity + rw [Finset.sum_congr rfl fun v _ => hexp v, ← Finset.sum_div] + rw [div_le_iff₀ hden] + have hsplit : ∑ v : G.V, ((G.deg : ℝ) ^ 2 * (X v) ^ 2 + + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (X v * Y v) + (H.deg : ℝ) ^ 2 * (Y v) ^ 2) + = (G.deg : ℝ) ^ 2 * (∑ v : G.V, (X v) ^ 2) + + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (∑ v : G.V, X v * Y v) + + (H.deg : ℝ) ^ 2 * ∑ v : G.V, (Y v) ^ 2 := by + rw [Finset.sum_add_distrib, Finset.sum_add_distrib, ← Finset.mul_sum, ← Finset.mul_sum, + ← Finset.mul_sum] + rw [hsplit] + have hgoal : (G.deg : ℝ) ^ 2 * (∑ v : G.V, (X v) ^ 2) + + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (∑ v : G.V, X v * Y v) + + (H.deg : ℝ) ^ 2 * (∑ v : G.V, (Y v) ^ 2) + ≤ (G.deg : ℝ) ^ 2 * A + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (lam * A) + + (H.deg : ℝ) ^ 2 * (lam ^ 2 * A) := by + have h1 : (G.deg : ℝ) ^ 2 * (∑ v : G.V, (X v) ^ 2) ≤ (G.deg : ℝ) ^ 2 * A := by + exact mul_le_mul_of_nonneg_left hX (by positivity) + have h2 : 2 * (G.deg : ℝ) * (H.deg : ℝ) * (∑ v : G.V, X v * Y v) + ≤ 2 * (G.deg : ℝ) * (H.deg : ℝ) * (lam * A) := by + exact mul_le_mul_of_nonneg_left hcross (by positivity) + have h3 : (H.deg : ℝ) ^ 2 * (∑ v : G.V, (Y v) ^ 2) ≤ (H.deg : ℝ) ^ 2 * (lam ^ 2 * A) := by + exact mul_le_mul_of_nonneg_left hY (by positivity) + linarith + calc (G.deg : ℝ) ^ 2 * (∑ v : G.V, (X v) ^ 2) + + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (∑ v : G.V, X v * Y v) + + (H.deg : ℝ) ^ 2 * (∑ v : G.V, (Y v) ^ 2) + ≤ (G.deg : ℝ) ^ 2 * A + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (lam * A) + + (H.deg : ℝ) ^ 2 * (lam ^ 2 * A) := hgoal + _ = (((G.deg : ℝ) + (H.deg : ℝ) * lam) / ((G.deg : ℝ) + (H.deg : ℝ))) ^ 2 * A + * ((G.deg : ℝ) + (H.deg : ℝ)) ^ 2 := by + field_simp + ring + +/-- **Expanderization.** -/ +theorem spectralBound_union {lam : ℝ} (hlam : 0 ≤ lam) (hH : H.SpectralBound lam) : + (union G H e).SpectralBound + (((G.deg : ℝ) + (H.deg : ℝ) * lam) / ((G.deg : ℝ) + (H.deg : ℝ))) := + fun f hf => sum_sq_step_union_le G H e hlam hH f hf + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/VerifierLang.lean b/Complexitylib/Classes/PCP/Internal/VerifierLang.lean new file mode 100644 index 00000000..4cb41bce --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/VerifierLang.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.PosScan +public import Complexitylib.Classes.PCP.Internal.UnaryExp +public import Complexitylib.Classes.PCP.Internal.BoundedQuant + +/-! +# The witness layout of a PCP verifier + +A witness for a PCP verifier is a table of answers, one fixed-width block per +coin string. This module fixes that layout and reads it back: the block for a +coin string, cut down to the number of queries actually made, is exactly the +answer list `SubsetNP.tableOf` names. + +It also records that the query bound can be taken to be a *constant*. A bound +`q =O 1` need not be a computable function, but it is eventually bounded and +takes finitely many values before that, so a single number bounds every query +list — which is what an algorithm can actually use. + +## Main definitions + +- `Complexity.wBlock` — the witness block for one coin string + +## Main results + +- `Complexity.exists_const_query_bound` — a constant bounds every query list +- `Complexity.tableOf_eq_wBlock` — the block is the answer list +- `Complexity.accLang_mem_P` — checking every coin string is polynomial time +-/ + +@[expose] public section + +namespace Complexity + +open scoped Complexity in +/-- **A constant bounds every query list.** This is what makes the witness +layout uniform: each block has the same fixed width. -/ +theorem exists_const_query_bound {V : PCPVerifier} {q : ℕ → ℕ} + (hV : V.QueryBounded q) (hq : q =O fun _ => 1) : + ∃ K : ℕ, ∀ x ρ : List Bool, (V.positions x ρ).length ≤ K := by + rw [BigO, Asymptotics.isBigO_iff] at hq + obtain ⟨C, hC⟩ := hq + rw [Filter.eventually_atTop] at hC + obtain ⟨N, hN⟩ := hC + refine ⟨max ⌈C⌉₊ ((Finset.range (N + 1)).sup q), fun x ρ => ?_⟩ + refine le_trans (hV x ρ) ?_ + by_cases h : x.length < N + 1 + · exact le_trans (Finset.le_sup (f := q) (Finset.mem_range.mpr h)) (le_max_right _ _) + · have hb := hN x.length (by omega) + simp only [Real.norm_natCast, Nat.cast_one, norm_one, mul_one] at hb + have hqc : q x.length ≤ ⌈C⌉₊ := by exact_mod_cast le_trans hb (Nat.le_ceil C) + exact le_trans hqc (le_max_left _ _) + +/-- The witness block starting at `start` and holding `len` answers. -/ +def wBlock (w : List Bool) (start len : ℕ) : List Bool := (w.drop start).take len + +theorem wBlock_mem_FP {w s l : List Bool → List Bool} + (hw : w ∈ FP) (hs : s ∈ FP) (hl : l ∈ FP) : + (fun z => wBlock (w z) (s z).length (l z).length) ∈ FP := + Cobham.takeLenFn_mem_FP hl (dropLenFn_mem_FP hs hw) + +theorem length_wBlock {w : List Bool} {start len : ℕ} (h : start + len ≤ w.length) : + (wBlock w start len).length = len := by + rw [wBlock, List.length_take, List.length_drop] + omega + +theorem getElem_wBlock {w : List Bool} {start len : ℕ} (h : start + len ≤ w.length) + {i : ℕ} (hi : i < len) : + (wBlock w start len)[i]'(by rw [length_wBlock h]; exact hi) = w.getD (start + i) false := by + have hlt : start + i < w.length := by omega + simp only [wBlock] + rw [List.getElem_take, List.getElem_drop] + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem hlt] + rfl + +/-- **The block is the answer list.** With the answers for coin index `c` laid +out in the slots `c * Q, …`, the witness block is exactly the table +`SubsetNP.tableOf` reads. -/ +theorem tableOf_eq_wBlock (V : PCPVerifier) (t Q : ℕ) (x w : List Bool) + (ρ : Fin t → Bool) + (h : PCPVerifier.coinIndex ρ * Q + (V.positions x (BitString.toList ρ)).length + ≤ w.length) : + V.tableOf t Q x w ρ + = wBlock w (PCPVerifier.coinIndex ρ * Q) + (V.positions x (BitString.toList ρ)).length := by + refine List.ext_getElem ?_ fun i h1 h2 => ?_ + · rw [V.length_tableOf t Q x w ρ, length_wBlock h] + · have hi : i < (V.positions x (BitString.toList ρ)).length := by + rwa [V.length_tableOf t Q x w ρ] at h1 + rw [getElem_wBlock h hi] + show (List.map _ (List.range _))[i] = _ + rw [List.getElem_map, List.getElem_range] + +/-- A one-bit block is the bit it holds. -/ +theorem wBlock_one {w : List Bool} {k : ℕ} (h : k < w.length) : + wBlock w k 1 = [w.getD k false] := by + rw [wBlock, List.drop_eq_getElem_cons h] + simp only [List.take_succ_cons, List.take_zero] + congr 1 + rw [List.getD_eq_getElem?_getD, List.getElem?_eq_getElem h] + rfl + +/-- Reading a slot of the table. -/ +theorem getElem?_tableOf (V : PCPVerifier) (t Q : ℕ) (x w : List Bool) + (ρ : Fin t → Bool) {i : ℕ} (hi : i < (V.positions x (BitString.toList ρ)).length) : + (V.tableOf t Q x w ρ)[i]? = some (w.getD (PCPVerifier.coinIndex ρ * Q + i) false) := by + rw [PCPVerifier.tableOf, List.getElem?_map, List.getElem?_range hi] + rfl + +/-! ### Acceptance on every coin string + +The check is a loop over coin indices. Each iteration recovers the coin string +from its index, reads the verifier's query list to learn how many answers this +coin string uses, cuts that many out of the witness block, and asks the verdict. +-/ + +section Acceptance + +variable (V : PCPVerifier) (f : List Bool → List Bool) (r : ℕ → ℕ) (Q : ℕ) + +/-- The input of one iteration is `pair (pair x w) (unary c)`. -/ +def accX (y : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock y) + +/-- The witness, out of the iteration's input. -/ +def accW (y : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock y) + +/-- The coin string named by the iteration's index. -/ +noncomputable def accCoin (y : List Bool) : List Bool := + coinStr (r (accX y).length) (Cobham.sndBlock y).length + +/-- The verifier's view: input and coins paired with the answers read off the +witness block. -/ +noncomputable def accView (y : List Bool) : List Bool := + pair (pair (accX y) (accCoin r y)) + (wBlock (accW y) ((Cobham.sndBlock y).length * Q) + (posCount (f (pair (accX y) (accCoin r y)))).length) + +theorem accX_mem_FP : accX ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP + +theorem accW_mem_FP : accW ∈ FP := + mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP + +theorem accCoin_mem_FP + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) : + accCoin r ∈ FP := by + have ht : (fun y : List Bool => List.replicate (r (accX y).length) true) ∈ FP := by + have := mem_FP_comp accX_mem_FP hr + simpa [Function.comp] using this + have hc : (fun y : List Bool => List.replicate (Cobham.sndBlock y).length true) ∈ FP := by + have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP + simpa [Function.comp] using this + exact coinStr_mem_FP ht hc + +theorem accView_mem_FP (hf : f ∈ FP) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) : + accView f r Q ∈ FP := by + have hcoin := accCoin_mem_FP r hr + have hview : (fun y => pair (accX y) (accCoin r y)) ∈ FP := + Cobham.pairFn_mem_FP accX_mem_FP hcoin + have hfv : (fun y => f (pair (accX y) (accCoin r y))) ∈ FP := by + have := mem_FP_comp hview hf + simpa [Function.comp] using this + have hcount : (fun y => posCount (f (pair (accX y) (accCoin r y)))) ∈ FP := + posCount_mem_FP hfv + have hoff : (fun y : List Bool => + List.replicate ((Cobham.sndBlock y).length * Q) false) ∈ FP := by + have hb : (fun _ : List Bool => List.replicate Q false) ∈ FP := + Cobham.const_replicate_mem_FP Q + have := Cobham.mulLenFn_mem_FP Cobham.sndBlock_mem_FP hb + refine mem_FP_of_eq this fun y => ?_ + rw [List.length_replicate] + have hblk : (fun y => wBlock (accW y) + (List.replicate ((Cobham.sndBlock y).length * Q) false).length + (posCount (f (pair (accX y) (accCoin r y)))).length) ∈ FP := + wBlock_mem_FP accW_mem_FP hoff hcount + refine Cobham.pairFn_mem_FP hview (mem_FP_of_eq hblk fun y => ?_) + rw [List.length_replicate] + +/-- One iteration's condition: the verifier accepts the view. -/ +noncomputable def accInner : Language := accView f r Q ⁻¹' V.verdict + +theorem accInner_mem_P (hf : f ∈ FP) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) : + accInner V f r Q ∈ P := + mem_P_preimage (accView_mem_FP f r Q hf hr) V.verdict_mem + +/-- **Acceptance on every coin string**, as a language of `pair x w`. -/ +noncomputable def accLang : Language := + {z : List Bool | ∀ c < 2 ^ r (Cobham.fstBlock z).length, + pair z (List.replicate c true) ∈ accInner V f r Q} + +open scoped Complexity in +theorem accLang_mem_P (hf : f ∈ FP) + (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) + (hrlog : r =O fun n => Nat.log 2 n) : + accLang V f r Q ∈ P := by + have hlen : (fun z : List Bool => + List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by + have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) + simpa [Function.comp] using this + exact forall_unary_mem_P (accInner_mem_P V f r Q hf hr) hlen + +/-- What one iteration looks at, on a well-formed input. -/ +theorem accView_pair + (hfspec : ∀ x rr : List Bool, + f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) + {x w : List Bool} {c : ℕ} (hc : c < 2 ^ r x.length) + (hw : w.length = 2 ^ r x.length * Q) + (hQ : ∀ rr : List Bool, (V.positions x rr).length ≤ Q) : + accView f r Q (pair (pair x w) (List.replicate c true)) + = pair (pair x (BitString.toList (PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩))) + (V.tableOf (r x.length) Q x w + (PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩)) := by + set ρ := PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩ with hρ + have hX : accX (pair (pair x w) (List.replicate c true)) = x := by + rw [accX, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + have hW : accW (pair (pair x w) (List.replicate c true)) = w := by + rw [accW, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + have hC : (Cobham.sndBlock (pair (pair x w) (List.replicate c true))).length = c := by + rw [Cobham.sndBlock_pair, List.length_replicate] + have hcoin : accCoin r (pair (pair x w) (List.replicate c true)) = BitString.toList ρ := by + rw [accCoin, hX, hC, coinStr_eq hc, hρ, toList_coinOfIndex] + have hidx : PCPVerifier.coinIndex ρ = c := coinIndex_coinOfIndex _ + have hlen : (posCount (f (pair x (BitString.toList ρ)))).length + = (V.positions x (BitString.toList ρ)).length := by + rw [hfspec, posCount_eq, List.length_replicate] + have hfit : PCPVerifier.coinIndex ρ * Q + + (V.positions x (BitString.toList ρ)).length ≤ w.length := by + rw [hidx, hw] + have h1 : c + 1 ≤ 2 ^ r x.length := hc + have h2 : (V.positions x (BitString.toList ρ)).length ≤ Q := hQ _ + calc c * Q + (V.positions x (BitString.toList ρ)).length + ≤ c * Q + Q := by omega + _ = (c + 1) * Q := by ring + _ ≤ 2 ^ r x.length * Q := Nat.mul_le_mul_right _ h1 + rw [accView, hX, hW, hC, hcoin, hlen, ← hidx, ← tableOf_eq_wBlock V _ _ _ _ _ hfit] + +/-- **Acceptance on every coin string.** -/ +theorem mem_accLang_iff + (hfspec : ∀ x rr : List Bool, + f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) + {x w : List Bool} (hw : w.length = 2 ^ r x.length * Q) + (hQ : ∀ rr : List Bool, (V.positions x rr).length ≤ Q) : + pair x w ∈ accLang V f r Q + ↔ ∀ ρ : Fin (r x.length) → Bool, + pair (pair x (BitString.toList ρ)) (V.tableOf (r x.length) Q x w ρ) ∈ V.verdict := by + have hfst : Cobham.fstBlock (pair x w) = x := Cobham.fstBlock_pair x w + constructor + · intro h ρ + have hc : PCPVerifier.coinIndex ρ < 2 ^ r x.length := PCPVerifier.coinIndex_lt ρ + have := h (PCPVerifier.coinIndex ρ) (by rwa [hfst]) + rw [accInner, Set.mem_preimage, accView_pair V f r Q hfspec hc hw hQ, + PCPVerifier.coinOfIndex_coinIndex ρ hc] at this + exact this + · intro h c hc + rw [hfst] at hc + rw [accInner, Set.mem_preimage, accView_pair V f r Q hfspec hc hw hQ] + exact h _ + +end Acceptance + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Walk.lean b/Complexitylib/Classes/PCP/Internal/Walk.lean new file mode 100644 index 00000000..fd83ad47 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/Walk.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Mixing +public import Mathlib.Data.Fin.Tuple.Basic + +/-! +# Walks in a regular graph + +Dinur's powering step replaces the edges of a constraint graph by its **walks** +of a fixed length `t`. This module gives walks their combinatorial form — a +starting vertex together with a tuple of `t` edge labels — and connects that +form to the analytic one: summing any function of the walk's endpoint over all +`deg ^ t` walks out of a vertex is `deg ^ t` times the `t`-step walk operator. + +That identity, `sum_walkEnd`, is the bridge between the two views. The powering +construction is defined by quantifying over walk tuples, while every estimate +about it comes from the spectral bound through `Mixing`; `sum_mul_walkEnd` +performs the translation in the form the analysis needs. + +## Main definitions + +- `RegGraph.walkEnd` — the endpoint of the walk from `v` with label tuple `s` + +## Main results + +- `RegGraph.sum_walkEnd` — `∑ s, f (walkEnd v s) = d ^ t * stepIter t f v` +- `RegGraph.sum_mul_walkEnd` — the correlation of `f` at the start and `g` at + the end of a random walk, as a multiple of the operator inner product +- `RegGraph.card_walks` — there are `deg ^ t` walks out of each vertex +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-- The endpoint of the walk that starts at `v` and follows the edge labels +`s 0, s 1, …, s (t-1)` in order. -/ +def walkEnd (G : RegGraph) : ∀ (t : ℕ), G.V → (Fin t → G.D) → G.V + | 0, v, _ => v + | t + 1, v, s => walkEnd G t (G.nbr v (s 0)) (fun j => s j.succ) + +@[simp] theorem walkEnd_zero (v : G.V) (s : Fin 0 → G.D) : G.walkEnd 0 v s = v := by + simp [walkEnd] + +theorem walkEnd_succ (t : ℕ) (v : G.V) (s : Fin (t + 1) → G.D) : + G.walkEnd (t + 1) v s = G.walkEnd t (G.nbr v (s 0)) (fun j => s j.succ) := by + simp [walkEnd] + +theorem walkEnd_cons (t : ℕ) (v : G.V) (i : G.D) (s : Fin t → G.D) : + G.walkEnd (t + 1) v (Fin.cons i s) = G.walkEnd t (G.nbr v i) s := by + rw [walkEnd_succ] + simp + +/-- There are `deg ^ t` walks of length `t` out of a vertex. -/ +theorem card_walks (t : ℕ) : Fintype.card (Fin t → G.D) = G.deg ^ t := by + simp + +/-- **The bridge between walks and the walk operator.** Averaging a function of +the endpoint over all walks of length `t` out of `v` is exactly the `t`-step +operator applied at `v`. -/ +theorem sum_walkEnd (f : G.V → ℝ) (t : ℕ) (v : G.V) : + ∑ s : Fin t → G.D, f (G.walkEnd t v s) = (G.deg : ℝ) ^ t * G.stepIter t f v := by + induction t generalizing v with + | zero => simp + | succ t ih => + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + have hsplit : ∑ s : Fin (t + 1) → G.D, f (G.walkEnd (t + 1) v s) + = ∑ p : G.D × (Fin t → G.D), f (G.walkEnd (t + 1) v (Fin.cons p.1 p.2)) := + (Equiv.sum_comp (Fin.consEquiv fun _ => G.D) + (fun s => f (G.walkEnd (t + 1) v s))).symm + calc ∑ s : Fin (t + 1) → G.D, f (G.walkEnd (t + 1) v s) + = ∑ p : G.D × (Fin t → G.D), f (G.walkEnd (t + 1) v (Fin.cons p.1 p.2)) := + hsplit + _ = ∑ i : G.D, ∑ s : Fin t → G.D, f (G.walkEnd t (G.nbr v i) s) := by + rw [Fintype.sum_prod_type] + exact Finset.sum_congr rfl fun i _ => + Finset.sum_congr rfl fun s _ => by rw [walkEnd_cons] + _ = ∑ i : G.D, (G.deg : ℝ) ^ t * G.stepIter t f (G.nbr v i) := by + exact Finset.sum_congr rfl fun i _ => ih (G.nbr v i) + _ = (G.deg : ℝ) ^ t * ∑ i : G.D, G.stepIter t f (G.nbr v i) := by + rw [Finset.mul_sum] + _ = (G.deg : ℝ) ^ (t + 1) * G.stepIter (t + 1) f v := by + rw [stepIter_succ, step] + field_simp + ring + +/-- The walk-form of the correlation between the start and the end of a random +walk: it is `deg ^ t` times the operator inner product, which `mixing_sq` +estimates. -/ +theorem sum_mul_walkEnd (f g : G.V → ℝ) (t : ℕ) : + ∑ v : G.V, ∑ s : Fin t → G.D, f v * g (G.walkEnd t v s) + = (G.deg : ℝ) ^ t * ∑ v : G.V, f v * G.stepIter t g v := by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun v _ => ?_ + rw [← Finset.mul_sum, G.sum_walkEnd g t v] + ring + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/WalkDart.lean b/Complexitylib/Classes/PCP/Internal/WalkDart.lean new file mode 100644 index 00000000..9914a8a9 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/WalkDart.lean @@ -0,0 +1,336 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.WalkPath + +/-! +# Each step of a random walk is a uniform dart + +The counting fact behind every first-moment estimate in Dinur's powering +analysis: fix a step index `k < t`; then the map sending a walk `(v, s)` to its +`k`-th dart `(walkAt k, s k)` sends the uniform distribution on walks to the +uniform distribution on darts. Equivalently, summing any function of the `k`-th +dart over all `order · deg ^ t` walks gives `deg ^ (t-1)` times its sum over all +darts — every dart is the `k`-th dart of exactly `deg ^ (t-1)` walks. + +The proof is an induction on `k` that peels the first label off the walk. Two +ingredients do the work: `walkAt_cons`, which says dropping the first label +shifts the trajectory by one, and `sum_nbr_nsmul`, the rotation-map form of +regularity, which reindexes the sum over `(v, i)` as `deg` copies of the sum +over vertices. + +Stated for an arbitrary `AddCommMonoid`, since it is used both to count walks in +`ℕ` and to compute real-valued averages. + +## Main results + +- `RegGraph.walkAt_cons` — dropping the first label shifts the trajectory +- `RegGraph.sum_stepDart` — the `k`-th dart of a uniform walk is a uniform dart +- `RegGraph.sum_stepDart_fixed` — from a fixed start, the `k`-th dart is + described by the `k`-step walk operator +- `RegGraph.card_walks_stepDart_mem` — how many walks have their `k`-th dart in + a given set +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-- Dropping the first label of a walk shifts its trajectory by one step. -/ +theorem walkAt_cons {t : ℕ} (v : G.V) (i : G.D) (s : Fin t → G.D) : + ∀ m : ℕ, G.walkAt (t + 1) v (Fin.cons i s) (m + 1) = G.walkAt t (G.nbr v i) s m := by + intro m + induction m with + | zero => + rw [G.walkAt_succ_of_lt _ _ (Nat.succ_pos t), walkAt_zero, walkAt_zero] + congr 1 + | succ m ih => + rcases Nat.lt_or_ge m t with hlt | hge + · rw [G.walkAt_succ_of_lt _ _ (by omega : m + 1 < t + 1), ih, + G.walkAt_succ_of_lt _ _ hlt] + congr 1 + · rw [G.walkAt_succ_of_ge _ _ (by omega : t + 1 ≤ m + 1), ih, + G.walkAt_succ_of_ge _ _ hge] + +/-- **The `k`-th dart of a uniform walk is a uniform dart.** -/ +theorem sum_stepDart {M : Type*} [AddCommMonoid M] : + ∀ (k t : ℕ) (hk : k < t) (f : G.V × G.D → M), + (∑ v : G.V, ∑ s : Fin t → G.D, f (G.walkAt t v s k, s ⟨k, hk⟩)) + = (G.deg ^ (t - 1)) • ∑ p : G.V × G.D, f p := by + intro k + induction k with + | zero => + intro t hk f + obtain ⟨t', rfl⟩ : ∃ t', t = t' + 1 := ⟨t - 1, by omega⟩ + have hsplit : ∀ v : G.V, ∑ s : Fin (t' + 1) → G.D, f (G.walkAt (t' + 1) v s 0, s ⟨0, hk⟩) + = ∑ p : G.D × (Fin t' → G.D), f (v, p.1) := by + intro v + rw [← Equiv.sum_comp (Fin.consEquiv fun _ => G.D) + (fun s => f (G.walkAt (t' + 1) v s 0, s ⟨0, hk⟩))] + refine Finset.sum_congr rfl fun p _ => ?_ + have h0 : (⟨0, hk⟩ : Fin (t' + 1)) = 0 := rfl + simp only [Fin.consEquiv_apply, h0, Fin.cons_zero, walkAt_zero] + calc ∑ v : G.V, ∑ s : Fin (t' + 1) → G.D, f (G.walkAt (t' + 1) v s 0, s ⟨0, hk⟩) + = ∑ v : G.V, ∑ p : G.D × (Fin t' → G.D), f (v, p.1) := + Finset.sum_congr rfl fun v _ => hsplit v + _ = ∑ v : G.V, ∑ i : G.D, ∑ _s : Fin t' → G.D, f (v, i) := by + exact Finset.sum_congr rfl fun v _ => + Fintype.sum_prod_type (fun p : G.D × (Fin t' → G.D) => f (v, p.1)) + _ = ∑ v : G.V, ∑ i : G.D, (G.deg ^ t') • f (v, i) := by + refine Finset.sum_congr rfl fun v _ => Finset.sum_congr rfl fun i _ => ?_ + rw [Finset.sum_const, Finset.card_univ, G.card_walks t'] + _ = (G.deg ^ t') • ∑ p : G.V × G.D, f p := by + rw [Fintype.sum_prod_type (fun p : G.V × G.D => f p)] + simp only [Finset.sum_nsmul] + _ = (G.deg ^ (t' + 1 - 1)) • ∑ p : G.V × G.D, f p := by norm_num + | succ k ih => + intro t hk f + obtain ⟨t', rfl⟩ : ∃ t', t = t' + 1 := ⟨t - 1, by omega⟩ + have hkt : k < t' := by omega + have ht' : 1 ≤ t' := by omega + have hsplit : ∀ v : G.V, + (∑ s : Fin (t' + 1) → G.D, + f (G.walkAt (t' + 1) v s (k + 1), s ⟨k + 1, hk⟩)) + = ∑ i : G.D, ∑ s : Fin t' → G.D, + f (G.walkAt t' (G.nbr v i) s k, s ⟨k, hkt⟩) := by + intro v + rw [← Equiv.sum_comp (Fin.consEquiv fun _ => G.D) + (fun s => f (G.walkAt (t' + 1) v s (k + 1), s ⟨k + 1, hk⟩))] + rw [Fintype.sum_prod_type] + refine Finset.sum_congr rfl fun i _ => Finset.sum_congr rfl fun s _ => ?_ + have hidx : (Fin.cons (α := fun _ => G.D) i s) ⟨k + 1, hk⟩ = s ⟨k, hkt⟩ := by + rw [show (⟨k + 1, hk⟩ : Fin (t' + 1)) = Fin.succ ⟨k, hkt⟩ from rfl, Fin.cons_succ] + show f (G.walkAt (t' + 1) v (Fin.cons i s) (k + 1), + (Fin.cons (α := fun _ => G.D) i s) ⟨k + 1, hk⟩) = _ + rw [hidx, G.walkAt_cons v i s k] + calc ∑ v : G.V, ∑ s : Fin (t' + 1) → G.D, + f (G.walkAt (t' + 1) v s (k + 1), s ⟨k + 1, hk⟩) + = ∑ v : G.V, ∑ i : G.D, ∑ s : Fin t' → G.D, + f (G.walkAt t' (G.nbr v i) s k, s ⟨k, hkt⟩) := + Finset.sum_congr rfl fun v _ => hsplit v + _ = G.deg • ∑ u : G.V, ∑ s : Fin t' → G.D, + f (G.walkAt t' u s k, s ⟨k, hkt⟩) := + G.sum_nbr_nsmul (fun u => ∑ s : Fin t' → G.D, f (G.walkAt t' u s k, s ⟨k, hkt⟩)) + _ = G.deg • ((G.deg ^ (t' - 1)) • ∑ p : G.V × G.D, f p) := by + rw [ih t' hkt f] + _ = (G.deg ^ (t' + 1 - 1)) • ∑ p : G.V × G.D, f p := by + rw [← mul_nsmul' (∑ p : G.V × G.D, f p) G.deg (G.deg ^ (t' - 1))] + congr 1 + rw [← pow_succ'] + congr 1 + omega + +/-- Summing over label tuples splits into the first label and the rest. -/ +theorem sum_cons_split {M : Type*} [AddCommMonoid M] (m : ℕ) (F : (Fin (m + 1) → G.D) → M) : + (∑ r : Fin (m + 1) → G.D, F r) + = ∑ i : G.D, ∑ r : Fin m → G.D, F (Fin.cons i r) := by + rw [← Equiv.sum_comp (Fin.consEquiv fun _ => G.D) F] + exact Fintype.sum_prod_type (fun p : G.D × (Fin m → G.D) => F (Fin.cons p.1 p.2)) + +/-- **The `k`-th dart of a walk out of a *fixed* start.** Unlike `sum_stepDart`, +where the start is also averaged and the dart comes out uniform, here the dart's +vertex is distributed as the `k`-step walk from `x`, which the walk operator +describes exactly. This is what turns a correlation between two steps of a walk +into an operator inner product, where `Mixing` can bound it. -/ +theorem sum_stepDart_fixed (h : G.V → G.D → ℝ) : + ∀ (k m : ℕ) (hk : k < m) (x : G.V), + (∑ r : Fin m → G.D, h (G.walkAt m x r k) (r ⟨k, hk⟩)) + = (G.deg : ℝ) ^ (m - 1) * ∑ a : G.D, G.stepIter k (fun y => h y a) x := by + intro k + induction k with + | zero => + intro m hk x + obtain ⟨m', rfl⟩ : ∃ m', m = m' + 1 := ⟨m - 1, by omega⟩ + have hsplit : (∑ r : Fin (m' + 1) → G.D, h (G.walkAt (m' + 1) x r 0) (r ⟨0, hk⟩)) + = ∑ a : G.D, ∑ _r : Fin m' → G.D, h x a := by + rw [G.sum_cons_split m' (fun r => h (G.walkAt (m' + 1) x r 0) (r ⟨0, hk⟩))] + refine Finset.sum_congr rfl fun a _ => ?_ + refine Finset.sum_congr rfl fun r _ => ?_ + have h0 : (⟨0, hk⟩ : Fin (m' + 1)) = 0 := rfl + rw [h0, Fin.cons_zero, walkAt_zero] + rw [hsplit] + have hcard : ∀ a : G.D, (∑ _r : Fin m' → G.D, h x a) = (G.deg : ℝ) ^ m' * h x a := by + intro a + rw [Finset.sum_const, Finset.card_univ, G.card_walks m', nsmul_eq_mul] + push_cast + ring + rw [Finset.sum_congr rfl fun a _ => hcard a, ← Finset.mul_sum] + simp + | succ k ih => + intro m hk x + obtain ⟨m', rfl⟩ : ∃ m', m = m' + 1 := ⟨m - 1, by omega⟩ + have hkm : k < m' := by omega + have hm1 : 1 ≤ m' := by omega + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + have hsplit : (∑ r : Fin (m' + 1) → G.D, + h (G.walkAt (m' + 1) x r (k + 1)) (r ⟨k + 1, hk⟩)) + = ∑ i : G.D, ∑ r : Fin m' → G.D, + h (G.walkAt m' (G.nbr x i) r k) (r ⟨k, hkm⟩) := by + rw [G.sum_cons_split m' (fun r => h (G.walkAt (m' + 1) x r (k + 1)) (r ⟨k + 1, hk⟩))] + refine Finset.sum_congr rfl fun i _ => ?_ + refine Finset.sum_congr rfl fun r _ => ?_ + have hidx : (Fin.cons (α := fun _ => G.D) i r) ⟨k + 1, hk⟩ = r ⟨k, hkm⟩ := by + rw [show (⟨k + 1, hk⟩ : Fin (m' + 1)) = Fin.succ ⟨k, hkm⟩ from rfl, Fin.cons_succ] + rw [hidx, G.walkAt_cons x i r k] + rw [hsplit] + have hstep : ∀ i : G.D, (∑ r : Fin m' → G.D, + h (G.walkAt m' (G.nbr x i) r k) (r ⟨k, hkm⟩)) + = (G.deg : ℝ) ^ (m' - 1) * ∑ a : G.D, G.stepIter k (fun y => h y a) (G.nbr x i) := + fun i => ih m' hkm (G.nbr x i) + rw [Finset.sum_congr rfl fun i _ => hstep i, ← Finset.mul_sum] + have hswap : (∑ i : G.D, ∑ a : G.D, G.stepIter k (fun y => h y a) (G.nbr x i)) + = ∑ a : G.D, ∑ i : G.D, G.stepIter k (fun y => h y a) (G.nbr x i) := + Finset.sum_comm + rw [hswap] + have hnbr : ∀ a : G.D, (∑ i : G.D, G.stepIter k (fun y => h y a) (G.nbr x i)) + = (G.deg : ℝ) * G.stepIter (k + 1) (fun y => h y a) x := by + intro a + rw [stepIter_succ, step] + field_simp + rw [Finset.sum_congr rfl fun a _ => hnbr a, ← Finset.mul_sum, ← mul_assoc] + congr 1 + rw [← pow_succ] + congr 1 + omega + +/-- **Two darts of a walk out of a fixed start.** The correlation between what +happens at step `k` and at step `l > k` is an operator expression: the walk +reaches step `k`, the constraint there is weighted, and the remaining `l-k-1` +steps are another application of the walk operator. Feeding this to `Mixing` is +how the second moment of the number of faulty steps gets bounded. -/ +theorem sum_two_darts_fixed (h₁ h₂ : G.V → G.D → ℝ) : + ∀ (k l m : ℕ) (hkl : k < l) (hl : l < m) (x : G.V), + (∑ r : Fin m → G.D, h₁ (G.walkAt m x r k) (r ⟨k, by omega⟩) + * h₂ (G.walkAt m x r l) (r ⟨l, by omega⟩)) + = (G.deg : ℝ) ^ (m - 2) * ∑ a : G.D, ∑ b : G.D, + G.stepIter k + (fun y => h₁ y a * G.stepIter (l - k - 1) (fun z => h₂ z b) (G.nbr y a)) x := by + intro k + induction k with + | zero => + intro l m hkl hl x + obtain ⟨m', rfl⟩ : ∃ m', m = m' + 1 := ⟨m - 1, by omega⟩ + obtain ⟨l', rfl⟩ : ∃ l', l = l' + 1 := ⟨l - 1, by omega⟩ + have hl' : l' < m' := by omega + have hsplit : (∑ r : Fin (m' + 1) → G.D, + h₁ (G.walkAt (m' + 1) x r 0) (r ⟨0, by omega⟩) + * h₂ (G.walkAt (m' + 1) x r (l' + 1)) (r ⟨l' + 1, by omega⟩)) + = ∑ a : G.D, ∑ r : Fin m' → G.D, + h₁ x a * h₂ (G.walkAt m' (G.nbr x a) r l') (r ⟨l', hl'⟩) := by + rw [G.sum_cons_split m' (fun r => h₁ (G.walkAt (m' + 1) x r 0) (r ⟨0, by omega⟩) + * h₂ (G.walkAt (m' + 1) x r (l' + 1)) (r ⟨l' + 1, by omega⟩))] + refine Finset.sum_congr rfl fun a _ => ?_ + refine Finset.sum_congr rfl fun r _ => ?_ + have h0 : (⟨0, by omega⟩ : Fin (m' + 1)) = 0 := rfl + have hidx : (Fin.cons (α := fun _ => G.D) a r) ⟨l' + 1, by omega⟩ = r ⟨l', hl'⟩ := by + rw [show (⟨l' + 1, by omega⟩ : Fin (m' + 1)) = Fin.succ ⟨l', hl'⟩ from rfl, + Fin.cons_succ] + rw [h0, Fin.cons_zero, walkAt_zero, hidx, G.walkAt_cons x a r l'] + rw [hsplit] + have hinner : ∀ a : G.D, (∑ r : Fin m' → G.D, + h₁ x a * h₂ (G.walkAt m' (G.nbr x a) r l') (r ⟨l', hl'⟩)) + = h₁ x a * ((G.deg : ℝ) ^ (m' - 1) + * ∑ b : G.D, G.stepIter l' (fun z => h₂ z b) (G.nbr x a)) := by + intro a + rw [← Finset.mul_sum, G.sum_stepDart_fixed h₂ l' m' hl' (G.nbr x a)] + rw [Finset.sum_congr rfl fun a _ => hinner a] + have hpow : m' + 1 - 2 = m' - 1 := by omega + rw [hpow, Finset.mul_sum] + refine Finset.sum_congr rfl fun a _ => ?_ + have hsub : l' + 1 - 0 - 1 = l' := by omega + simp only [stepIter_zero, hsub, ← Finset.mul_sum] + ring + | succ k ih => + intro l m hkl hl x + obtain ⟨m', rfl⟩ : ∃ m', m = m' + 1 := ⟨m - 1, by omega⟩ + obtain ⟨l', rfl⟩ : ∃ l', l = l' + 1 := ⟨l - 1, by omega⟩ + have hkl' : k < l' := by omega + have hl' : l' < m' := by omega + have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + have hsplit : (∑ r : Fin (m' + 1) → G.D, + h₁ (G.walkAt (m' + 1) x r (k + 1)) (r ⟨k + 1, by omega⟩) + * h₂ (G.walkAt (m' + 1) x r (l' + 1)) (r ⟨l' + 1, by omega⟩)) + = ∑ i : G.D, ∑ r : Fin m' → G.D, + h₁ (G.walkAt m' (G.nbr x i) r k) (r ⟨k, by omega⟩) + * h₂ (G.walkAt m' (G.nbr x i) r l') (r ⟨l', hl'⟩) := by + rw [G.sum_cons_split m' (fun r => h₁ (G.walkAt (m' + 1) x r (k + 1)) (r ⟨k + 1, by omega⟩) + * h₂ (G.walkAt (m' + 1) x r (l' + 1)) (r ⟨l' + 1, by omega⟩))] + refine Finset.sum_congr rfl fun i _ => ?_ + refine Finset.sum_congr rfl fun r _ => ?_ + have hk1 : (Fin.cons (α := fun _ => G.D) i r) ⟨k + 1, by omega⟩ = r ⟨k, by omega⟩ := by + rw [show (⟨k + 1, by omega⟩ : Fin (m' + 1)) = Fin.succ ⟨k, by omega⟩ from rfl, + Fin.cons_succ] + have hl1 : (Fin.cons (α := fun _ => G.D) i r) ⟨l' + 1, by omega⟩ = r ⟨l', hl'⟩ := by + rw [show (⟨l' + 1, by omega⟩ : Fin (m' + 1)) = Fin.succ ⟨l', hl'⟩ from rfl, + Fin.cons_succ] + rw [hk1, hl1, G.walkAt_cons x i r k, G.walkAt_cons x i r l'] + rw [hsplit] + have hIH : ∀ i : G.D, (∑ r : Fin m' → G.D, + h₁ (G.walkAt m' (G.nbr x i) r k) (r ⟨k, by omega⟩) + * h₂ (G.walkAt m' (G.nbr x i) r l') (r ⟨l', hl'⟩)) + = (G.deg : ℝ) ^ (m' - 2) * ∑ a : G.D, ∑ b : G.D, + G.stepIter k + (fun y => h₁ y a * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) + (G.nbr x i) := + fun i => ih l' m' hkl' hl' (G.nbr x i) + rw [Finset.sum_congr rfl fun i _ => hIH i, ← Finset.mul_sum] + have hswap : ∀ i : G.D, (∑ a : G.D, ∑ b : G.D, + G.stepIter k (fun y => h₁ y a + * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i)) + = ∑ a : G.D, ∑ b : G.D, + G.stepIter k (fun y => h₁ y a + * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i) := fun _ => rfl + have hcomm : (∑ i : G.D, ∑ a : G.D, ∑ b : G.D, + G.stepIter k (fun y => h₁ y a + * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i)) + = ∑ a : G.D, ∑ b : G.D, ∑ i : G.D, + G.stepIter k (fun y => h₁ y a + * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i) := by + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun a _ => ?_ + rw [Finset.sum_comm] + rw [hcomm] + have hstep : ∀ a b : G.D, (∑ i : G.D, + G.stepIter k (fun y => h₁ y a + * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i)) + = (G.deg : ℝ) * G.stepIter (k + 1) (fun y => h₁ y a + * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) x := by + intro a b + rw [stepIter_succ, step] + field_simp + rw [Finset.sum_congr rfl fun a _ => Finset.sum_congr rfl fun b _ => hstep a b] + have hsub : l' + 1 - (k + 1) - 1 = l' - k - 1 := by omega + simp only [hsub] + have hpow : (G.deg : ℝ) ^ (m' + 1 - 2) = (G.deg : ℝ) ^ (m' - 2) * (G.deg : ℝ) := by + rw [← pow_succ] + congr 1 + omega + rw [hpow] + simp only [← Finset.mul_sum] + ring + +/-- The number of walks of length `t` whose `k`-th dart lies in `S`. -/ +theorem card_walks_stepDart_mem {t : ℕ} {k : ℕ} (hk : k < t) (S : Finset (G.V × G.D)) : + ∑ v : G.V, (Finset.univ.filter fun s : Fin t → G.D => + (G.walkAt t v s k, s ⟨k, hk⟩) ∈ S).card + = G.deg ^ (t - 1) * S.card := by + have hind : ∀ v : G.V, (Finset.univ.filter fun s : Fin t → G.D => + (G.walkAt t v s k, s ⟨k, hk⟩) ∈ S).card + = ∑ s : Fin t → G.D, (if (G.walkAt t v s k, s ⟨k, hk⟩) ∈ S then 1 else 0) := by + intro v + rw [Finset.card_filter] + rw [Finset.sum_congr rfl fun v _ => hind v] + rw [G.sum_stepDart k t hk (fun p => if p ∈ S then 1 else 0)] + rw [← Finset.card_filter (fun p => p ∈ S) Finset.univ] + simp [smul_eq_mul] + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/WalkPath.lean b/Complexitylib/Classes/PCP/Internal/WalkPath.lean new file mode 100644 index 00000000..03a91909 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/WalkPath.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.Walk + +/-! +# Trajectories of walks, and self-loops + +`Walk` gives the *endpoint* of a walk, which is all the spectral estimates +need. Dinur's powering step also needs the walk's whole **trajectory**: the +constraint attached to a length-`t` walk talks about the graph constraints on +each intermediate edge, and about what the two endpoints of the walk claim the +intermediate vertices are labelled. + +This module adds the trajectory `walkAt`, indexed by `ℕ` and constant once the +walk is exhausted, and identifies its final position with `walkEnd`. The bridge +runs through `walkEnd_snoc`: extending a walk by one label at the *end* takes +one more step from its endpoint, whereas `walkEnd` recurses on the *first* +label. + +It also introduces `Loops`, a choice of self-loop at each vertex. Dinur's +construction needs these to pad a short walk out to a fixed length without +moving: a vertex within distance `k ≤ h` of `v` is the endpoint of a length-`h` +walk from `v` that follows `k` real steps and then stays put. + +## Main definitions + +- `RegGraph.walkAt` — the position of the walk after `k` steps (`k > t` stays) +- `RegGraph.Loops` — a self-loop at every vertex +- `RegGraph.Loops.padWalk` — a short walk padded out to a fixed length + +## Main results + +- `RegGraph.walkEnd_snoc` — appending a label takes one further step +- `RegGraph.walkAt_eq_walkEnd_prefix`, `RegGraph.walkAt_self_eq_walkEnd` +- `RegGraph.walkAt_of_le` — the trajectory is constant past its length +- `RegGraph.Loops.nbr_loop` — a loop label does not move +- `RegGraph.Loops.walkEnd_padWalk` — a padded walk of length `h` ends at the + `k`-th vertex of the walk it pads, so every vertex within distance `h` is + named by some length-`h` walk +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-! ### Extending a walk at its end -/ + +theorem walkEnd_snoc : ∀ (t : ℕ) (v : G.V) (s : Fin t → G.D) (i : G.D), + G.walkEnd (t + 1) v (Fin.snoc s i) = G.nbr (G.walkEnd t v s) i := by + intro t + induction t with + | zero => + intro v s i + have h0 : (0 : Fin 1) = Fin.last 0 := rfl + rw [walkEnd_succ, h0, Fin.snoc_last] + simp + | succ t ih => + intro v s i + have hcs : (Fin.snoc s i : Fin (t + 2) → G.D) + = Fin.cons (s 0) (Fin.snoc (α := fun _ => G.D) (fun j => s j.succ) i) := by + rw [Fin.cons_snoc_eq_snoc_cons] + congr 1 + exact (Fin.cons_self_tail s).symm + rw [hcs, walkEnd_cons, ih, walkEnd_succ] + +/-! ### The trajectory -/ + +/-- The position of the walk `(v, s)` after `k` steps. Once the label tuple is +exhausted the walk stays where it is, so this is defined for every `k : ℕ`. -/ +def walkAt (G : RegGraph) (t : ℕ) (v : G.V) (s : Fin t → G.D) : ℕ → G.V + | 0 => v + | k + 1 => if h : k < t then G.nbr (walkAt G t v s k) (s ⟨k, h⟩) else walkAt G t v s k + +@[simp] theorem walkAt_zero (t : ℕ) (v : G.V) (s : Fin t → G.D) : + G.walkAt t v s 0 = v := rfl + +theorem walkAt_succ_of_lt {t : ℕ} (v : G.V) (s : Fin t → G.D) {k : ℕ} (h : k < t) : + G.walkAt t v s (k + 1) = G.nbr (G.walkAt t v s k) (s ⟨k, h⟩) := by + rw [walkAt] + simp [h] + +theorem walkAt_succ_of_ge {t : ℕ} (v : G.V) (s : Fin t → G.D) {k : ℕ} (h : t ≤ k) : + G.walkAt t v s (k + 1) = G.walkAt t v s k := by + rw [walkAt] + simp [Nat.not_lt.mpr h] + +/-- Past its length the trajectory is constant. -/ +theorem walkAt_of_le {t : ℕ} (v : G.V) (s : Fin t → G.D) : + ∀ {k : ℕ}, t ≤ k → G.walkAt t v s k = G.walkAt t v s t := by + intro k + induction k with + | zero => + intro h + have ht : t = 0 := Nat.le_zero.mp h + subst ht + rfl + | succ k ih => + intro h + rcases Nat.lt_or_ge t (k + 1) with hlt | hge + · have htk : t ≤ k := by omega + rw [G.walkAt_succ_of_ge v s htk, ih htk] + · have ht : t = k + 1 := by omega + subst ht + rfl + +/-- The trajectory after `k ≤ t` steps is the endpoint of the length-`k` prefix +of the walk. -/ +theorem walkAt_eq_walkEnd_prefix {t : ℕ} (v : G.V) (s : Fin t → G.D) : + ∀ (k : ℕ) (hk : k ≤ t), + G.walkAt t v s k = G.walkEnd k v (fun j : Fin k => s (Fin.castLE hk j)) := by + intro k + induction k with + | zero => intro _; simp + | succ k ih => + intro hk + have hkt : k < t := by omega + have hk' : k ≤ t := le_of_lt hkt + have hsnoc : (fun j : Fin (k + 1) => s (Fin.castLE hk j)) + = Fin.snoc (α := fun _ => G.D) + (fun j : Fin k => s (Fin.castLE hk' j)) (s ⟨k, hkt⟩) := by + funext j + refine Fin.lastCases ?_ ?_ j + · rw [Fin.snoc_last] + congr 1 + · intro j' + rw [Fin.snoc_castSucc] + congr 1 + rw [G.walkAt_succ_of_lt v s hkt, ih hk', hsnoc, G.walkEnd_snoc] + +/-- The trajectory ends where `walkEnd` says it does. -/ +theorem walkAt_self_eq_walkEnd {t : ℕ} (v : G.V) (s : Fin t → G.D) : + G.walkAt t v s t = G.walkEnd t v s := by + rw [G.walkAt_eq_walkEnd_prefix v s t le_rfl] + congr 1 + +/-! ### Self-loops -/ + +/-- A choice of self-loop at every vertex: an edge label that fixes the dart, +hence does not move. Dinur's construction needs these to pad short walks out to +a fixed length. -/ +structure Loops (G : RegGraph) where + /-- The self-loop label at each vertex. -/ + loop : G.V → G.D + /-- The chosen dart is fixed by reversal, so it is a self-loop. -/ + rot_loop : ∀ v, G.rot (v, loop v) = (v, loop v) + +namespace Loops + +variable {G} (L : G.Loops) + +/-- Following a loop label does not move. -/ +@[simp] theorem nbr_loop (v : G.V) : G.nbr v (L.loop v) = v := by + rw [nbr, L.rot_loop v] + +/-- The length-`h` label tuple that follows `s` for `k` steps and then stays +put, taking self-loops. This is how a vertex within distance `k ≤ h` of `v` is +named by a walk of length exactly `h` out of `v`. -/ +def padWalk {t : ℕ} (v : G.V) (s : Fin t → G.D) (k h : ℕ) : Fin h → G.D := + fun j => if hj : j.val < min k t then s ⟨j.val, lt_of_lt_of_le hj (min_le_right k t)⟩ + else L.loop (G.walkAt t v s k) + +theorem padWalk_of_lt {t : ℕ} (v : G.V) (s : Fin t → G.D) {k h : ℕ} (j : Fin h) + (hj : j.val < min k t) : + L.padWalk v s k h j = s ⟨j.val, lt_of_lt_of_le hj (min_le_right k t)⟩ := + dif_pos hj + +theorem padWalk_of_ge {t : ℕ} (v : G.V) (s : Fin t → G.D) {k h : ℕ} (j : Fin h) + (hj : ¬ j.val < min k t) : + L.padWalk v s k h j = L.loop (G.walkAt t v s k) := + dif_neg hj + +/-- Below `k` the padded walk follows the original. -/ +theorem walkAt_padWalk_of_le {t : ℕ} (v : G.V) (s : Fin t → G.D) {k h : ℕ} + (hkh : k ≤ h) (hkt : k ≤ t) : + ∀ m : ℕ, m ≤ k → G.walkAt h v (L.padWalk v s k h) m = G.walkAt t v s m := by + intro m + induction m with + | zero => intro _; simp + | succ m ih => + intro hm + have hmh : m < h := by omega + have hmt : m < t := by omega + have hmin : m < min k t := by omega + rw [G.walkAt_succ_of_lt _ _ hmh, G.walkAt_succ_of_lt _ _ hmt, ih (by omega)] + congr 1 + exact L.padWalk_of_lt v s ⟨m, hmh⟩ hmin + +/-- At and past `k` the padded walk stays at the `k`-th vertex. -/ +theorem walkAt_padWalk_of_ge {t : ℕ} (v : G.V) (s : Fin t → G.D) {k h : ℕ} + (hkh : k ≤ h) (hkt : k ≤ t) : + ∀ m : ℕ, k ≤ m → m ≤ h → G.walkAt h v (L.padWalk v s k h) m = G.walkAt t v s k := by + intro m + induction m with + | zero => + intro hk _ + have : k = 0 := by omega + subst this + simp + | succ m ih => + intro hkm hmh + rcases Nat.lt_or_ge m k with hlt | hge + · have hk : k = m + 1 := by omega + subst hk + exact L.walkAt_padWalk_of_le v s hkh hkt (m + 1) le_rfl + · have hmh' : m < h := by omega + rw [G.walkAt_succ_of_lt _ _ hmh', ih hge (by omega)] + have hmin : ¬ (m < min k t) := by omega + rw [L.padWalk_of_ge v s ⟨m, hmh'⟩ hmin, L.nbr_loop] + +/-- **The naming property.** A padded walk of length `h` ends exactly at the +`k`-th vertex of the original walk. -/ +theorem walkEnd_padWalk {t : ℕ} (v : G.V) (s : Fin t → G.D) {k h : ℕ} + (hkh : k ≤ h) (hkt : k ≤ t) : + G.walkEnd h v (L.padWalk v s k h) = G.walkAt t v s k := by + rw [← G.walkAt_self_eq_walkEnd] + exact L.walkAt_padWalk_of_ge v s hkh hkt h hkh le_rfl + +end Loops + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/WalkSplit.lean b/Complexitylib/Classes/PCP/Internal/WalkSplit.lean new file mode 100644 index 00000000..a00c6ad7 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/WalkSplit.lean @@ -0,0 +1,325 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.KilledWalk + +/-! +# Splitting a walk at a step + +The surgery behind the crossing decomposition: a walk of length `ℓ` and a +position `i < ℓ` split it into a prefix of length `i`, the label crossed at `i`, +and a suffix of length `ℓ - (i+1)`; gluing puts them back. + +Dinur's first-moment count is organised around this. Conditioned on a killed +walk crossing a given dart at step `i`, what remains is exactly a free prefix +and a free suffix — and because the killed law makes their *lengths* +independent too, the count factorises into two copies of the plurality bound. + +## Main definitions + +- `RegGraph.segPre`, `RegGraph.segSuf` — the two pieces of a split walk +- `RegGraph.segGlue` — gluing them back with a crossing label + +## Main results + +- `RegGraph.segPre_segGlue`, `RegGraph.segMid_segGlue`, `RegGraph.segSuf_segGlue` + — gluing then splitting is the identity +- `RegGraph.segGlue_split` — splitting then gluing is the identity +- `RegGraph.walkAt_segSuf`, `RegGraph.revWalk_segSuf` — the suffix walk tracks + the original, and reversing it gives the reversed walk's prefix +- `RegGraph.card_crossing_eq` — the walks crossing a dart at a step, counted as + independent prefix and suffix factors +- `RegGraph.card_label_fibre` — labels grouped by their effective walk +- `RegGraph.card_label_crossing` — the two combined: crossing labels counted as + prefix times suffix times fibre weight +- `RegGraph.walkAt_preWalk` — a killed walk's crossings are the underlying + fixed-length walk's crossings +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G : RegGraph) + +/-- The first `i` steps of a walk. -/ +def segPre {ℓ : ℕ} (W : Fin ℓ → G.D) {i : ℕ} (hi : i ≤ ℓ) : Fin i → G.D := + G.preWalk W hi + +/-- The steps of a walk after position `i`. -/ +def segSuf {ℓ : ℕ} (W : Fin ℓ → G.D) (i : ℕ) : Fin (ℓ - (i + 1)) → G.D := + fun k => W ⟨i + 1 + k.val, by have := k.isLt; omega⟩ + +/-- Glue a prefix, a crossing label and a suffix into one walk. -/ +def segGlue {ℓ i : ℕ} (p : Fin i → G.D) (d : G.D) (s : Fin (ℓ - (i + 1)) → G.D) : + Fin ℓ → G.D := + fun k => + if hk : k.val < i then p ⟨k.val, hk⟩ + else if hk2 : k.val = i then d + else s ⟨k.val - (i + 1), by have := k.isLt; omega⟩ + +@[simp] theorem segPre_segGlue {ℓ i : ℕ} (hi : i ≤ ℓ) (p : Fin i → G.D) (d : G.D) + (s : Fin (ℓ - (i + 1)) → G.D) : + G.segPre (G.segGlue p d s) hi = p := by + funext k + simp [segPre, preWalk, segGlue, k.isLt] + +@[simp] theorem segMid_segGlue {ℓ i : ℕ} (hi : i < ℓ) (p : Fin i → G.D) (d : G.D) + (s : Fin (ℓ - (i + 1)) → G.D) : + G.segGlue p d s ⟨i, hi⟩ = d := by + simp [segGlue] + +@[simp] theorem segSuf_segGlue {ℓ i : ℕ} (p : Fin i → G.D) (d : G.D) + (s : Fin (ℓ - (i + 1)) → G.D) : + G.segSuf (G.segGlue p d s) i = s := by + funext k + have hk := k.isLt + have h1 : ¬ (i + 1 + k.val < i) := by omega + have h2 : ¬ (i + 1 + k.val = i) := by omega + simp only [segSuf, segGlue, dif_neg h1, dif_neg h2] + congr 1 + have : i + 1 + k.val - (i + 1) = k.val := by omega + exact Fin.ext this + +/-- Splitting a walk and gluing it back returns the walk. -/ +theorem segGlue_split {ℓ i : ℕ} (hi : i < ℓ) (W : Fin ℓ → G.D) : + G.segGlue (G.segPre W (le_of_lt hi)) (W ⟨i, hi⟩) (G.segSuf W i) = W := by + funext k + rcases lt_trichotomy k.val i with hk | hk | hk + · simp [segGlue, segPre, preWalk, hk] + · have hkey : k = ⟨i, hi⟩ := Fin.ext hk + subst hkey + simp [segGlue] + · have h1 : ¬ (k.val < i) := by omega + have h2 : ¬ (k.val = i) := by omega + simp only [segGlue, dif_neg h1, dif_neg h2, segSuf] + congr 1 + have : i + 1 + (k.val - (i + 1)) = k.val := by omega + exact Fin.ext this + +/-- The suffix walk, started at the vertex the original walk reaches at step +`i + 1`, tracks the original walk. -/ +theorem walkAt_segSuf {ℓ : ℕ} (v : G.V) (W : Fin ℓ → G.D) (i : ℕ) : + ∀ m : ℕ, m ≤ ℓ - (i + 1) → + G.walkAt (ℓ - (i + 1)) (G.walkAt ℓ v W (i + 1)) (G.segSuf W i) m + = G.walkAt ℓ v W (i + 1 + m) := by + intro m + induction m with + | zero => intro _; simp + | succ m ih => + intro hm + have hm' : m ≤ ℓ - (i + 1) := by omega + have hmlt : m < ℓ - (i + 1) := by omega + have hilt : i + 1 + m < ℓ := by omega + have hidx : i + 1 + (m + 1) = (i + 1 + m) + 1 := by omega + rw [walkAt, dif_pos hmlt, ih hm', hidx, G.walkAt_succ_of_lt v W hilt] + exact congrArg (G.nbr (G.walkAt ℓ v W (i + 1 + m))) rfl + +/-- **Reversal commutes with splitting.** Reversing the suffix of a walk gives +the prefix of the reversed walk: both are the walk that runs from the far end +back to the crossing point. This is what makes the suffix condition in the +powered constraint the same as a condition on walks out of the dart's head. -/ +theorem revWalk_segSuf {ℓ : ℕ} (v : G.V) (W : Fin ℓ → G.D) {i : ℕ} (hi : i < ℓ) : + G.revWalk (G.walkAt ℓ v W (i + 1)) (G.segSuf W i) + = G.segPre (G.revWalk v W) (show ℓ - (i + 1) ≤ ℓ by omega) := by + funext k + have hk := k.isLt + have hkl : k.val < ℓ := by omega + have hlt : ℓ - (k.val + 1) < ℓ := by omega + have hrev : ((Fin.rev k : Fin (ℓ - (i + 1)))).val = ℓ - (i + 1) - (k.val + 1) := + Fin.val_rev k + have hbound : (Fin.rev k : Fin (ℓ - (i + 1))).val ≤ ℓ - (i + 1) := + le_of_lt (Fin.rev k).isLt + have hpairL : (G.walkAt (ℓ - (i + 1)) (G.walkAt ℓ v W (i + 1)) (G.segSuf W i) + (Fin.rev k).val, G.segSuf W i (Fin.rev k)) + = (G.walkAt ℓ v W (ℓ - (k.val + 1)), W ⟨ℓ - (k.val + 1), hlt⟩) := by + refine Prod.ext ?_ ?_ + · have hidx : i + 1 + (Fin.rev k : Fin (ℓ - (i + 1))).val = ℓ - (k.val + 1) := by + rw [hrev] + omega + rw [G.walkAt_segSuf v W i _ hbound, hidx] + · have hidx : i + 1 + (Fin.rev k : Fin (ℓ - (i + 1))).val = ℓ - (k.val + 1) := by + rw [hrev] + omega + show G.segSuf W i (Fin.rev k) = W ⟨ℓ - (k.val + 1), hlt⟩ + rw [segSuf] + apply congrArg + exact Fin.ext hidx + have hrev2 : ((Fin.rev (⟨k.val, hkl⟩ : Fin ℓ))).val = ℓ - (k.val + 1) := + Fin.val_rev _ + have hpairR : (G.walkAt ℓ v W (Fin.rev (⟨k.val, hkl⟩ : Fin ℓ)).val, + W (Fin.rev (⟨k.val, hkl⟩ : Fin ℓ))) + = (G.walkAt ℓ v W (ℓ - (k.val + 1)), W ⟨ℓ - (k.val + 1), hlt⟩) := by + refine Prod.ext ?_ ?_ + · rw [hrev2] + · exact congrArg W (Fin.ext hrev2) + show G.revWalk (G.walkAt ℓ v W (i + 1)) (G.segSuf W i) k = G.revWalk v W ⟨k.val, hkl⟩ + simp only [revWalk, backLabel] + rw [hpairL, hpairR] + +/-! ### The crossing bijection -/ + +/-- **The crossing decomposition.** The walks of length `ℓ` that cross a given +dart `(a, d)` at step `i` are in bijection with pairs of a walk *out of* `a` of +length `i` — the reversed prefix — and a walk of length `ℓ - (i+1)` — the +suffix. Any conditions imposed on the two pieces therefore contribute +independent factors, which is what makes the first moment factorise. -/ +theorem card_crossing_eq {ℓ i : ℕ} (hi : i < ℓ) (a : G.V) (d : G.D) + (Pre : (Fin i → G.D) → Prop) [DecidablePred Pre] + (Suf : (Fin (ℓ - (i + 1)) → G.D) → Prop) [DecidablePred Suf] : + (Finset.univ.filter fun x : G.V × (Fin ℓ → G.D) => + G.walkAt ℓ x.1 x.2 i = a ∧ x.2 ⟨i, hi⟩ = d + ∧ Pre (G.revWalk x.1 (G.segPre x.2 (le_of_lt hi))) ∧ Suf (G.segSuf x.2 i)).card + = (Finset.univ.filter Pre).card * (Finset.univ.filter Suf).card := by + classical + rw [← Finset.card_product] + refine Finset.card_bij' + (fun x _ => (G.revWalk x.1 (G.segPre x.2 (le_of_lt hi)), G.segSuf x.2 i)) + (fun y _ => (G.walkEnd i a y.1, G.segGlue (G.revWalk a y.1) d y.2)) ?_ ?_ ?_ ?_ + · intro x hx + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx + simp only [Finset.mem_product, Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨hx.2.2.1, hx.2.2.2⟩ + · intro y hy + simp only [Finset.mem_product, Finset.mem_filter, Finset.mem_univ, true_and] at hy + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + have hp : G.segPre (G.segGlue (G.revWalk a y.1) d y.2) (le_of_lt hi) + = G.revWalk a y.1 := G.segPre_segGlue (le_of_lt hi) _ d _ + refine ⟨?_, ?_, ?_, ?_⟩ + · rw [G.walkAt_eq_walkEnd_prefix _ _ i (le_of_lt hi)] + have hpre : (fun j : Fin i => + G.segGlue (G.revWalk a y.1) d y.2 (Fin.castLE (le_of_lt hi) j)) + = G.revWalk a y.1 := hp + rw [hpre] + exact G.walkEnd_revWalk a y.1 + · exact G.segMid_segGlue hi _ d _ + · rw [hp, G.revWalk_revWalk] + exact hy.1 + · rw [G.segSuf_segGlue] + exact hy.2 + · intro x hx + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx + obtain ⟨hwalk, hmid, -, -⟩ := hx + have ha : G.walkEnd i x.1 (G.segPre x.2 (le_of_lt hi)) = a := by + rw [← hwalk, G.walkAt_eq_walkEnd_prefix _ _ i (le_of_lt hi)] + rfl + refine Prod.ext ?_ ?_ + · show G.walkEnd i a (G.revWalk x.1 (G.segPre x.2 (le_of_lt hi))) = x.1 + rw [← ha] + exact G.walkEnd_revWalk x.1 (G.segPre x.2 (le_of_lt hi)) + · show G.segGlue (G.revWalk a (G.revWalk x.1 (G.segPre x.2 (le_of_lt hi)))) d + (G.segSuf x.2 i) = x.2 + rw [← ha, G.revWalk_revWalk, ← hmid] + exact G.segGlue_split hi x.2 + · intro y hy + simp only [Finset.mem_product, Finset.mem_filter, Finset.mem_univ, true_and] at hy + have hp : G.segPre (G.segGlue (G.revWalk a y.1) d y.2) (le_of_lt hi) + = G.revWalk a y.1 := G.segPre_segGlue (le_of_lt hi) _ d _ + refine Prod.ext ?_ ?_ + · show G.revWalk (G.walkEnd i a y.1) + (G.segPre (G.segGlue (G.revWalk a y.1) d y.2) (le_of_lt hi)) = y.1 + rw [hp, G.revWalk_revWalk] + · show G.segSuf (G.segGlue (G.revWalk a y.1) d y.2) i = y.2 + exact G.segSuf_segGlue _ d _ + +/-! ### From labels to walks -/ + +/-- **Labels grouped by their effective walk.** Any condition on the starting +vertex and the effective walk is counted by counting *walks*, each weighted by +the number of labels carrying it. This is the step that turns a statement about +killed-walk labels into one about walks, where the crossing decomposition +applies. -/ +theorem card_label_fibre {T q ℓ : ℕ} (hq : 0 < q) (hℓ : ℓ < T) + (P : G.V × (Fin ℓ → G.D) → Prop) [DecidablePred P] : + (Finset.univ.filter fun z : G.V × ((Fin T → G.D) × (Fin T → Fin q)) => + stopAt z.2.2 = ℓ ∧ P (z.1, G.preWalk z.2.1 (le_of_lt hℓ))).card + = (Finset.univ.filter P).card + * (G.deg ^ (T - ℓ) * ((q - 1) ^ ℓ * q ^ (T - ℓ - 1))) := by + classical + have hmaps : ∀ z ∈ (Finset.univ.filter fun z : G.V × ((Fin T → G.D) × (Fin T → Fin q)) => + stopAt z.2.2 = ℓ ∧ P (z.1, G.preWalk z.2.1 (le_of_lt hℓ))), + (z.1, G.preWalk z.2.1 (le_of_lt hℓ)) ∈ Finset.univ.filter P := by + intro z hz + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hz ⊢ + exact hz.2 + rw [Finset.card_eq_sum_card_fiberwise hmaps] + have hfib : ∀ y ∈ Finset.univ.filter P, + ((Finset.univ.filter fun z : G.V × ((Fin T → G.D) × (Fin T → Fin q)) => + stopAt z.2.2 = ℓ ∧ P (z.1, G.preWalk z.2.1 (le_of_lt hℓ))).filter + fun z => (z.1, G.preWalk z.2.1 (le_of_lt hℓ)) = y).card + = G.deg ^ (T - ℓ) * ((q - 1) ^ ℓ * q ^ (T - ℓ - 1)) := by + intro y hy + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hy + have hset : ((Finset.univ.filter fun z : G.V × ((Fin T → G.D) × (Fin T → Fin q)) => + stopAt z.2.2 = ℓ ∧ P (z.1, G.preWalk z.2.1 (le_of_lt hℓ))).filter + fun z => (z.1, G.preWalk z.2.1 (le_of_lt hℓ)) = y) + = ({y.1} : Finset G.V) ×ˢ + (Finset.univ.filter fun x : (Fin T → G.D) × (Fin T → Fin q) => + G.preWalk x.1 (le_of_lt hℓ) = y.2 ∧ stopAt x.2 = ℓ) := by + ext z + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_product, + Finset.mem_singleton, Prod.ext_iff] + constructor + · rintro ⟨⟨hlen, -⟩, hz1, hz2⟩ + exact ⟨hz1, hz2, hlen⟩ + · rintro ⟨hz1, hz2, hlen⟩ + refine ⟨⟨hlen, ?_⟩, hz1, hz2⟩ + have hpair : (z.1, G.preWalk z.2.1 (le_of_lt hℓ)) = y := Prod.ext hz1 hz2 + rw [hpair] + exact hy + rw [hset, Finset.card_product, Finset.card_singleton, one_mul, + G.card_killed_fibre hq hℓ y.2] + rw [Finset.sum_congr rfl hfib, Finset.sum_const, smul_eq_mul] + +/-- **The crossing count, at the level of labels.** Chaining the two previous +lemmas: the killed-walk labels of effective length `ℓ` whose walk crosses the +dart `(a, d)` at step `i`, subject to any conditions on the reversed prefix and +on the suffix, number + +`(prefix count) * (suffix count) * (fibre weight)`. + +The two conditions never interact — that is the independence the killed law +buys, and the reason the first moment factorises into two plurality bounds. -/ +theorem card_label_crossing {T q ℓ i : ℕ} (hq : 0 < q) (hℓ : ℓ < T) (hi : i < ℓ) + (a : G.V) (d : G.D) + (Pre : (Fin i → G.D) → Prop) [DecidablePred Pre] + (Suf : (Fin (ℓ - (i + 1)) → G.D) → Prop) [DecidablePred Suf] : + (Finset.univ.filter fun z : G.V × ((Fin T → G.D) × (Fin T → Fin q)) => + stopAt z.2.2 = ℓ ∧ + (G.walkAt ℓ z.1 (G.preWalk z.2.1 (le_of_lt hℓ)) i = a + ∧ (G.preWalk z.2.1 (le_of_lt hℓ)) ⟨i, hi⟩ = d + ∧ Pre (G.revWalk z.1 (G.segPre (G.preWalk z.2.1 (le_of_lt hℓ)) (le_of_lt hi))) + ∧ Suf (G.segSuf (G.preWalk z.2.1 (le_of_lt hℓ)) i))).card + = (Finset.univ.filter Pre).card * (Finset.univ.filter Suf).card + * (G.deg ^ (T - ℓ) * ((q - 1) ^ ℓ * q ^ (T - ℓ - 1))) := by + classical + rw [G.card_label_fibre hq hℓ (fun y : G.V × (Fin ℓ → G.D) => + G.walkAt ℓ y.1 y.2 i = a ∧ y.2 ⟨i, hi⟩ = d + ∧ Pre (G.revWalk y.1 (G.segPre y.2 (le_of_lt hi))) + ∧ Suf (G.segSuf y.2 i)), + G.card_crossing_eq hi a d Pre Suf] + +/-- A walk following a prefix of a label sequence agrees with the full walk for +as long as the prefix lasts. This identifies the crossings of a *killed* walk +with those of the underlying fixed-length walk, which is what lets the +correlation bound — stated for fixed length — apply to them. -/ +theorem walkAt_preWalk {T ℓ : ℕ} (h : ℓ ≤ T) (x : G.V) (s : Fin T → G.D) : + ∀ k : ℕ, k ≤ ℓ → G.walkAt ℓ x (G.preWalk s h) k = G.walkAt T x s k := by + intro k + induction k with + | zero => intro _; simp + | succ k ih => + intro hk + have hkl : k < ℓ := by omega + have hkT : k < T := by omega + rw [walkAt, dif_pos hkl, ih (by omega), walkAt, dif_pos hkT] + congr 1 + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ZigZag.lean b/Complexitylib/Classes/PCP/Internal/ZigZag.lean new file mode 100644 index 00000000..14cd8b58 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ZigZag.lean @@ -0,0 +1,914 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.RegularGraph +public import Complexitylib.Classes.PCP.Internal.Mixing +public import Complexitylib.Classes.PCP.Internal.Cheeger + +/-! +# The zig-zag product + +The expander family of `ExpanderExists` is obtained by counting, so nothing +computes it. A verifier, though, has to *build* its constraint graph, so the +`NP ⊆ PCP` direction needs a family some algorithm produces. + +The zig-zag product is the standard route, and it is enough that its *base* +graph be non-constructive: the base is a single graph of constant size, which an +algorithm may carry as a table, while the family itself is built from it by an +explicit recursion. Classically, "there is a machine with this table built in" +is provable without knowing the table. + +A vertex of `G ⓩ H` is a dart of `G` — a vertex of `G` together with one of its +labels — and a step takes three: a step in the small graph `H` on the label, a +step in `G` along the label reached, and a step in `H` on the label arrived at. +Reversing a zig-zag step reverses each of the three and swaps the two `H`-labels, +which is why the rotation map is an involution. + +## Main definitions + +- `Complexity.RegGraph.zigzag` — the product + +## Main results + +- `Complexity.RegGraph.order_zigzag`, `Complexity.RegGraph.deg_zigzag` — its size + and degree +- `Complexity.RegGraph.step_zigzag` — the walk factors as cloud, cross, cloud +- `Complexity.RegGraph.sum_sq_crossStep` — the crossing move is an isometry +- `Complexity.RegGraph.cloudStep_apply` — the cloud move *is* `H`'s own walk +- `Complexity.RegGraph.sum_sq_cloudStep_le` — so it contracts what `H` contracts +- `Complexity.RegGraph.cloudStep_cloudPar` — the cloud move fixes the part + constant along clouds, and `Complexity.RegGraph.sum_cloudPerp` — kills the rest +- `Complexity.RegGraph.ip_cloudStep`, `Complexity.RegGraph.ip_crossStep` — both + moves are self-adjoint +- `Complexity.RegGraph.cloudMean_crossStep_cloudPar` — on the part constant + along clouds, the crossing move is exactly `G`'s own walk +- `Complexity.RegGraph.cloudStep_decomp` — one cloud move splits `f` into its + constant part and a contracted remainder +- `Complexity.RegGraph.sum_mul_step_le_of_spectralBound` — a spectral bound + controls the Rayleigh quotient +- `Complexity.RegGraph.ip_cloudPar_cloudPerp` — the two parts are orthogonal +- `Complexity.RegGraph.ip_two_mul_le` — the weighted arithmetic-geometric bound +- `Complexity.RegGraph.ip_step_zigzag_le` — **the RVW estimate** +- `Complexity.RegGraph.ip_cloudStep_le` — the cloud move is a contraction +- `Complexity.RegGraph.abs_ip_step_zigzag_le` — the RVW estimate, two-sided +- `Complexity.RegGraph.spectralBound_zigzag` — **the spectral bound of the + product** +-/ + +@[expose] public section + +namespace Complexity + +namespace RegGraph + +variable (G H : RegGraph) (e : H.V ≃ G.D) + +/-- One zig-zag step: turn inside the cloud, cross, then turn again. -/ +def zigzagRot : (G.V × G.D) × (H.D × H.D) → (G.V × G.D) × (H.D × H.D) := + fun x => + let p := H.rot (e.symm x.1.2, x.2.1) + let q := G.rot (x.1.1, e p.1) + let r := H.rot (e.symm q.2, x.2.2) + ((q.1, e r.1), (r.2, p.2)) + +theorem zigzagRot_involutive : Function.Involutive (zigzagRot G H e) := by + intro x + obtain ⟨⟨v, i⟩, ⟨a, b⟩⟩ := x + simp only [zigzagRot] + -- the three reversals, innermost first + set p := H.rot (e.symm i, a) with hp + set q := G.rot (v, e p.1) with hq + set r := H.rot (e.symm q.2, b) with hr + have hrr : H.rot (e.symm (e r.1), r.2) = (e.symm q.2, b) := by + rw [Equiv.symm_apply_apply] + have : (r.1, r.2) = r := rfl + rw [this, hr, H.rot_involutive] + have hqq : G.rot (q.1, e (e.symm q.2)) = (v, e p.1) := by + rw [Equiv.apply_symm_apply] + have : (q.1, q.2) = q := rfl + rw [this, hq, G.rot_involutive] + have hpp : H.rot (e.symm (e p.1), p.2) = (e.symm i, a) := by + rw [Equiv.symm_apply_apply] + have : (p.1, p.2) = p := rfl + rw [this, hp, H.rot_involutive] + simp only [hrr, hqq, hpp] + simp [Equiv.apply_symm_apply] + +/-- **The zig-zag product.** Its vertices are the darts of `G` and its degree is +the square of `H`'s. -/ +def zigzag : RegGraph where + V := G.V × G.D + D := H.D × H.D + decEqV := by + haveI := G.decEqV + haveI := G.decEqD + exact inferInstance + decEqD := by + haveI := H.decEqD + exact inferInstance + fintypeV := by + haveI := G.fintypeV + haveI := G.fintypeD + exact inferInstance + fintypeD := by + haveI := H.fintypeD + exact inferInstance + nonemptyD := by + haveI := H.nonemptyD + exact inferInstance + rot := zigzagRot G H e + rot_involutive := zigzagRot_involutive G H e + +@[simp] theorem order_zigzag : (zigzag G H e).order = G.order * G.deg := + @Fintype.card_prod G.V G.D G.fintypeV G.fintypeD + +@[simp] theorem deg_zigzag : (zigzag G H e).deg = H.deg * H.deg := + @Fintype.card_prod H.D H.D H.fintypeD H.fintypeD + +/-! ### The walk, factored -/ + +/-- The move inside a cloud: one step of `H` on the label, the vertex of `G` +held fixed. -/ +noncomputable def cloudStep (f : G.V × G.D → ℝ) : G.V × G.D → ℝ := + fun x => (∑ b : H.D, f (x.1, e (H.rot (e.symm x.2, b)).1)) / (H.deg : ℝ) + +/-- The crossing move: follow the dart of `G` the label names. It is composition +with `G.rot`, an involution of darts, so it merely permutes the vertices of the +product. -/ +def crossStep (f : G.V × G.D → ℝ) : G.V × G.D → ℝ := fun x => f (G.rot x) + +/-- **The zig-zag walk is cloud, then cross, then cloud.** -/ +theorem step_zigzag (f : (zigzag G H e).V → ℝ) (x : (zigzag G H e).V) : + (zigzag G H e).step f x + = cloudStep G H e (crossStep G (cloudStep G H e f)) x := by + have hd : (H.deg : ℝ) ≠ 0 := H.deg_ne_zero + have hdeg : ((zigzag G H e).deg : ℝ) = (H.deg : ℝ) * (H.deg : ℝ) := by + rw [deg_zigzag] + push_cast + ring + have hsum : (∑ d : (zigzag G H e).D, f ((zigzag G H e).nbr x d)) + = ∑ a : H.D, ∑ b : H.D, f ((zigzagRot G H e (x, (a, b))).1) := + Fintype.sum_prod_type (f := fun d : H.D × H.D => f ((zigzagRot G H e (x, d)).1)) + rw [RegGraph.step, hdeg, hsum] + rw [cloudStep] + have hinner : ∀ a : H.D, + ∑ b : H.D, f ((zigzagRot G H e (x, (a, b))).1) + = (H.deg : ℝ) * cloudStep G H e f + (G.rot (x.1, e (H.rot (e.symm x.2, a)).1)) := by + intro a + rw [cloudStep] + field_simp + rfl + rw [Finset.sum_congr rfl fun a _ => hinner a, ← Finset.mul_sum] + show _ = (∑ b : H.D, cloudStep G H e f (G.rot (x.1, e (H.rot (e.symm x.2, b)).1))) + / (H.deg : ℝ) + field_simp + +/-- **The crossing move is an isometry**: it permutes the darts of `G`. -/ +theorem sum_sq_crossStep (f : G.V × G.D → ℝ) : + ∑ x : G.V × G.D, (crossStep G f x) ^ 2 = ∑ x : G.V × G.D, (f x) ^ 2 := + Fintype.sum_equiv (G.rot_involutive.toPerm) + (fun x => (crossStep G f x) ^ 2) (fun x => (f x) ^ 2) fun _ => rfl + +/-- The crossing move preserves the inner product with itself. -/ +theorem sum_sq_crossStep_aux (f : G.V × G.D → ℝ) : + ∑ x : G.V × G.D, crossStep G f x * crossStep G f x + = ∑ x : G.V × G.D, f x * f x := + Fintype.sum_equiv (G.rot_involutive.toPerm) + (fun x => crossStep G f x * crossStep G f x) (fun x => f x * f x) fun _ => rfl + +/-- The crossing move preserves sums too. -/ +theorem sum_crossStep (f : G.V × G.D → ℝ) : + ∑ x : G.V × G.D, crossStep G f x = ∑ x : G.V × G.D, f x := + Fintype.sum_equiv (G.rot_involutive.toPerm) + (fun x => crossStep G f x) (fun x => f x) fun _ => rfl + +/-! ### The cloud move is `H`'s walk -/ + +/-- One cloud of the product, read as a function on `H`'s vertices. -/ +def cloudFun (f : G.V × G.D → ℝ) (v : G.V) : H.V → ℝ := fun u => f (v, e u) + +/-- **The cloud move is `H`'s walk**, transported along `e`. Every property of +`H`'s step operator therefore holds cloud by cloud. -/ +theorem cloudStep_apply (f : G.V × G.D → ℝ) (v : G.V) (i : G.D) : + cloudStep G H e f (v, i) = H.step (cloudFun G H e f v) (e.symm i) := rfl + +theorem sum_cloudFun (f : G.V × G.D → ℝ) (v : G.V) : + ∑ u : H.V, cloudFun G H e f v u = ∑ i : G.D, f (v, i) := + Fintype.sum_equiv e (fun u => cloudFun G H e f v u) (fun i => f (v, i)) fun _ => rfl + +theorem sum_sq_cloudFun (f : G.V × G.D → ℝ) (v : G.V) : + ∑ u : H.V, (cloudFun G H e f v u) ^ 2 = ∑ i : G.D, (f (v, i)) ^ 2 := + Fintype.sum_equiv e (fun u => (cloudFun G H e f v u) ^ 2) (fun i => (f (v, i)) ^ 2) + fun _ => rfl + +/-- The cloud move, summed over one cloud, is what `H`'s walk does there. -/ +theorem sum_cloudStep (f : G.V × G.D → ℝ) (v : G.V) : + ∑ i : G.D, cloudStep G H e f (v, i) = ∑ i : G.D, f (v, i) := by + have h : ∑ i : G.D, cloudStep G H e f (v, i) + = ∑ u : H.V, H.step (cloudFun G H e f v) u := + (Fintype.sum_equiv e (fun u => H.step (cloudFun G H e f v) u) + (fun i => cloudStep G H e f (v, i)) fun u => by + dsimp only + rw [cloudStep_apply, Equiv.symm_apply_apply]).symm + rw [h, H.sum_step, sum_cloudFun] + +/-- **The cloud move contracts what `H` contracts.** On a cloud whose values sum +to zero, one cloud move shrinks the sum of squares by `lam ^ 2`. -/ +theorem sum_sq_cloudStep_le {lam : ℝ} (hH : H.SpectralBound lam) + (f : G.V × G.D → ℝ) (v : G.V) (hv : ∑ i : G.D, f (v, i) = 0) : + ∑ i : G.D, (cloudStep G H e f (v, i)) ^ 2 ≤ lam ^ 2 * ∑ i : G.D, (f (v, i)) ^ 2 := by + have hzero : ∑ u : H.V, cloudFun G H e f v u = 0 := by + rw [sum_cloudFun] + exact hv + have hbound := hH (cloudFun G H e f v) hzero + have h : ∑ i : G.D, (cloudStep G H e f (v, i)) ^ 2 + = ∑ u : H.V, (H.step (cloudFun G H e f v) u) ^ 2 := + (Fintype.sum_equiv e (fun u => (H.step (cloudFun G H e f v) u) ^ 2) + (fun i => (cloudStep G H e f (v, i)) ^ 2) fun u => by + dsimp only + rw [cloudStep_apply, Equiv.symm_apply_apply]).symm + rw [h, ← sum_sq_cloudFun] + exact hbound + +/-! ### Splitting off the part constant along clouds -/ + +/-- The average of `f` over the cloud above a vertex of `G`. -/ +noncomputable def cloudMean (f : G.V × G.D → ℝ) (v : G.V) : ℝ := + (∑ i : G.D, f (v, i)) / (G.deg : ℝ) + +/-- The part of `f` that is constant along each cloud. -/ +noncomputable def cloudPar (f : G.V × G.D → ℝ) : G.V × G.D → ℝ := + fun x => cloudMean G f x.1 + +/-- What is left over. -/ +noncomputable def cloudPerp (f : G.V × G.D → ℝ) : G.V × G.D → ℝ := + fun x => f x - cloudPar G f x + +theorem cloudPar_add_cloudPerp (f : G.V × G.D → ℝ) (x : G.V × G.D) : + cloudPar G f x + cloudPerp G f x = f x := by + rw [cloudPerp] + ring + +/-- **The cloud move fixes the constant part.** -/ +theorem cloudStep_cloudPar (f : G.V × G.D → ℝ) (x : G.V × G.D) : + cloudStep G H e (cloudPar G f) x = cloudPar G f x := by + obtain ⟨v, i⟩ := x + rw [cloudStep_apply] + have hconst : cloudFun G H e (cloudPar G f) v = fun _ => cloudMean G f v := rfl + rw [hconst, RegGraph.step_const] + rfl + +/-- **The leftover part sums to zero on every cloud.** -/ +theorem sum_cloudPerp (f : G.V × G.D → ℝ) (v : G.V) : + ∑ i : G.D, cloudPerp G f (v, i) = 0 := by + have hdeg : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + have hcard : (Finset.univ : Finset G.D).card = G.deg := Finset.card_univ + rw [show (fun i : G.D => cloudPerp G f (v, i)) + = fun i : G.D => f (v, i) - cloudMean G f v from rfl] + rw [Finset.sum_sub_distrib, Finset.sum_const, hcard, nsmul_eq_mul, cloudMean] + field_simp + ring + +/-- The cloud move contracts the leftover part. -/ +theorem sum_sq_cloudStep_cloudPerp_le {lam : ℝ} (hH : H.SpectralBound lam) + (f : G.V × G.D → ℝ) (v : G.V) : + ∑ i : G.D, (cloudStep G H e (cloudPerp G f) (v, i)) ^ 2 + ≤ lam ^ 2 * ∑ i : G.D, (cloudPerp G f (v, i)) ^ 2 := + sum_sq_cloudStep_le G H e hH (cloudPerp G f) v (sum_cloudPerp G f v) + +/-! ### Both moves are self-adjoint -/ + +/-- One step of a graph is self-adjoint: reversing darts is a bijection. -/ +theorem sum_mul_step_comm (K : RegGraph) (f g : K.V → ℝ) : + ∑ v : K.V, f v * K.step g v = ∑ v : K.V, K.step f v * g v := by + have hr : ∑ v : K.V, K.step f v * g v = ∑ v : K.V, g v * K.step f v := + Finset.sum_congr rfl fun v _ => mul_comm _ _ + rw [hr, sum_mul_step, sum_mul_step] + congr 1 + rw [K.sum_darts_swap (fun u w => f u * g w)] + exact Finset.sum_congr rfl fun p _ => mul_comm _ _ + +/-- The inner product of two functions on the darts of `G`. -/ +noncomputable def ip (f g : G.V × G.D → ℝ) : ℝ := ∑ x : G.V × G.D, f x * g x + +theorem ip_comm (f g : G.V × G.D → ℝ) : ip G f g = ip G g f := by + rw [ip, ip] + exact Finset.sum_congr rfl fun x _ => mul_comm _ _ + +/-- Summing over the product is summing cloud by cloud. -/ +theorem ip_eq_sum_clouds (f g : G.V × G.D → ℝ) : + ip G f g = ∑ v : G.V, ∑ i : G.D, f (v, i) * g (v, i) := by + rw [ip, Fintype.sum_prod_type] + +/-- **The cloud move is self-adjoint**, because `H`'s walk is. -/ +theorem ip_cloudStep (f g : G.V × G.D → ℝ) : + ip G (cloudStep G H e f) g = ip G f (cloudStep G H e g) := by + rw [ip_eq_sum_clouds, ip_eq_sum_clouds] + refine Finset.sum_congr rfl fun v _ => ?_ + have hl : ∑ i : G.D, cloudStep G H e f (v, i) * g (v, i) + = ∑ u : H.V, H.step (cloudFun G H e f v) u * cloudFun G H e g v u := + (Fintype.sum_equiv e + (fun u => H.step (cloudFun G H e f v) u * cloudFun G H e g v u) + (fun i => cloudStep G H e f (v, i) * g (v, i)) fun u => by + dsimp only + rw [cloudStep_apply, Equiv.symm_apply_apply] + rfl).symm + have hr : ∑ i : G.D, f (v, i) * cloudStep G H e g (v, i) + = ∑ u : H.V, cloudFun G H e f v u * H.step (cloudFun G H e g v) u := + (Fintype.sum_equiv e + (fun u => cloudFun G H e f v u * H.step (cloudFun G H e g v) u) + (fun i => f (v, i) * cloudStep G H e g (v, i)) fun u => by + dsimp only + rw [cloudStep_apply, Equiv.symm_apply_apply] + rfl).symm + rw [hl, hr, ← sum_mul_step_comm] + +/-- **The crossing move is self-adjoint**, because `G.rot` is an involution. -/ +theorem ip_crossStep (f g : G.V × G.D → ℝ) : + ip G (crossStep G f) g = ip G f (crossStep G g) := by + rw [ip, ip] + refine Fintype.sum_equiv (G.rot_involutive.toPerm) + (fun x => crossStep G f x * g x) (fun x => f x * crossStep G g x) fun x => ?_ + show f (G.rot x) * g x = f (G.rot x) * g (G.rot (G.rot x)) + rw [G.rot_involutive x] + +/-- Cauchy–Schwarz for this inner product. -/ +theorem ip_sq_le (f g : G.V × G.D → ℝ) : (ip G f g) ^ 2 ≤ ip G f f * ip G g g := by + have h := Finset.sum_mul_sq_le_sq_mul_sq (Finset.univ : Finset (G.V × G.D)) f g + rw [ip, ip, ip] + calc (∑ x : G.V × G.D, f x * g x) ^ 2 + ≤ (∑ x : G.V × G.D, f x ^ 2) * ∑ x : G.V × G.D, g x ^ 2 := h + _ = (∑ x : G.V × G.D, f x * f x) * ∑ x : G.V × G.D, g x * g x := by + rw [Finset.sum_congr rfl fun x _ => sq (f x), + Finset.sum_congr rfl fun x _ => sq (g x)] + +/-! ### The constant part is a function on `G` -/ + +/-- **Crossing acts on cloud-constant functions as `G`'s walk.** This is the +bridge that lets `G.SpectralBound` be applied to the product. -/ +theorem cloudMean_crossStep_cloudPar (f : G.V × G.D → ℝ) (v : G.V) : + cloudMean G (crossStep G (cloudPar G f)) v = G.step (cloudMean G f) v := by + rw [cloudMean, RegGraph.step] + congr 1 + +/-- The inner product of two cloud-constant functions is `G.deg` times the inner +product of the functions they come from. -/ +theorem ip_cloudPar (f g : G.V × G.D → ℝ) : + ip G (cloudPar G f) (cloudPar G g) + = (G.deg : ℝ) * ∑ v : G.V, cloudMean G f v * cloudMean G g v := by + rw [ip_eq_sum_clouds, Finset.mul_sum] + refine Finset.sum_congr rfl fun v _ => ?_ + have hconst : ∀ i : G.D, cloudPar G f (v, i) * cloudPar G g (v, i) + = cloudMean G f v * cloudMean G g v := fun _ => rfl + rw [Finset.sum_congr rfl fun i _ => hconst i, Finset.sum_const, Finset.card_univ, + nsmul_eq_mul] + rfl + +/-- A mean-zero function on the product has mean-zero cloud averages. -/ +theorem sum_cloudMean (f : G.V × G.D → ℝ) : + ∑ v : G.V, cloudMean G f v = (∑ x : G.V × G.D, f x) / (G.deg : ℝ) := by + rw [Fintype.sum_prod_type, Finset.sum_div] + exact Finset.sum_congr rfl fun v _ => rfl + +theorem sum_cloudMean_eq_zero {f : G.V × G.D → ℝ} (hf : ∑ x : G.V × G.D, f x = 0) : + ∑ v : G.V, cloudMean G f v = 0 := by + rw [sum_cloudMean, hf, zero_div] + +/-- The sum of squares of the constant part, in terms of `G`. -/ +theorem ip_cloudPar_self (f : G.V × G.D → ℝ) : + ip G (cloudPar G f) (cloudPar G f) + = (G.deg : ℝ) * ∑ v : G.V, (cloudMean G f v) ^ 2 := by + rw [ip_cloudPar] + congr 1 + exact Finset.sum_congr rfl fun v _ => (sq _).symm + +/-- **The parallel–parallel term is `G`'s own quadratic form.** This is where +`G.SpectralBound` will enter the estimate. -/ +theorem ip_cloudPar_crossStep (f : G.V × G.D → ℝ) : + ip G (cloudPar G f) (crossStep G (cloudPar G f)) + = (G.deg : ℝ) * ∑ v : G.V, cloudMean G f v * G.step (cloudMean G f) v := by + have hdeg : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero + rw [ip_eq_sum_clouds, Finset.mul_sum] + refine Finset.sum_congr rfl fun v _ => ?_ + have h : ∀ i : G.D, cloudPar G f (v, i) * crossStep G (cloudPar G f) (v, i) + = cloudMean G f v * cloudMean G f (G.nbr v i) := fun _ => rfl + rw [Finset.sum_congr rfl fun i _ => h i, ← Finset.mul_sum, RegGraph.step] + field_simp + +/-! ### Linearity -/ + +theorem cloudStep_add (f g : G.V × G.D → ℝ) (x : G.V × G.D) : + cloudStep G H e (fun y => f y + g y) x = cloudStep G H e f x + cloudStep G H e g x := by + rw [cloudStep, cloudStep, cloudStep, ← add_div] + congr 1 + exact Finset.sum_add_distrib + +theorem crossStep_add (f g : G.V × G.D → ℝ) (x : G.V × G.D) : + crossStep G (fun y => f y + g y) x = crossStep G f x + crossStep G g x := rfl + +theorem ip_add_left (f g h : G.V × G.D → ℝ) : + ip G (fun x => f x + g x) h = ip G f h + ip G g h := by + rw [ip, ip, ip, ← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + +theorem ip_add_right (f g h : G.V × G.D → ℝ) : + ip G f (fun x => g x + h x) = ip G f g + ip G f h := by + rw [ip, ip, ip, ← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + +/-- **One cloud move splits into the constant part and a contracted +remainder.** -/ +theorem cloudStep_decomp (f : G.V × G.D → ℝ) (x : G.V × G.D) : + cloudStep G H e f x = cloudPar G f x + cloudStep G H e (cloudPerp G f) x := by + have hsplit : f = fun y => cloudPar G f y + cloudPerp G f y := by + funext y + rw [cloudPar_add_cloudPerp] + conv_lhs => rw [hsplit] + rw [cloudStep_add, cloudStep_cloudPar] + +/-- The zig-zag walk, with the cloud move split on both sides. -/ +theorem step_zigzag_decomp (f : (zigzag G H e).V → ℝ) : + ip G f ((zigzag G H e).step f) + = ip G (fun x => cloudPar G f x + cloudStep G H e (cloudPerp G f) x) + (crossStep G (fun x => cloudPar G f x + cloudStep G H e (cloudPerp G f) x)) := by + have hstep : ∀ x, (zigzag G H e).step f x + = cloudStep G H e (crossStep G (cloudStep G H e f)) x := step_zigzag G H e f + have hz : (zigzag G H e).step f = cloudStep G H e (crossStep G (cloudStep G H e f)) := by + funext x + exact hstep x + rw [hz, ← ip_cloudStep] + have hdec : cloudStep G H e f + = fun x => cloudPar G f x + cloudStep G H e (cloudPerp G f) x := by + funext x + exact cloudStep_decomp G H e f x + rw [hdec] + +/-- **The four terms of the estimate.** -/ +theorem ip_crossStep_expand (p q : G.V × G.D → ℝ) : + ip G (fun x => p x + q x) (crossStep G (fun x => p x + q x)) + = ip G p (crossStep G p) + ip G p (crossStep G q) + + ip G q (crossStep G p) + ip G q (crossStep G q) := by + have hc : crossStep G (fun x => p x + q x) + = fun x => crossStep G p x + crossStep G q x := by + funext x + exact crossStep_add G p q x + rw [hc, ip_add_left, ip_add_right, ip_add_right] + ring + +/-- **The zig-zag quadratic form, expanded.** The first summand is `G`'s own +form on the cloud averages; the other three involve the contracted remainder. -/ +theorem ip_step_zigzag_expand (f : (zigzag G H e).V → ℝ) : + ip G f ((zigzag G H e).step f) + = ip G (cloudPar G f) (crossStep G (cloudPar G f)) + + ip G (cloudPar G f) (crossStep G (cloudStep G H e (cloudPerp G f))) + + ip G (cloudStep G H e (cloudPerp G f)) (crossStep G (cloudPar G f)) + + ip G (cloudStep G H e (cloudPerp G f)) + (crossStep G (cloudStep G H e (cloudPerp G f))) := by + rw [step_zigzag_decomp, ip_crossStep_expand] + +/-! ### The Rayleigh quotient -/ + +/-- **A spectral bound controls the quadratic form.** Cauchy–Schwarz turns the +bound on `‖step g‖` into one on `⟨g, step g⟩`, which is the form the zig-zag +estimate consumes. -/ +theorem sum_mul_step_le_of_spectralBound (K : RegGraph) {lam : ℝ} (hK : K.SpectralBound lam) + (hlam : 0 ≤ lam) (g : K.V → ℝ) (hg : ∑ v : K.V, g v = 0) : + ∑ v : K.V, g v * K.step g v ≤ lam * ∑ v : K.V, (g v) ^ 2 := by + set S := ∑ v : K.V, (g v) ^ 2 with hS + set T := ∑ v : K.V, g v * K.step g v with hT + have hS0 : 0 ≤ S := Finset.sum_nonneg fun _ _ => sq_nonneg _ + have hcs := Finset.sum_mul_sq_le_sq_mul_sq (Finset.univ : Finset K.V) g (K.step g) + have hspec := hK g hg + have hT2 : T ^ 2 ≤ S * (lam ^ 2 * S) := + le_trans hcs (mul_le_mul_of_nonneg_left hspec hS0) + nlinarith [hT2, mul_nonneg hlam hS0, sq_nonneg (T + lam * S)] + +/-- The norm of the contracted remainder, over the whole product. -/ +theorem ip_cloudStep_cloudPerp_le {lam : ℝ} (hH : H.SpectralBound lam) + (f : G.V × G.D → ℝ) : + ip G (cloudStep G H e (cloudPerp G f)) (cloudStep G H e (cloudPerp G f)) + ≤ lam ^ 2 * ip G (cloudPerp G f) (cloudPerp G f) := by + rw [ip_eq_sum_clouds, ip_eq_sum_clouds, Finset.mul_sum] + refine Finset.sum_le_sum fun v _ => ?_ + have hb := sum_sq_cloudStep_cloudPerp_le G H e hH f v + have hl : ∑ i : G.D, cloudStep G H e (cloudPerp G f) (v, i) + * cloudStep G H e (cloudPerp G f) (v, i) + = ∑ i : G.D, (cloudStep G H e (cloudPerp G f) (v, i)) ^ 2 := + Finset.sum_congr rfl fun i _ => (sq _).symm + have hr : ∑ i : G.D, cloudPerp G f (v, i) * cloudPerp G f (v, i) + = ∑ i : G.D, (cloudPerp G f (v, i)) ^ 2 := + Finset.sum_congr rfl fun i _ => (sq _).symm + rw [hl, hr] + exact hb + +/-- **Term one of the estimate**: the constant part is bounded by `G`'s own +spectral bound. -/ +theorem ip_cloudPar_crossStep_le {lam : ℝ} (hG : G.SpectralBound lam) (hlam : 0 ≤ lam) + {f : G.V × G.D → ℝ} (hf : ∑ x : G.V × G.D, f x = 0) : + ip G (cloudPar G f) (crossStep G (cloudPar G f)) + ≤ lam * ip G (cloudPar G f) (cloudPar G f) := by + have hzero : ∑ v : G.V, cloudMean G f v = 0 := sum_cloudMean_eq_zero G hf + have hray := sum_mul_step_le_of_spectralBound G hG hlam (cloudMean G f) hzero + rw [ip_cloudPar_crossStep, ip_cloudPar_self] + have hd : (0 : ℝ) ≤ (G.deg : ℝ) := by positivity + calc (G.deg : ℝ) * ∑ v : G.V, cloudMean G f v * G.step (cloudMean G f) v + ≤ (G.deg : ℝ) * (lam * ∑ v : G.V, (cloudMean G f v) ^ 2) := + mul_le_mul_of_nonneg_left hray hd + _ = lam * ((G.deg : ℝ) * ∑ v : G.V, (cloudMean G f v) ^ 2) := by ring + +/-! ### Orthogonality and a weighted bound -/ + +theorem ip_nonneg (g : G.V × G.D → ℝ) : 0 ≤ ip G g g := + Finset.sum_nonneg fun _ _ => mul_self_nonneg _ + +/-- **The two parts are orthogonal.** The constant part is fixed along a cloud +while the remainder sums to zero there. -/ +theorem ip_cloudPar_cloudPerp (f : G.V × G.D → ℝ) : + ip G (cloudPar G f) (cloudPerp G f) = 0 := by + rw [ip_eq_sum_clouds] + refine Finset.sum_eq_zero fun v _ => ?_ + have h : ∀ i : G.D, cloudPar G f (v, i) * cloudPerp G f (v, i) + = cloudMean G f v * cloudPerp G f (v, i) := fun _ => rfl + rw [Finset.sum_congr rfl fun i _ => h i, ← Finset.mul_sum, sum_cloudPerp, mul_zero] + +/-- **Pythagoras** for the splitting. -/ +theorem ip_self_split (f : G.V × G.D → ℝ) : + ip G f f = ip G (cloudPar G f) (cloudPar G f) + ip G (cloudPerp G f) (cloudPerp G f) := by + have hsplit : f = fun y => cloudPar G f y + cloudPerp G f y := by + funext y + rw [cloudPar_add_cloudPerp] + conv_lhs => rw [hsplit] + rw [ip_add_left, ip_add_right, ip_add_right, ip_cloudPar_cloudPerp, + ip_comm G (cloudPerp G f) (cloudPar G f), ip_cloudPar_cloudPerp] + ring + +/-- **The weighted arithmetic-geometric bound.** Expanding `0 ≤ ‖t u - w‖²` +avoids any square root, which keeps the estimate inside the ordered field. -/ +theorem ip_two_mul_le (u w : G.V × G.D → ℝ) {t : ℝ} (ht : 0 < t) : + 2 * ip G u w ≤ t * ip G u u + ip G w w / t := by + have hnn : 0 ≤ ∑ x : G.V × G.D, (t * u x - w x) ^ 2 := + Finset.sum_nonneg fun _ _ => sq_nonneg _ + have hexp : ∑ x : G.V × G.D, (t * u x - w x) ^ 2 + = t ^ 2 * ip G u u - 2 * t * ip G u w + ip G w w := by + rw [ip, ip, ip, Finset.mul_sum, Finset.mul_sum, ← Finset.sum_sub_distrib, + ← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + rw [hexp] at hnn + have hmul : 2 * ip G u w * t ≤ (t * ip G u u + ip G w w / t) * t := by + have ht' : t ≠ 0 := ne_of_gt ht + field_simp + nlinarith [hnn] + exact le_of_mul_le_mul_right hmul ht + +/-- The crossing move preserves the inner product with itself, in `ip` form. -/ +theorem ip_crossStep_self (g : G.V × G.D → ℝ) : + ip G (crossStep G g) (crossStep G g) = ip G g g := by + rw [ip, ip] + exact sum_sq_crossStep_aux G g + +/-! ### The Reingold–Vadhan–Wigderson estimate -/ + +theorem eq_zero_of_ip_self_eq_zero {g : G.V × G.D → ℝ} (h : ip G g g = 0) + (x : G.V × G.D) : g x = 0 := by + have hmem := (Finset.sum_eq_zero_iff_of_nonneg + (fun y (_ : y ∈ (Finset.univ : Finset (G.V × G.D))) => mul_self_nonneg (g y))).1 h x + (Finset.mem_univ x) + exact mul_self_eq_zero.1 hmem + +/-- **The zig-zag product's quadratic form is bounded by +`lamG + lamH + lamH ^ 2`.** -/ +theorem ip_step_zigzag_le {lamG lamH : ℝ} (hG : G.SpectralBound lamG) + (hH : H.SpectralBound lamH) (hlamG : 0 ≤ lamG) (hlamH : 0 ≤ lamH) + (f : (zigzag G H e).V → ℝ) (hf : ∑ x : G.V × G.D, f x = 0) : + ip G f ((zigzag G H e).step f) ≤ (lamG + lamH + lamH ^ 2) * ip G f f := by + set p := cloudPar G f with hp + set r := cloudPerp G f with hr + set q := cloudStep G H e r with hq + set a := ip G p p with ha + set b := ip G r r with hb + have ha0 : 0 ≤ a := ip_nonneg G p + have hb0 : 0 ≤ b := ip_nonneg G r + have hqq : ip G q q ≤ lamH ^ 2 * b := ip_cloudStep_cloudPerp_le G H e hH f + have hq0 : 0 ≤ ip G q q := ip_nonneg G q + have hsplit : ip G f f = a + b := ip_self_split G f + have hterm1 : ip G p (crossStep G p) ≤ lamG * a := ip_cloudPar_crossStep_le G hG hlamG hf + have hsym : ip G q (crossStep G p) = ip G p (crossStep G q) := by + rw [← ip_crossStep, ip_comm] + have hcross : 2 * ip G p (crossStep G q) ≤ lamH * a + lamH * b := by + rcases eq_or_lt_of_le hlamH with h0 | hpos + · have hz : ip G q q = 0 := le_antisymm (by rw [← h0] at hqq; simpa using hqq) hq0 + have hqzero : ∀ x, q x = 0 := fun x => eq_zero_of_ip_self_eq_zero G hz x + have : ip G p (crossStep G q) = 0 := by + rw [ip] + refine Finset.sum_eq_zero fun x _ => ?_ + show p x * q (G.rot x) = 0 + rw [hqzero, mul_zero] + rw [this, ← h0] + norm_num + · have hb2 := ip_two_mul_le G p (crossStep G q) hpos + rw [ip_crossStep_self] at hb2 + have hdiv : ip G q q / lamH ≤ lamH * b := by + rw [div_le_iff₀ hpos] + calc ip G q q ≤ lamH ^ 2 * b := hqq + _ = lamH * b * lamH := by ring + linarith + have hterm4 : ip G q (crossStep G q) ≤ lamH ^ 2 * b := by + have h1 := ip_two_mul_le G q (crossStep G q) (by norm_num : (0 : ℝ) < 1) + rw [ip_crossStep_self] at h1 + linarith + rw [ip_step_zigzag_expand, hsplit, ← hp, ← hr, ← hq] + have hgb : 0 ≤ lamG * b := mul_nonneg hlamG hb0 + have hha : 0 ≤ lamH ^ 2 * a := mul_nonneg (sq_nonneg _) ha0 + linarith [hterm1, hcross, hterm4, hsym, hgb, hha] + +/-! ### A walk is a contraction -/ + +/-- In inner-product form: the cloud move is a contraction. -/ +theorem ip_cloudStep_le (g : G.V × G.D → ℝ) : + ip G (cloudStep G H e g) (cloudStep G H e g) ≤ ip G g g := by + rw [ip_eq_sum_clouds, ip_eq_sum_clouds] + refine Finset.sum_le_sum fun v _ => ?_ + have hl : ∑ i : G.D, cloudStep G H e g (v, i) * cloudStep G H e g (v, i) + = ∑ u : H.V, (H.step (cloudFun G H e g v) u) ^ 2 := + (Fintype.sum_equiv e (fun u => (H.step (cloudFun G H e g v) u) ^ 2) + (fun i => cloudStep G H e g (v, i) * cloudStep G H e g (v, i)) fun u => by + dsimp only + rw [cloudStep_apply, Equiv.symm_apply_apply, sq]).symm + have hr : ∑ i : G.D, g (v, i) * g (v, i) = ∑ u : H.V, (cloudFun G H e g v u) ^ 2 := + (Fintype.sum_equiv e (fun u => (cloudFun G H e g v u) ^ 2) + (fun i => g (v, i) * g (v, i)) fun u => by + dsimp only + rw [sq] + rfl).symm + rw [hl, hr] + exact H.sum_sq_step_le (cloudFun G H e g v) + +/-! ### Two-sided forms -/ + +theorem ip_neg_left (u w : G.V × G.D → ℝ) : + ip G (fun x => -u x) w = -ip G u w := by + rw [ip, ip, ← Finset.sum_neg_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + +theorem ip_neg_self (u : G.V × G.D → ℝ) : + ip G (fun x => -u x) (fun x => -u x) = ip G u u := by + rw [ip, ip] + exact Finset.sum_congr rfl fun x _ => by ring + +/-- The weighted bound, two-sided. -/ +theorem abs_ip_two_mul_le (u w : G.V × G.D → ℝ) {t : ℝ} (ht : 0 < t) : + 2 * |ip G u w| ≤ t * ip G u u + ip G w w / t := by + have hpos := ip_two_mul_le G u w ht + have hneg := ip_two_mul_le G (fun x => -u x) w ht + rw [ip_neg_left, ip_neg_self] at hneg + rcases abs_cases (ip G u w) with ⟨he, -⟩ | ⟨he, -⟩ <;> rw [he] <;> linarith + +/-- **The Rayleigh quotient, two-sided.** -/ +theorem abs_sum_mul_step_le (K : RegGraph) {lam : ℝ} (hK : K.SpectralBound lam) + (hlam : 0 ≤ lam) (g : K.V → ℝ) (hg : ∑ v : K.V, g v = 0) : + |∑ v : K.V, g v * K.step g v| ≤ lam * ∑ v : K.V, (g v) ^ 2 := by + set S := ∑ v : K.V, (g v) ^ 2 with hS + set T := ∑ v : K.V, g v * K.step g v with hT + have hS0 : 0 ≤ S := Finset.sum_nonneg fun _ _ => sq_nonneg _ + have hcs := Finset.sum_mul_sq_le_sq_mul_sq (Finset.univ : Finset K.V) g (K.step g) + have hspec := hK g hg + have hT2 : T ^ 2 ≤ S * (lam ^ 2 * S) := + le_trans hcs (mul_le_mul_of_nonneg_left hspec hS0) + rw [abs_le] + constructor + · nlinarith [hT2, mul_nonneg hlam hS0, sq_nonneg (T - lam * S)] + · nlinarith [hT2, mul_nonneg hlam hS0, sq_nonneg (T + lam * S)] + +/-- **Term one, two-sided.** -/ +theorem abs_ip_cloudPar_crossStep_le {lam : ℝ} (hG : G.SpectralBound lam) (hlam : 0 ≤ lam) + {f : G.V × G.D → ℝ} (hf : ∑ x : G.V × G.D, f x = 0) : + |ip G (cloudPar G f) (crossStep G (cloudPar G f))| + ≤ lam * ip G (cloudPar G f) (cloudPar G f) := by + have hzero : ∑ v : G.V, cloudMean G f v = 0 := sum_cloudMean_eq_zero G hf + have hray := abs_sum_mul_step_le G hG hlam (cloudMean G f) hzero + rw [ip_cloudPar_crossStep, ip_cloudPar_self, abs_mul, + abs_of_nonneg (show (0:ℝ) ≤ (G.deg : ℝ) by positivity)] + have hd : (0 : ℝ) ≤ (G.deg : ℝ) := by positivity + calc (G.deg : ℝ) * |∑ v : G.V, cloudMean G f v * G.step (cloudMean G f) v| + ≤ (G.deg : ℝ) * (lam * ∑ v : G.V, (cloudMean G f v) ^ 2) := + mul_le_mul_of_nonneg_left hray hd + _ = lam * ((G.deg : ℝ) * ∑ v : G.V, (cloudMean G f v) ^ 2) := by ring + +/-- **The RVW estimate, two-sided.** This is the form the conversion to +`SpectralBound` needs, since polarisation uses the bound on both signs. -/ +theorem abs_ip_step_zigzag_le {lamG lamH : ℝ} (hG : G.SpectralBound lamG) + (hH : H.SpectralBound lamH) (hlamG : 0 ≤ lamG) (hlamH : 0 ≤ lamH) + (f : (zigzag G H e).V → ℝ) (hf : ∑ x : G.V × G.D, f x = 0) : + |ip G f ((zigzag G H e).step f)| ≤ (lamG + lamH + lamH ^ 2) * ip G f f := by + set p := cloudPar G f with hp + set r := cloudPerp G f with hr + set q := cloudStep G H e r with hq + set a := ip G p p with ha + set b := ip G r r with hb + have ha0 : 0 ≤ a := ip_nonneg G p + have hb0 : 0 ≤ b := ip_nonneg G r + have hqq : ip G q q ≤ lamH ^ 2 * b := ip_cloudStep_cloudPerp_le G H e hH f + have hq0 : 0 ≤ ip G q q := ip_nonneg G q + have hsplit : ip G f f = a + b := ip_self_split G f + have hterm1 : |ip G p (crossStep G p)| ≤ lamG * a := + abs_ip_cloudPar_crossStep_le G hG hlamG hf + have hsym : ip G q (crossStep G p) = ip G p (crossStep G q) := by + rw [← ip_crossStep, ip_comm] + have hcross : 2 * |ip G p (crossStep G q)| ≤ lamH * a + lamH * b := by + rcases eq_or_lt_of_le hlamH with h0 | hpos + · have hz : ip G q q = 0 := le_antisymm (by rw [← h0] at hqq; simpa using hqq) hq0 + have hqzero : ∀ x, q x = 0 := fun x => eq_zero_of_ip_self_eq_zero G hz x + have hzero2 : ip G p (crossStep G q) = 0 := by + rw [ip] + refine Finset.sum_eq_zero fun x _ => ?_ + show p x * q (G.rot x) = 0 + rw [hqzero, mul_zero] + rw [hzero2, ← h0] + norm_num + · have hb2 := abs_ip_two_mul_le G p (crossStep G q) hpos + rw [ip_crossStep_self] at hb2 + have hdiv : ip G q q / lamH ≤ lamH * b := by + rw [div_le_iff₀ hpos] + calc ip G q q ≤ lamH ^ 2 * b := hqq + _ = lamH * b * lamH := by ring + linarith + have hterm4 : |ip G q (crossStep G q)| ≤ lamH ^ 2 * b := by + have h1 := abs_ip_two_mul_le G q (crossStep G q) (by norm_num : (0 : ℝ) < 1) + rw [ip_crossStep_self] at h1 + linarith + rw [ip_step_zigzag_expand, hsplit, ← hp, ← hr, ← hq, hsym] + have hgb : 0 ≤ lamG * b := mul_nonneg hlamG hb0 + have hha : 0 ≤ lamH ^ 2 * a := mul_nonneg (sq_nonneg _) ha0 + have hcross' : |ip G p (crossStep G q)| ≤ (lamH * a + lamH * b) / 2 := by linarith + have h1 := abs_le.1 hterm1 + have h2 := abs_le.1 hcross' + have h4 := abs_le.1 hterm4 + rw [abs_le] + constructor <;> linarith [h1.1, h1.2, h2.1, h2.2, h4.1, h4.2, hgb, hha] + +/-! ### From the quadratic form to the spectral bound -/ + +theorem step_sub (K : RegGraph) (f g : K.V → ℝ) (v : K.V) : + K.step (fun w => f w - g w) v = K.step f v - K.step g v := by + rw [RegGraph.step, RegGraph.step, RegGraph.step, ← sub_div] + congr 1 + exact Finset.sum_sub_distrib (s := (Finset.univ : Finset K.D)) + (f := fun i => f (K.nbr v i)) (g := fun i => g (K.nbr v i)) + +theorem ip_sub_left (f g h : G.V × G.D → ℝ) : + ip G (fun x => f x - g x) h = ip G f h - ip G g h := by + rw [ip, ip, ip, ← Finset.sum_sub_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + +theorem ip_sub_right (f g h : G.V × G.D → ℝ) : + ip G f (fun x => g x - h x) = ip G f g - ip G f h := by + rw [ip, ip, ip, ← Finset.sum_sub_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + +/-- The walk of the product is self-adjoint — it is a walk, like any other. -/ +theorem ip_step_zigzag_comm (f g : G.V × G.D → ℝ) : + ip G ((zigzag G H e).step f) g = ip G f ((zigzag G H e).step g) := by + rw [ip, ip] + exact (sum_mul_step_comm (zigzag G H e) f g).symm + +/-- The sum of squares over the product's vertices, as an inner product. -/ +theorem sum_sq_eq_ip (g : (zigzag G H e).V → ℝ) : + ∑ v : (zigzag G H e).V, (g v) ^ 2 = ip G g g := by + rw [ip] + exact Finset.sum_congr rfl fun x _ => sq _ + +/-- **Polarisation.** -/ +theorem ip_polarise (f g : G.V × G.D → ℝ) : + 4 * ip G ((zigzag G H e).step f) g + = ip G ((zigzag G H e).step (fun x => f x + g x)) (fun x => f x + g x) + - ip G ((zigzag G H e).step (fun x => f x - g x)) (fun x => f x - g x) := by + have hadd : (zigzag G H e).step (fun x => f x + g x) + = fun x => (zigzag G H e).step f x + (zigzag G H e).step g x := by + funext x + exact RegGraph.step_add (zigzag G H e) f g x + have hsub : (zigzag G H e).step (fun x => f x - g x) + = fun x => (zigzag G H e).step f x - (zigzag G H e).step g x := by + funext x + exact step_sub (zigzag G H e) f g x + have hcross : ip G ((zigzag G H e).step g) f = ip G ((zigzag G H e).step f) g := by + rw [ip_step_zigzag_comm, ip_comm] + have key : ip G ((zigzag G H e).step (fun x => f x + g x)) (fun x => f x + g x) + - ip G ((zigzag G H e).step (fun x => f x - g x)) (fun x => f x - g x) + = 2 * ip G ((zigzag G H e).step f) g + 2 * ip G ((zigzag G H e).step g) f := by + rw [hadd, hsub, ip, ip, ip, ip, ← Finset.sum_sub_distrib, Finset.mul_sum, + Finset.mul_sum, ← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun x _ => by ring + rw [key, hcross] + ring + +/-- **The spectral bound of the zig-zag product.** -/ +theorem spectralBound_zigzag {lamG lamH : ℝ} (hG : G.SpectralBound lamG) + (hH : H.SpectralBound lamH) (hlamG : 0 ≤ lamG) (hlamH : 0 ≤ lamH) : + (zigzag G H e).SpectralBound (lamG + lamH + lamH ^ 2) := by + have hlam0 : (0 : ℝ) ≤ lamG + lamH + lamH ^ 2 := by positivity + intro f hf + have hf' : ∑ x : G.V × G.D, f x = 0 := hf + have hmean : ∑ x : G.V × G.D, (zigzag G H e).step f x = ∑ x : G.V × G.D, f x := + RegGraph.sum_step (zigzag G H e) f + have hTf0 : ∑ x : G.V × G.D, (zigzag G H e).step f x = 0 := by rw [hmean]; exact hf' + have hA0 : 0 ≤ ip G ((zigzag G H e).step f) ((zigzag G H e).step f) := ip_nonneg G _ + have hB0 : 0 ≤ ip G f f := ip_nonneg G f + -- the test vector `g = (1/lam) • T f`, or `T f` itself in the degenerate case + have hmain : ∀ c : ℝ, 0 < c → + 2 * (ip G ((zigzag G H e).step f) ((zigzag G H e).step f) * c) + ≤ (lamG + lamH + lamH ^ 2) * (ip G f f + + c ^ 2 * ip G ((zigzag G H e).step f) ((zigzag G H e).step f)) := by + intro c hc + set g : G.V × G.D → ℝ := fun x => c * (zigzag G H e).step f x with hg + have hg0 : ∑ x : G.V × G.D, g x = 0 := by + rw [hg, ← Finset.mul_sum, hTf0, mul_zero] + have hgg : ip G g g + = c ^ 2 * ip G ((zigzag G H e).step f) ((zigzag G H e).step f) := by + rw [hg, ip, ip, Finset.mul_sum] + exact Finset.sum_congr rfl fun x _ => by ring + have hTfg : ip G ((zigzag G H e).step f) g + = c * ip G ((zigzag G H e).step f) ((zigzag G H e).step f) := by + rw [hg, ip, ip, Finset.mul_sum] + exact Finset.sum_congr rfl fun x _ => by ring + have hpol := ip_polarise G H e f g + have h1 := abs_ip_step_zigzag_le G H e hG hH hlamG hlamH + (fun x => f x + g x) (by rw [Finset.sum_add_distrib, hf', hg0]; ring) + have h2 := abs_ip_step_zigzag_le G H e hG hH hlamG hlamH + (fun x => f x - g x) (by rw [Finset.sum_sub_distrib, hf', hg0]; ring) + have hpar : ip G (fun x => f x + g x) (fun x => f x + g x) + + ip G (fun x => f x - g x) (fun x => f x - g x) + = 2 * ip G f f + 2 * ip G g g := by + rw [ip_add_left, ip_add_right, ip_add_right, ip_sub_left, ip_sub_right, + ip_sub_right, ip_comm G g f] + ring + have hb1 := abs_le.1 h1 + have hb2 := abs_le.1 h2 + have hswap1 : ip G ((zigzag G H e).step (fun x => f x + g x)) (fun x => f x + g x) + = ip G (fun x => f x + g x) ((zigzag G H e).step (fun x => f x + g x)) := + ip_comm G _ _ + have hswap2 : ip G ((zigzag G H e).step (fun x => f x - g x)) (fun x => f x - g x) + = ip G (fun x => f x - g x) ((zigzag G H e).step (fun x => f x - g x)) := + ip_comm G _ _ + rw [hTfg, hswap1, hswap2] at hpol + rw [hgg] at hpar + have hscaled : (lamG + lamH + lamH ^ 2) + * ((ip G (fun x => f x + g x) (fun x => f x + g x)) + + ip G (fun x => f x - g x) (fun x => f x - g x)) + = (lamG + lamH + lamH ^ 2) + * (2 * ip G f f + + 2 * (c ^ 2 * ip G ((zigzag G H e).step f) ((zigzag G H e).step f))) := by + rw [hpar] + have hcomb : ip G (fun x => f x + g x) ((zigzag G H e).step (fun x => f x + g x)) + - ip G (fun x => f x - g x) ((zigzag G H e).step (fun x => f x - g x)) + ≤ (lamG + lamH + lamH ^ 2) * (ip G (fun x => f x + g x) (fun x => f x + g x)) + + (lamG + lamH + lamH ^ 2) + * (ip G (fun x => f x - g x) (fun x => f x - g x)) := by + have hq' : -(ip G (fun x => f x - g x) + ((zigzag G H e).step (fun x => f x - g x))) + ≤ (lamG + lamH + lamH ^ 2) + * (ip G (fun x => f x - g x) (fun x => f x - g x)) := + neg_le_of_neg_le hb2.1 + have hsum := add_le_add hb1.2 hq' + rw [sub_eq_add_neg] + exact hsum + linarith [hpol, hcomb, hscaled] + rcases eq_or_lt_of_le hlam0 with h0 | hpos + · have hc := hmain 1 one_pos + rw [← h0] at hc + have : ip G ((zigzag G H e).step f) ((zigzag G H e).step f) ≤ 0 := by linarith + have hz : ip G ((zigzag G H e).step f) ((zigzag G H e).step f) = 0 := + le_antisymm this hA0 + show ∑ v : (zigzag G H e).V, ((zigzag G H e).step f v) ^ 2 ≤ _ + rw [sum_sq_eq_ip, sum_sq_eq_ip, hz, ← h0] + norm_num + · have hc := hmain (1 / (lamG + lamH + lamH ^ 2)) (by positivity) + have hne : lamG + lamH + lamH ^ 2 ≠ 0 := ne_of_gt hpos + have hsimp : (lamG + lamH + lamH ^ 2) + * (ip G f f + (1 / (lamG + lamH + lamH ^ 2)) ^ 2 + * ip G ((zigzag G H e).step f) ((zigzag G H e).step f)) + = (lamG + lamH + lamH ^ 2) * ip G f f + + ip G ((zigzag G H e).step f) ((zigzag G H e).step f) + / (lamG + lamH + lamH ^ 2) := by + field_simp + rw [hsimp] at hc + have hkey : ip G ((zigzag G H e).step f) ((zigzag G H e).step f) + / (lamG + lamH + lamH ^ 2) ≤ (lamG + lamH + lamH ^ 2) * ip G f f := by + have h2c : 2 * (ip G ((zigzag G H e).step f) ((zigzag G H e).step f) + * (1 / (lamG + lamH + lamH ^ 2))) + = 2 * (ip G ((zigzag G H e).step f) ((zigzag G H e).step f) + / (lamG + lamH + lamH ^ 2)) := by + field_simp + rw [h2c] at hc + linarith + rw [div_le_iff₀ hpos] at hkey + show ∑ v : (zigzag G H e).V, ((zigzag G H e).step f v) ^ 2 ≤ _ + rw [sum_sq_eq_ip, sum_sq_eq_ip] + nlinarith [hkey] + +end RegGraph + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean b/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean new file mode 100644 index 00000000..a7bb430f --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.SizedExpander +public import Complexitylib.Classes.PCP.Internal.ExpanderExists + +/-! +# A base graph for the tower exists + +The zig-zag tower is seeded by a single finite graph whose vertices number the +fourth power of its degree and whose spectral bound is a fifth. Such a graph is +what Reingold, Vadhan and Wigderson find by exhaustive search; here it comes +from any expander family at all, by raising one member to a power. + +Powering leaves the vertex set alone and raises both the degree and the bound +to the same power, so taking the member on `degree ^ (4 * m)` vertices and +powering it `m` times gives `degree ^ (4 * m) = (degree ^ m) ^ 4` vertices +against degree `degree ^ m` — and `lam ^ m ≤ 1 / 5` once `m` is large enough. + +Applied to `randExpander`, this shows a `ZigZagBase` exists. + +## Main definitions + +- `Complexity.ExpanderFamily.fifthExp` — a power taking the bound below a fifth +- `Complexity.ExpanderFamily.toZigZagBase` — the base graph + +## Main results + +- `Complexity.nonempty_zigZagBase` — a base graph exists +- `Complexity.nonempty_sizedExpanderFamily` — so the tower's size-flexible + family exists too +-/ + +@[expose] public section + +namespace Complexity + +namespace ExpanderFamily + +variable (E : ExpanderFamily) + +theorem exists_pow_le_fifth : ∃ m : ℕ, E.lam ^ m ≤ 1 / 5 := by + obtain ⟨m, hm⟩ := exists_pow_lt_of_lt_one (show (0 : ℝ) < 1 / 5 by norm_num) E.lam_lt_one + exact ⟨m, hm.le⟩ + +/-- A power taking the family's bound to at most a fifth. -/ +noncomputable def fifthExp : ℕ := Classical.choose E.exists_pow_le_fifth + +theorem pow_fifthExp_le : E.lam ^ E.fifthExp ≤ 1 / 5 := + Classical.choose_spec E.exists_pow_le_fifth + +/-- The size at which the powered member has as many vertices as the fourth +power of its degree. -/ +noncomputable def baseOrder : ℕ := E.degree ^ (4 * E.fifthExp) + +/-- **A base for the zig-zag tower.** -/ +noncomputable def toZigZagBase : ZigZagBase where + base := (E.graph E.baseOrder).power E.fifthExp + card_eq := by + have hV : Fintype.card ((E.graph E.baseOrder).power E.fifthExp).V = E.baseOrder := + Fintype.card_fin _ + rw [hV, RegGraph.deg_power, deg_graph, baseOrder, ← pow_mul, Nat.mul_comm] + lam := E.lam ^ E.fifthExp + lam_nonneg := pow_nonneg E.lam_nonneg _ + lam_le := E.pow_fifthExp_le + spectral := RegGraph.spectralBound_power _ (E.spectral_graph _) _ + +theorem one_le_fifthExp : 1 ≤ E.fifthExp := by + by_contra h + have h0 : E.fifthExp = 0 := by omega + have := E.pow_fifthExp_le + rw [h0, pow_zero] at this + norm_num at this + +@[simp] theorem deg_toZigZagBase : E.toZigZagBase.base.deg = E.degree ^ E.fifthExp := by + show ((E.graph E.baseOrder).power E.fifthExp).deg = _ + rw [RegGraph.deg_power, deg_graph] + +theorem one_lt_deg_toZigZagBase (h : 1 < E.degree) : 1 < E.toZigZagBase.base.deg := by + rw [deg_toZigZagBase] + exact Nat.one_lt_pow (by have := E.one_le_fifthExp; omega) h + +/-- **The tower's size-flexible family, from any expander family.** -/ +noncomputable def toSizedFamily (h : 1 < E.degree) : SizedExpanderFamily := + E.toZigZagBase.toSized (E.one_lt_deg_toZigZagBase h) + +end ExpanderFamily + +/-- **A base graph for the tower exists.** -/ +theorem nonempty_zigZagBase : Nonempty ZigZagBase := + ⟨randExpander.toZigZagBase⟩ + +/-- **A size-flexible family exists.** -/ +theorem nonempty_sizedExpanderFamily : Nonempty SizedExpanderFamily := + ⟨randExpander.toSizedFamily (by show 1 < 120; norm_num)⟩ + +end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean b/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean new file mode 100644 index 00000000..4ba9cb98 --- /dev/null +++ b/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ +module +public import Complexitylib.Classes.PCP.Internal.ZigZag +public import Complexitylib.Classes.PCP.Internal.Power +public import Complexitylib.Classes.PCP.Internal.ExpanderAssemble + +/-! +# The zig-zag tower + +One graph of constant size generates an infinite family. Square a member — the +degree becomes the fourth power of the base's, exactly the number of the base's +vertices — and zig-zag with the base: the vertex count is multiplied by that +same number while the degree drops back to the base's squared. + +The spectral bookkeeping is what makes the recursion close. If the base has +bound `lam ≤ 1/5` and a member has bound `2/5`, squaring gives `4/25` and the +zig-zag estimate `λ(G ⓩ H) ≤ λ(G) + λ(H) + λ(H)²` gives at most +`4/25 + 1/5 + 1/25 = 2/5`, the invariant again. + +Only the base is non-constructive; the recursion itself is an algorithm, which +is why this yields an expander family a machine can build. + +## Main definitions + +- `Complexity.ZigZagBase` — a constant-size graph to build from +- `Complexity.TowerStep` — a member of the family, with its invariants +- `Complexity.towerSucc` — one round of squaring and zig-zagging + +## Main results + +- `Complexity.towerSucc` carries the invariants forward, by construction +- `Complexity.ZigZagBase.order_tower` — the sizes are the powers of `deg ^ 4` +-/ + +@[expose] public section + +namespace Complexity + +/-- The seed of the tower: a graph whose vertices number the fourth power of its +degree, with a spectral bound of at most a fifth. -/ +structure ZigZagBase where + /-- The graph itself. -/ + base : RegGraph + /-- Its vertices number the fourth power of its degree. -/ + card_eq : Fintype.card base.V = base.deg ^ 4 + /-- Its spectral bound. -/ + lam : ℝ + /-- The bound is nonnegative. -/ + lam_nonneg : 0 ≤ lam + /-- And at most a fifth, which is what makes the recursion close. -/ + lam_le : lam ≤ 1 / 5 + /-- The bound holds. -/ + spectral : base.SpectralBound lam + +namespace ZigZagBase + +variable (B : ZigZagBase) + +/-- A member of the family: its degree is the base's squared, and its spectral +bound is two fifths. -/ +structure TowerStep where + /-- The graph. -/ + graph : RegGraph + /-- Its degree is the base's squared. -/ + deg_eq : graph.deg = B.base.deg ^ 2 + /-- Its spectral bound. -/ + spec : graph.SpectralBound (2 / 5) + +/-- Squaring a member makes its degree match the base's vertex count. -/ +theorem card_sq_eq (T : B.TowerStep) : + Fintype.card B.base.V = Fintype.card (T.graph.power 2).D := by + have h1 : Fintype.card (T.graph.power 2).D = (T.graph.power 2).deg := rfl + rw [h1, RegGraph.deg_power, T.deg_eq, B.card_eq] + ring + +/-- So the base's vertices name the squared member's darts. -/ +noncomputable def stepEquiv (T : B.TowerStep) : B.base.V ≃ (T.graph.power 2).D := + Fintype.equivOfCardEq (B.card_sq_eq T) + +/-- **One round of the tower**, against a chosen naming of the base's vertices +by the squared member's darts. The tower itself takes the arbitrary naming +`stepEquiv`; an explicitly encoded tower supplies its own. -/ +noncomputable def towerSuccOf (T : B.TowerStep) (e : B.base.V ≃ (T.graph.power 2).D) : + B.TowerStep where + graph := RegGraph.zigzag (T.graph.power 2) B.base e + deg_eq := by + rw [RegGraph.deg_zigzag] + ring + spec := by + have hsq : (T.graph.power 2).SpectralBound ((2 / 5) ^ 2) := + RegGraph.spectralBound_power T.graph T.spec 2 + have hzz := RegGraph.spectralBound_zigzag (T.graph.power 2) B.base e + hsq B.spectral (by norm_num) B.lam_nonneg + have h5 := B.lam_le + have h0 := B.lam_nonneg + refine hzz.mono ?_ ?_ + · nlinarith [h0] + · nlinarith [h5, h0] + +/-- **One round of the tower.** -/ +noncomputable def towerSucc (T : B.TowerStep) : B.TowerStep := + B.towerSuccOf T (B.stepEquiv T) + +@[simp] theorem graph_towerSucc (T : B.TowerStep) : + (B.towerSucc T).graph = RegGraph.zigzag (T.graph.power 2) B.base (B.stepEquiv T) := rfl + +/-- The first member: the base, squared. -/ +noncomputable def towerZero : B.TowerStep where + graph := B.base.power 2 + deg_eq := by + rw [RegGraph.deg_power] + spec := by + have hsq : (B.base.power 2).SpectralBound (B.lam ^ 2) := + RegGraph.spectralBound_power B.base B.spectral 2 + refine hsq.mono (by positivity) ?_ + have h5 := B.lam_le + have h0 := B.lam_nonneg + nlinarith [h5, h0] + +/-- **The tower.** -/ +noncomputable def tower : ℕ → B.TowerStep + | 0 => towerZero B + | k + 1 => towerSucc B (tower k) + +theorem deg_tower (k : ℕ) : (tower B k).graph.deg = B.base.deg ^ 2 := + (tower B k).deg_eq + +theorem spectral_tower (k : ℕ) : (tower B k).graph.SpectralBound (2 / 5) := + (tower B k).spec + +/-- **The sizes of the tower.** Each round multiplies the vertex count by the +base's vertex count, so the `k`-th member has `(deg ^ 4) ^ (k + 1)` vertices. -/ +theorem order_tower (k : ℕ) : + (tower B k).graph.order = (B.base.deg ^ 4) ^ (k + 1) := by + induction k with + | zero => + show (B.base.power 2).order = _ + rw [RegGraph.order_power] + show Fintype.card B.base.V = _ + rw [B.card_eq] + ring + | succ m ih => + show (RegGraph.zigzag ((tower B m).graph.power 2) B.base + (B.stepEquiv (tower B m))).order = _ + rw [RegGraph.order_zigzag, RegGraph.order_power, RegGraph.deg_power, + deg_tower, ih] + ring + +/-- The sizes grow, so every vertex count is eventually passed. -/ +theorem exists_order_ge (hd : 1 < B.base.deg) (n : ℕ) : + ∃ k : ℕ, n ≤ (tower B k).graph.order := by + refine ⟨n, ?_⟩ + rw [order_tower] + have h1 : 2 ≤ B.base.deg ^ 4 := by + calc 2 ≤ B.base.deg := hd + _ = B.base.deg ^ 1 := (pow_one _).symm + _ ≤ B.base.deg ^ 4 := Nat.pow_le_pow_right (by omega) (by norm_num) + calc n ≤ 2 ^ n := Nat.le_of_lt (Nat.lt_two_pow_self) + _ ≤ (B.base.deg ^ 4) ^ n := Nat.pow_le_pow_left h1 n + _ ≤ (B.base.deg ^ 4) ^ (n + 1) := + Nat.pow_le_pow_right (by omega) (by omega) + +end ZigZagBase + +end Complexity diff --git a/scripts/AxiomGuard.lean b/scripts/AxiomGuard.lean index bd5a84cf..94585378 100644 --- a/scripts/AxiomGuard.lean +++ b/scripts/AxiomGuard.lean @@ -83,6 +83,10 @@ def headlineTheorems : List Name := [ `Complexity.PSPACE_eq_NPSPACE, -- the easy half of Shamir's theorem `Complexity.IP_subset_PSPACE, + -- the PCP theorem + `Complexity.PCP_theorem, + `Complexity.exists_pcp_of_mem_NP, + `Complexity.PCP_subset_NP, -- Circuit lower and upper bounds `Complexity.shannon_lower_bound_circuit, `Complexity.shannon_sizeComplexity, From fde2ac3549c5f29381adc0e0d4827492aac0cfad Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Fri, 28 Aug 2026 21:54:12 -0700 Subject: [PATCH 20/24] review file --- Complexitylib/Classes/PCP/Defs.lean | 2 -- 1 file changed, 2 deletions(-) diff --git a/Complexitylib/Classes/PCP/Defs.lean b/Complexitylib/Classes/PCP/Defs.lean index 99c93608..b72d8fcf 100644 --- a/Complexitylib/Classes/PCP/Defs.lean +++ b/Complexitylib/Classes/PCP/Defs.lean @@ -17,8 +17,6 @@ public import Complexitylib.Encoding.DataEncode /-! # Probabilistically checkable proofs: definitions -⚠️ Unreviewed by Bolton - `PCP r q` is the class of languages with a probabilistically checkable proof system: a polynomial-time verifier that, on an input of length `n`, flips `r n` coins, reads at most `q n` bits of a proof string, always accepts a From 9b50bcf108802befbca14b7386626999cd4753b5 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Fri, 28 Aug 2026 22:12:30 -0700 Subject: [PATCH 21/24] golf proof --- Complexitylib/Classes/PCP.lean | 10 +++------- Complexitylib/Classes/PCP/Internal/AlgPCP.lean | 8 ++++---- 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/Complexitylib/Classes/PCP.lean b/Complexitylib/Classes/PCP.lean index 8217d5e9..ecbb9f52 100644 --- a/Complexitylib/Classes/PCP.lean +++ b/Complexitylib/Classes/PCP.lean @@ -41,12 +41,8 @@ theorem PCP_theorem : NP = ⋃ (r : ℕ → ℕ) (_ : r =O Nat.log 2) (_ : Constructible r) (q : ℕ → ℕ) (_ : q =O fun _ => 1), PCP r q := by ext L - simp only [Set.mem_iUnion] - constructor - · intro hL - obtain ⟨r, qc, hrlog, hrc, hq1, hmem⟩ := exists_pcp_of_mem_NP hL - exact ⟨r, hrlog, hrc, qc, hq1, hmem⟩ - · rintro ⟨r, hrlog, hrc, qc, hq1, hmem⟩ - exact PCP_subset_NP hrc hrlog hq1 hmem + simp only [Set.mem_iUnion, exists_prop] + exact ⟨exists_pcp_of_mem_NP, + fun ⟨_, hrlog, hrc, _, hq1, hmem⟩ => PCP_subset_NP hrc hrlog hq1 hmem⟩ end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgPCP.lean b/Complexitylib/Classes/PCP/Internal/AlgPCP.lean index 3cd08e92..53b71df5 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgPCP.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgPCP.lean @@ -110,8 +110,8 @@ open scoped Complexity in /-- **Every `NP` language has a PCP verifier** with logarithmically many coins and constantly many queries. -/ theorem exists_pcp_of_mem_NP {L : Language} (hL : L ∈ NP) : - ∃ r qc : ℕ → ℕ, r =O (fun n => Nat.log 2 n) ∧ Constructible r - ∧ qc =O (fun _ => 1) ∧ L ∈ PCP r qc := by + ∃ r : ℕ → ℕ, r =O (fun n => Nat.log 2 n) ∧ Constructible r + ∧ ∃ qc : ℕ → ℕ, qc =O (fun _ => 1) ∧ L ∈ PCP r qc := by classical obtain ⟨E, Φ, hEfp, hEeq, h3, hLiff⟩ := exists_reduction_cnf hL obtain ⟨pad0, q0, hpad0fp, hmark0, hq0, hle0⟩ := exists_padRuler hEfp 3 @@ -196,8 +196,8 @@ theorem exists_pcp_of_mem_NP {L : Language} (hL : L ∈ NP) : (fun x => by rw [hNE x]; exact two_pow_gapCoins_le (hqpos x.length)) (Dinur.amplifier (algF.toFamily algHd)).gap_pos (Dinur.amplifier (algF.toFamily algHd)).gap_le_one hcomp hsound - refine ⟨fun n => 2 ^ j * gapCoins q n, - fun _ => 2 ^ j * (2 * (gapAlg algF algHd E padU hgap).width), ?_, ?_, ?_, hj⟩ + refine ⟨fun n => 2 ^ j * gapCoins q n, ?_, ?_, + fun _ => 2 ^ j * (2 * (gapAlg algF algHd E padU hgap).width), ?_, hj⟩ · exact BigO.const_mul_left _ (gapCoins_bigO_log q) · exact constructible_pow_mul ht j · have h := BigO.const_mul_left (2 ^ j * (2 * (gapAlg algF algHd E padU hgap).width)) From fb60a3187ab7f7a79b1b8d7d2a533f39dafc4b33 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Sat, 29 Aug 2026 10:45:24 -0700 Subject: [PATCH 22/24] golfing pass --- .../Containments/Internal/FPBridge.lean | 4 -- Complexitylib/Classes/P/Cobham.lean | 4 ++ Complexitylib/Classes/PCP/Defs.lean | 11 +--- .../Classes/PCP/Internal/AlgEdge.lean | 1 - .../Classes/PCP/Internal/AlgFamily.lean | 9 ++- .../Classes/PCP/Internal/AlgGraph.lean | 2 - .../Classes/PCP/Internal/AlgKeyFn.lean | 4 +- .../Classes/PCP/Internal/AlgKilled.lean | 2 +- .../Classes/PCP/Internal/AlgLevel.lean | 3 +- .../Classes/PCP/Internal/AlgLog.lean | 5 +- .../Classes/PCP/Internal/AlgPosNum.lean | 58 +++++-------------- .../Classes/PCP/Internal/AlgPreRot.lean | 11 ---- .../Classes/PCP/Internal/AlgPreprocess.lean | 3 +- .../Classes/PCP/Internal/AlphabetLift.lean | 2 +- .../Classes/PCP/Internal/BinToUnary.lean | 2 - .../Classes/PCP/Internal/BitwiseFP.lean | 4 +- .../Classes/PCP/Internal/CNFCount.lean | 2 +- .../Classes/PCP/Internal/CNFSegment.lean | 8 +-- .../Classes/PCP/Internal/CNFTokens.lean | 2 +- .../Classes/PCP/Internal/CSPVerifier.lean | 11 ++-- .../Classes/PCP/Internal/Cheeger.lean | 4 +- .../PCP/Internal/CloudDisagreement.lean | 4 -- .../Classes/PCP/Internal/CoinEnum.lean | 1 - .../Classes/PCP/Internal/Compose.lean | 1 - .../Classes/PCP/Internal/ConsistencyLang.lean | 20 +++---- .../Classes/PCP/Internal/ConstraintGraph.lean | 1 - .../Classes/PCP/Internal/CubeBlocks.lean | 7 --- .../Classes/PCP/Internal/DartCorrelation.lean | 2 - .../Classes/PCP/Internal/DataScan.lean | 4 +- .../Classes/PCP/Internal/DataScanSpec.lean | 4 +- .../Classes/PCP/Internal/DegreeReduction.lean | 1 - .../PCP/Internal/DegreeReductionSound.lean | 1 - Complexitylib/Classes/PCP/Internal/Dinur.lean | 2 - .../Classes/PCP/Internal/EdgeExpansion.lean | 2 - .../Classes/PCP/Internal/Expander.lean | 1 - .../PCP/Internal/ExpanderAssemble.lean | 5 -- .../Classes/PCP/Internal/ExpanderMerge.lean | 5 +- .../Classes/PCP/Internal/ExpanderPad.lean | 2 - .../Classes/PCP/Internal/ExpanderRandom.lean | 3 - .../Classes/PCP/Internal/ExpanderizeCSP.lean | 3 - .../Classes/PCP/Internal/FamilyFin.lean | 2 - .../Classes/PCP/Internal/GapTheorem.lean | 3 - .../Classes/PCP/Internal/Hadamard.lean | 12 ++-- .../Classes/PCP/Internal/KilledCSP.lean | 1 - .../PCP/Internal/KilledFirstMoment.lean | 1 - .../Classes/PCP/Internal/KilledWalk.lean | 4 +- .../Classes/PCP/Internal/ListEncode.lean | 4 +- .../Classes/PCP/Internal/MaxLoop.lean | 4 +- .../Classes/PCP/Internal/MergeGen.lean | 3 +- .../Classes/PCP/Internal/Mixing.lean | 5 +- .../Classes/PCP/Internal/NatEncode.lean | 10 ++-- .../Classes/PCP/Internal/NumEnc.lean | 3 - .../Classes/PCP/Internal/PCPtoSAT.lean | 3 +- .../Classes/PCP/Internal/PermArith.lean | 2 - .../Classes/PCP/Internal/PermCount.lean | 1 - .../Classes/PCP/Internal/PermGraph.lean | 2 - .../Classes/PCP/Internal/PosScan.lean | 4 +- .../Classes/PCP/Internal/PositionsFP.lean | 7 +-- .../Classes/PCP/Internal/PowerCSP.lean | 4 +- .../Classes/PCP/Internal/PoweringBound.lean | 16 +---- .../Classes/PCP/Internal/Preprocess.lean | 2 - .../Classes/PCP/Internal/RegCSP.lean | 3 +- .../PCP/Internal/SizedExpanderize.lean | 4 -- .../Classes/PCP/Internal/SquareVerifier.lean | 12 ++-- .../Classes/PCP/Internal/SubsetNP.lean | 5 +- .../Classes/PCP/Internal/SubsetNPFinal.lean | 2 +- .../PCP/Internal/ThreeSATReduction.lean | 3 - .../Classes/PCP/Internal/TowerFamily.lean | 3 - .../Classes/PCP/Internal/TowerFin.lean | 3 +- .../Classes/PCP/Internal/TowerTable.lean | 3 - .../Classes/PCP/Internal/UnaryDivMod.lean | 12 ++-- Complexitylib/Classes/PCP/Internal/Union.lean | 5 +- .../Classes/PCP/Internal/VerifierLang.lean | 8 +-- .../Classes/PCP/Internal/WalkDart.lean | 10 +--- .../Classes/PCP/Internal/WalkSplit.lean | 3 +- .../Classes/PCP/Internal/ZigZag.lean | 7 +-- 76 files changed, 115 insertions(+), 282 deletions(-) diff --git a/Complexitylib/Classes/Containments/Internal/FPBridge.lean b/Complexitylib/Classes/Containments/Internal/FPBridge.lean index 2a3471bf..1f5ae2df 100644 --- a/Complexitylib/Classes/Containments/Internal/FPBridge.lean +++ b/Complexitylib/Classes/Containments/Internal/FPBridge.lean @@ -94,10 +94,6 @@ theorem binFn_mem_FP {g : List Bool → List Bool → List Bool} /-! ## The rules -/ -/-- Every constant function is polynomial-time. -/ -theorem constFn_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := - CobhamFP_subset_FP (Cobham.const c) - /-- Dropping a prefix at another value's width is polynomial-time. -/ theorem dropLenFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : (fun z => (b z).drop (a z).length) ∈ FP := diff --git a/Complexitylib/Classes/P/Cobham.lean b/Complexitylib/Classes/P/Cobham.lean index 9acc095e..b3237d46 100644 --- a/Complexitylib/Classes/P/Cobham.lean +++ b/Complexitylib/Classes/P/Cobham.lean @@ -79,6 +79,10 @@ arity one. -/ theorem CobhamFP_subset_FP : CobhamFP ⊆ FP := Cobham.CobhamFP_subset_FP_of_FPn +/-- Every constant function is polynomial-time. -/ +theorem constFn_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := + CobhamFP_subset_FP (Cobham.const c) + /-- Cobham's algebra is complete for polynomial time: every polynomial-time computable function belongs to the algebra. diff --git a/Complexitylib/Classes/PCP/Defs.lean b/Complexitylib/Classes/PCP/Defs.lean index b72d8fcf..d31e42a5 100644 --- a/Complexitylib/Classes/PCP/Defs.lean +++ b/Complexitylib/Classes/PCP/Defs.lean @@ -6,6 +6,7 @@ Authors: Bolton Bailey module public import Complexitylib.Classes.EventProb public import Complexitylib.Classes.NP +public import Complexitylib.Classes.P.Cobham public import Complexitylib.Classes.P.Composition public import Complexitylib.Classes.P.Cobham.Internal.ConsBit public import Complexitylib.Classes.P.Cobham.Internal.FstBlock @@ -131,21 +132,13 @@ def PCP (r q : ℕ → ℕ) : Set Language := /-! ## Elementary properties -/ -/-- Every constant string function is polynomial-time. -/ -private theorem const_mem_FP (c : List Bool) : (fun _ : List Bool => c) ∈ FP := by - induction c with - | nil => exact Cobham.const_nil_mem_FP - | cons b c ih => - have := mem_FP_comp ih (Cobham.cons_mem_FP b) - simpa [Function.comp] using this - /-- The verifier that reads no bits of the proof, ignores its coins, and decides `L` on the input it recovers from the encoded view. -/ private noncomputable def inputVerifier (L : Language) (hL : L ∈ P) : PCPVerifier where positions _ _ := [] positions_mem := ⟨fun _ => DataEncode.bitstringEncode ([] : List ℕ), - const_mem_FP _, fun _ _ => rfl⟩ + constFn_mem_FP _, fun _ _ => rfl⟩ verdict := (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L verdict_mem := by refine mem_P_preimage ?_ hL diff --git a/Complexitylib/Classes/PCP/Internal/AlgEdge.lean b/Complexitylib/Classes/PCP/Internal/AlgEdge.lean index 47c1e93b..9ed49812 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgEdge.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgEdge.lean @@ -339,7 +339,6 @@ theorem stepFn_mem_FP (F : FinBase) (pol : Polynomial ℕ) (r : Round) (marks_mem_FP (mulC_mem_FP (posCount_mem_FP Cobham.sndBlock_mem_FP) edgeF)) (edgeRule_mem_FP F pol r posF cardB cardN cardNN hQ hD hZ hC dflt encβ) -set_option maxHeartbeats 1000000 in /-- **One round of amplification, computed.** The algorithm's output is the graph the round produces. -/ theorem stepFn_eq (F : FinBase) (pol : Polynomial ℕ) (hd : 1 < F.deg) diff --git a/Complexitylib/Classes/PCP/Internal/AlgFamily.lean b/Complexitylib/Classes/PCP/Internal/AlgFamily.lean index b509a3f6..9dc5b343 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgFamily.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgFamily.lean @@ -230,22 +230,21 @@ theorem famRotFn_eq (hd : 1 < F.deg) (n v i : ℕ) (hn : 0 < n) rw [hT, hidx, F.tableFst_table hbound, F.tableSnd_table hbound, show F.deg ^ 2 = F.fitD from rfl, mul_add_div_of_lt hdpos (Nat.mod_lt _ hdpos), mul_add_mod_of_lt (Nat.mod_lt _ hdpos)] - congr 1 + refine congrArg₂ pair ?_ ?_ · rw [marks_eq, modFn2_eq (by rw [hrep]; exact hn), List.length_replicate, hrep, List.length_replicate] · rw [marks_eq, List.length_append, List.length_replicate, length_mulC, divFn2_eq (by rw [hrep]; exact hn), List.length_replicate, hrep, List.length_replicate] - congr 1 - ring + exact congrArg (List.replicate · true) (by ring) · rw [if_neg h2, ifLtLen_neg (by rw [hlift, hN]; exact h2)] - congr 1 + refine congrArg₂ pair ?_ ?_ · rw [marks_eq, List.length_replicate] · rw [marks_eq, List.length_replicate] · rw [if_neg h1, ifLtLen_neg (by rw [List.length_replicate, length_mulLen, hm, List.length_replicate] exact h1)] - congr 1 + refine congrArg₂ pair ?_ ?_ · rw [marks_eq, List.length_replicate] · rw [marks_eq, List.length_replicate] diff --git a/Complexitylib/Classes/PCP/Internal/AlgGraph.lean b/Complexitylib/Classes/PCP/Internal/AlgGraph.lean index db43e8bf..762d6690 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgGraph.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgGraph.lean @@ -149,8 +149,6 @@ theorem length_encGraph_le (G : ConstraintGraph α) : obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp he rw [length_edgeRecs] at hi rw [getElem_edgeRecs G i hi, ← encTriple_eq, length_encTriple] - have h1 := (G.tail ⟨i, hi⟩).isLt - have h2 := (G.head ⟨i, hi⟩).isLt have h3 := codeOfRel_lt (G.rel ⟨i, hi⟩) omega · rw [List.length_map, length_edgeRecs, smul_eq_mul] diff --git a/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean b/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean index b8a3ddeb..e42d86a7 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean @@ -316,7 +316,7 @@ theorem parBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) = List.replicate (NumEnc.enc (stepKeyOf G (F.toFamily hd) v x B z i).par) true := by have hstop := stopBlk_eq r hd G hq v x hg hv hdart rw [marks_eq] - congr 1 + refine congrArg (List.replicate · true) ?_ refine length_digitSum_eq_enc (X := Fin 2) (stepKeyOf G (F.toFamily hd) v x B z i).par _ w fun j hj => ?_ rw [parDigit, hstop, hdeg, hP] @@ -367,7 +367,7 @@ theorem codeBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) = List.replicate (NumEnc.enc (stepKeyOf G (F.toFamily hd) v x B z i).code) true := by have hstop := stopBlk_eq r hd G hq v x hg hv hdart rw [marks_eq] - congr 1 + refine congrArg (List.replicate · true) ?_ rw [hC] refine length_digitSum_eq_enc (X := Fin (Fintype.card (α → α → Bool))) (stepKeyOf G (F.toFamily hd) v x B z i).code _ w fun j hj => ?_ diff --git a/Complexitylib/Classes/PCP/Internal/AlgKilled.lean b/Complexitylib/Classes/PCP/Internal/AlgKilled.lean index 5edba267..77dabf14 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgKilled.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgKilled.lean @@ -536,7 +536,7 @@ theorem killedRotFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (T q v s c : walkFn_eq F pol hd G v s hv hpc hpe, marks_revSum_eq hd G T v s _ hv hpc hpe, marks_eq, length_mulC, List.length_replicate, hco, ConstraintGraph.killedRotNum] dsimp only - congr 1 + refine congrArg (pair _) ?_ rw [← List.replicate_add, G.killedRevNum_eq_revAtNum] end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgLevel.lean b/Complexitylib/Classes/PCP/Internal/AlgLevel.lean index 2d0b10be..4378b7e1 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgLevel.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgLevel.lean @@ -140,8 +140,7 @@ theorem levelAfter_stable (d n : ℕ) (p : ℕ × ℕ) (j : ℕ) (h : 2 * n ≤ | zero => rfl | succ i ih => have hji : j + (i + 1) = (j + i) + 1 := by omega - rw [hji, levelAfter, ih] - rw [if_neg (by omega)] + rw [hji, levelAfter, ih, if_neg (by omega)] /-- The loop never overshoots by more than a factor of `d`. -/ theorem levelAfter_snd_le (d n : ℕ) : diff --git a/Complexitylib/Classes/PCP/Internal/AlgLog.lean b/Complexitylib/Classes/PCP/Internal/AlgLog.lean index ec138c84..dbe56f51 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgLog.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgLog.lean @@ -132,8 +132,7 @@ theorem rulerLen_bigO_log {N : ℕ → ℕ} {A B : ℕ} (hN : ∀ n, N n ≤ A * le_trans (hN n) (Nat.mul_le_mul hA hpow) have h2 : 2 ^ (Nat.log 2 A + 3 + (Nat.log 2 n + 1) * B) = 4 * (2 ^ (Nat.log 2 A + 1) * 2 ^ ((Nat.log 2 n + 1) * B)) := by - rw [← pow_add] - rw [show (4 : ℕ) = 2 ^ 2 from rfl, ← pow_add] + rw [← pow_add, show (4 : ℕ) = 2 ^ 2 from rfl, ← pow_add] congr 1 ring have h3 : 0 < 2 ^ (Nat.log 2 A + 1) * 2 ^ ((Nat.log 2 n + 1) * B) := @@ -176,8 +175,6 @@ theorem logFold_eq (bound : ℕ) : ∀ z : List Bool, 4 * z.length + 4 ≤ bound | cons b t ih => intro hb have hbt : 4 * t.length + 4 ≤ bound := by simp at hb ⊢; omega - have hpow := two_pow_rulerLen_le (t.length + 1) - have hlen := rulerLen_le (t.length + 1) rw [Cobham.recFoldClamp] simp only [Bool.cond_self] rw [ih hbt, logStep] diff --git a/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean b/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean index e8f4f785..9539dd20 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgPosNum.lean @@ -65,8 +65,8 @@ noncomputable def blockNum (p : R.Dart) : ReadIdx → ℕ | .f1x | .f1y | .f1s | .g2x | .g2y | .g2s | .c3cQ | .c3tQ | .c3cX | .c3xX | .c3cY | .c3yY | .k4qG | .k4tG | .k4cF | .k4lF | .i5c | .i5b | .i6c | .i6b => NumEnc.enc p -/-- The number of the cube a read's position names inside its block. -/ -noncomputable def cubeNum (p : R.Dart) (z : Cube (ROf B)) : ReadIdx → ℕ +/-- The cube a read names, from the satisfying set alone. -/ +noncomputable def cubeOfSet (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) : ReadIdx → ℕ | .f1x => NumEnc.enc (leftBlock (blk1 z)) | .f1y => NumEnc.enc (rightBlock (blk1 z)) | .f1s => NumEnc.enc (leftBlock (blk1 z) + rightBlock (blk1 z)) @@ -80,10 +80,10 @@ noncomputable def cubeNum (p : R.Dart) (z : Cube (ROf B)) : ReadIdx → ℕ | .c3cY => NumEnc.enc (cY (blk3 z)) | .c3yY => NumEnc.enc (qY (blk3 z) + cY (blk3 z)) | .k4qG => NumEnc.enc (rightBlock (rightBlock (blk4 z))) - | .k4tG => NumEnc.enc ((QuadConstraint.combine (oneHotSystem (R.satSet enc p)) + | .k4tG => NumEnc.enc ((QuadConstraint.combine (oneHotSystem S) (leftBlock (blk4 z))).quad + rightBlock (rightBlock (blk4 z))) | .k4cF => NumEnc.enc (leftBlock (rightBlock (blk4 z))) - | .k4lF => NumEnc.enc ((QuadConstraint.combine (oneHotSystem (R.satSet enc p)) + | .k4lF => NumEnc.enc ((QuadConstraint.combine (oneHotSystem S) (leftBlock (blk4 z))).lin + leftBlock (rightBlock (blk4 z))) | .i5r => NumEnc.enc (leftBlock (blk5 z)) | .i5c => NumEnc.enc (rightBlock (blk5 z)) @@ -92,6 +92,10 @@ noncomputable def cubeNum (p : R.Dart) (z : Cube (ROf B)) : ReadIdx → ℕ | .i6c => NumEnc.enc (rightBlock (blk6 z)) | .i6b => NumEnc.enc (basisVec (inHead B (leftBlock (blk6 z))) + rightBlock (blk6 z)) +/-- The number of the cube a read's position names inside its block. -/ +noncomputable def cubeNum (p : R.Dart) (z : Cube (ROf B)) : ReadIdx → ℕ := + cubeOfSet (R.satSet enc p) z + /-- The number a kind, a block and a cube make: encoding blocks first, then the linear tables, then the quadratic ones. -/ def posNum (cardV cardD cardB cardN cardNN k w c : ℕ) : ℕ := @@ -135,33 +139,6 @@ theorem val_head_toGraph_compose (k : Fin (Fintype.card (R.compose enc).Edge)) : ((R.compose enc).edgeOf k).2.2) := by rw [MultiTest.val_head_toGraph, enc_pos_compose] -/-- The cube a read names, from the satisfying set alone. -/ -noncomputable def cubeOfSet (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) : ReadIdx → ℕ - | .f1x => NumEnc.enc (leftBlock (blk1 z)) - | .f1y => NumEnc.enc (rightBlock (blk1 z)) - | .f1s => NumEnc.enc (leftBlock (blk1 z) + rightBlock (blk1 z)) - | .g2x => NumEnc.enc (leftBlock (blk2 z)) - | .g2y => NumEnc.enc (rightBlock (blk2 z)) - | .g2s => NumEnc.enc (leftBlock (blk2 z) + rightBlock (blk2 z)) - | .c3cQ => NumEnc.enc (cQ (blk3 z)) - | .c3tQ => NumEnc.enc (tensor (qX (blk3 z)) (qY (blk3 z)) + cQ (blk3 z)) - | .c3cX => NumEnc.enc (cX (blk3 z)) - | .c3xX => NumEnc.enc (qX (blk3 z) + cX (blk3 z)) - | .c3cY => NumEnc.enc (cY (blk3 z)) - | .c3yY => NumEnc.enc (qY (blk3 z) + cY (blk3 z)) - | .k4qG => NumEnc.enc (rightBlock (rightBlock (blk4 z))) - | .k4tG => NumEnc.enc ((QuadConstraint.combine (oneHotSystem S) - (leftBlock (blk4 z))).quad + rightBlock (rightBlock (blk4 z))) - | .k4cF => NumEnc.enc (leftBlock (rightBlock (blk4 z))) - | .k4lF => NumEnc.enc ((QuadConstraint.combine (oneHotSystem S) - (leftBlock (blk4 z))).lin + leftBlock (rightBlock (blk4 z))) - | .i5r => NumEnc.enc (leftBlock (blk5 z)) - | .i5c => NumEnc.enc (rightBlock (blk5 z)) - | .i5b => NumEnc.enc (basisVec (inTail B (leftBlock (blk5 z))) + rightBlock (blk5 z)) - | .i6r => NumEnc.enc (leftBlock (blk6 z)) - | .i6c => NumEnc.enc (rightBlock (blk6 z)) - | .i6b => NumEnc.enc (basisVec (inHead B (leftBlock (blk6 z))) + rightBlock (blk6 z)) - /-- The test's verdict, from the satisfying set alone. -/ noncomputable def checkOfSet (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) (rd : ReadIdx → ZMod 2) : Bool := @@ -170,8 +147,7 @@ noncomputable def checkOfSet (S : Finset (Cube (kOf B))) (z : Cube (ROf B)) omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in /-- **The cube depends on the satisfying set alone.** -/ theorem cubeNum_eq_cubeOfSet (p : R.Dart) (z : Cube (ROf B)) (i : ReadIdx) : - R.cubeNum enc p z i = cubeOfSet (R.satSet enc p) z i := by - cases i <;> rfl + R.cubeNum enc p z i = cubeOfSet (R.satSet enc p) z i := rfl omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in /-- **And so does the verdict.** -/ @@ -179,7 +155,7 @@ theorem check_eq_checkOfSet (p : R.Dart) (z : Cube (ROf B)) : (R.compose enc).check p z = checkOfSet (R.satSet enc p) z := rfl omit [DecidableEq β] [Nonempty β] in -set_option maxHeartbeats 2000000 in +set_option maxHeartbeats 800000 in /-- **An edge's data and all three of its numbers**, in one package: a caller never has to spell the composed system out, nor match anything against it. -/ theorem edge_facts (e : ℕ) (he : e < (R.compose enc).toGraph.numEdges) : @@ -195,13 +171,11 @@ theorem edge_facts (e : ℕ) (he : e < (R.compose enc).toGraph.numEdges) : ∧ (R.compose enc).toGraph.rel ⟨e, he⟩ = MultiTest.relOfCheck ((R.compose enc).check p z) i := by obtain ⟨p, z, i, hp, hz, hi, hsplit⟩ := R.edge_data B enc e he - subst hp - subst hz - subst hi - refine ⟨_, _, _, hsplit, (MultiTest.tailNum_eq _ ⟨e, he⟩).symm, ?_, - MultiTest.rel_toGraph_eq _ ⟨e, he⟩⟩ - rw [MultiTest.val_head_toGraph, enc_pos_compose] - rfl + refine ⟨p, z, i, hsplit, (MultiTest.tailNum_eq _ ⟨e, he⟩).symm, ?_, ?_⟩ + · rw [hp, hz, hi, MultiTest.val_head_toGraph, enc_pos_compose] + rfl + · rw [hp, hz, hi] + exact MultiTest.rel_toGraph_eq _ _ /-! ### Everything depends on the dart's constraint alone -/ @@ -222,7 +196,7 @@ theorem cubeNum_congr {β' : Type} [Fintype β'] [DecidableEq β'] [Nonempty β' (p : R.Dart) (p' : R'.Dart) (z : Cube (ROf B)) (i : ReadIdx) (h : R.satSet enc p = R'.satSet enc' p') : R.cubeNum enc p z i = R'.cubeNum enc' p' z i := by - cases i <;> rw [cubeNum, cubeNum] <;> rw [h] + rw [cubeNum, cubeNum, h] omit [DecidableEq β] [Nonempty β] [NumEnc R.graph.V] [NumEnc R.graph.D] in /-- **And so does the test's verdict.** -/ diff --git a/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean b/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean index 53fe1037..a8f82720 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean @@ -65,7 +65,6 @@ noncomputable def cloudMark (w : List Bool) : List Bool := ifEqLen (ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) (Cobham.sndBlock (Cobham.fstBlock w)) [true] [] -set_option maxHeartbeats 1000000 in theorem cloudMark_mem_FP : cloudMark ∈ FP := by have hG : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP @@ -96,7 +95,6 @@ noncomputable def cloudSizeFn (z : List Bool) : List Bool := countOver cloudMark (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) z) -set_option maxHeartbeats 1000000 in theorem cloudSizeFn_mem_FP : cloudSizeFn ∈ FP := by have hcnt : (fun z : List Bool => marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) ∈ FP := by @@ -127,7 +125,6 @@ noncomputable def cloudIdxFn (z : List Bool) : List Bool := countOver cloudMark (pair (marks (Cobham.sndBlock z)) (pair (Cobham.fstBlock z) (ownerFn z))) -set_option maxHeartbeats 1000000 in theorem cloudIdxFn_mem_FP : cloudIdxFn ∈ FP := by have hcnt := marks_mem_FP Cobham.sndBlock_mem_FP have hdata := Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP ownerFn_mem_FP @@ -162,7 +159,6 @@ noncomputable def eltMark (w : List Bool) : List Bool := (Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock w))) [true] []) [] -set_option maxHeartbeats 1000000 in theorem eltMark_mem_FP : eltMark ∈ FP := by have hG : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP @@ -218,7 +214,6 @@ theorem cloudEltFn_eq_replicate (z : List Bool) : conv_lhs => rw [cloudEltFn, findFirst_eq_replicate] rw [← cloudEltFn] -set_option maxHeartbeats 1000000 in theorem cloudEltFn_mem_FP : cloudEltFn ∈ FP := by have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP @@ -369,7 +364,6 @@ theorem length_cloudIdxFn_eq (m : ℕ) (hm : m < 2 * G.numEdges) : omit [Fintype α] [DecidableEq α] in /-- The code of a half-edge is below twice the edge count. -/ theorem halfCode_lt (p : G.HalfEdge) : G.halfCode p < 2 * G.numEdges := by - have hp := p.1.isLt rw [ConstraintGraph.halfCode] by_cases hb : p.2 = true · rw [if_pos hb] @@ -465,7 +459,6 @@ noncomputable def cloudStepFn (z : List Bool) : List Bool := (Cobham.fstBlock (Cobham.sndBlock z)))) (Cobham.sndBlock (Cobham.sndBlock z)))))) -set_option maxHeartbeats 1000000 in theorem cloudStepFn_mem_FP : cloudStepFn F pol ∈ FP := by have hG : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP @@ -518,7 +511,6 @@ noncomputable def expStepFn (z : List Bool) : List Bool := (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) (Cobham.sndBlock z)) -set_option maxHeartbeats 1000000 in theorem expStepFn_mem_FP : expStepFn F pol ∈ FP := by have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP @@ -666,7 +658,6 @@ noncomputable def preRotFn (deg : ℕ) (z : List Bool) : List Bool := ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg))))) ++ List.replicate (2 + deg) true)))) -set_option maxHeartbeats 1000000 in theorem preRotFn_mem_FP (deg : ℕ) : preRotFn F pol deg ∈ FP := by have hG : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP have hv : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := @@ -720,7 +711,6 @@ theorem preRotFn_mem_FP (deg : ℕ) : preRotFn F pol deg ∈ FP := by simp only [Function.comp_apply] rw [preRotFn] -set_option maxHeartbeats 1000000 in /-- **The whole rotation map computes what it should.** -/ theorem preRotFn_eq (hd : 1 < F.deg) (v d : ℕ) (hv : v < 2 * G.numEdges) (hdlt : d < 2 + 2 * (F.toFamily hd).degree) @@ -749,7 +739,6 @@ theorem preRotFn_eq (hd : 1 < F.deg) (v d : ℕ) (hv : v < 2 * G.numEdges) rw [ifEqLen_pos (by simp), if_pos rfl, flipFn_eq] rfl rw [ifEqLen_neg (by simpa using h1), if_neg h1] - have hd2 : 2 ≤ d := by omega have hdrop2 : (List.replicate d true).drop 2 = List.replicate (d - 2) true := by simp by_cases h2 : d < 2 + (F.toFamily hd).degree · -- the cloud's move diff --git a/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean b/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean index 1640f259..adaac6a8 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgPreprocess.lean @@ -147,8 +147,7 @@ theorem cloudStepNum_eq (p : G.HalfEdge) (j : Fin E.degree) : rw [G.idxOf_cloudList rfl, enc_halfEdge] have hlt' : countBelow (G.cloudCodes (G.owner p)) (enc p) < (G.cloudList (G.owner p)).length := by rw [← hidx]; exact hlt - rw [cloudStepNum, dif_pos hlt'] - rw [cloudRot, cloudRotAux, dif_pos hlt] + rw [cloudStepNum, dif_pos hlt', cloudRot, cloudRotAux, dif_pos hlt] simp only [← hidx] refine Prod.ext ?_ rfl dsimp only diff --git a/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean b/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean index 04467118..116df595 100644 --- a/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean +++ b/Complexitylib/Classes/PCP/Internal/AlphabetLift.lean @@ -69,7 +69,7 @@ theorem satisfies_lift_iff (G : ConstraintGraph α) (f : α → β) ∃ a₁ : α, ∃ a₂ : α, f a₁ = b (G.tail e) ∧ f a₂ = b (G.head e) ∧ G.rel e a₁ a₂ = true := by rw [Satisfies, satisfies] - simp [lift] + simp /-- **Satisfiability is unchanged.** -/ theorem satisfiable_lift_iff (G : ConstraintGraph α) {f : α → β} (hf : Function.Injective f) diff --git a/Complexitylib/Classes/PCP/Internal/BinToUnary.lean b/Complexitylib/Classes/PCP/Internal/BinToUnary.lean index c7bb9105..fdd21801 100644 --- a/Complexitylib/Classes/PCP/Internal/BinToUnary.lean +++ b/Complexitylib/Classes/PCP/Internal/BinToUnary.lean @@ -87,8 +87,6 @@ theorem recFoldClamp_binValLE (bound : ℕ) (W : List Bool) : have hlen : 2 ^ (l.length + 1) ≤ bound := by have : (b :: l).length = l.length + 1 := by simp omega - have hpow : 2 ^ (l.length + 1) = 2 ^ l.length + 2 ^ l.length := by - rw [pow_succ]; ring rw [Cobham.recFoldClamp, ih hb'] have hstate : Cobham.sndBlock (Cobham.fstBlock (pair (pair W (List.replicate (binValLE l) true)) l)) diff --git a/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean b/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean index 41f64222..dc14b58c 100644 --- a/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean +++ b/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean @@ -59,11 +59,11 @@ theorem bitStep_mem_FP {G : List Bool → List Bool} (hG : G ∈ FP) : bitStep G have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := sndBlock_mem_FP have hcnt : (fun z : List Bool => List.replicate (fstBlock z).length true) ∈ FP := by have := mem_FP_comp hfst unaryLength_mem_FP - simpa [Function.comp] using this + simpa using this have hquery : (fun z : List Bool => G (pair (sndBlock z) (List.replicate (fstBlock z).length true))) ∈ FP := by have := mem_FP_comp (pairFn_mem_FP hsnd hcnt) hG - simpa [Function.comp] using this + simpa using this exact pairFn_mem_FP (appendFn_mem_FP hfst hquery) hsnd /-- Running the step from the empty output builds the first `n` bits. -/ diff --git a/Complexitylib/Classes/PCP/Internal/CNFCount.lean b/Complexitylib/Classes/PCP/Internal/CNFCount.lean index 715319a3..ed1f934a 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFCount.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFCount.lean @@ -192,7 +192,7 @@ theorem clauseCountFn_mem_FP : clauseCountFn ∈ FP := by omega have hiter := Cobham.iterate_mem_FP ccStep_mem_FP hinit id_mem_FP hwidth hbound have := mem_FP_comp hiter Cobham.fstBlock_mem_FP - simpa [Function.comp, clauseCountFn] using this + simpa using this theorem clauseCountFn_eq {z : List Bool} (h : Even z.length) : clauseCountFn z = List.replicate (sepCount z) true := by diff --git a/Complexitylib/Classes/PCP/Internal/CNFSegment.lean b/Complexitylib/Classes/PCP/Internal/CNFSegment.lean index 3b0f1970..cf834dbe 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFSegment.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFSegment.lean @@ -336,7 +336,7 @@ theorem segAtFn_mem_FP : segAtFn s0 s1 ∈ FP := by omega have hiter := Cobham.iterate_mem_FP (segStep_mem_FP s0 s1) hinit hs hwidth hbound have := mem_FP_comp hiter segColl_mem_FP - simpa [Function.comp, segAtFn] using this + simpa only using this theorem segAtFn_eq {j : ℕ} {e : List Bool} (h : Even e.length) : segAtFn s0 s1 (pair (List.replicate j true) e) = segFrom s0 s1 j 0 e := by @@ -363,9 +363,9 @@ theorem litSegFn_mem_FP : litSegFn ∈ FP := by have hcl : (fun z : List Bool => segAtFn true false (pair (Cobham.fstBlock (Cobham.fstBlock z)) (Cobham.sndBlock z))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hj he) (segAtFn_mem_FP true false) - simpa [Function.comp] using this + simpa only using this have := mem_FP_comp (Cobham.pairFn_mem_FP hp hcl) (segAtFn_mem_FP false true) - simpa [Function.comp, litSegFn] using this + simpa only using this theorem litSegFn_eq {j p : ℕ} {e : List Bool} (h : Even e.length) : litSegFn (pair (pair (List.replicate j true) (List.replicate p true)) e) @@ -383,7 +383,7 @@ theorem litVarFn_mem_FP : litVarFn ∈ FP := by refine mem_FP_of_eq this fun z => ?_ rfl have := mem_FP_comp hdrop halfFn_mem_FP - simpa [Function.comp, litVarFn] using this + simpa only using this theorem litVarFn_eq {j p : ℕ} {e : List Bool} (h : Even e.length) : litVarFn (pair (pair (List.replicate j true) (List.replicate p true)) e) diff --git a/Complexitylib/Classes/PCP/Internal/CNFTokens.lean b/Complexitylib/Classes/PCP/Internal/CNFTokens.lean index ce178b35..486d0e0b 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFTokens.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFTokens.lean @@ -79,7 +79,7 @@ theorem clause_tokens_no_sep (c : Clause) : rw [Clause.tokens, List.filter_append, List.filter_append, ih] have hraw : (Lit.rawTokens l).filter (fun t => t = EncToken.clauseSep) = [] := by rw [Lit.rawTokens, List.filter_map] - simp [Function.comp] + simp rw [hraw] rfl diff --git a/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean b/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean index 5570cb1b..867c0ab3 100644 --- a/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean +++ b/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean @@ -84,7 +84,7 @@ theorem inRange_mem_FP : A.inRange p ∈ FP := by have hn : (fun z : List Bool => List.replicate (A.numEdges (Cobham.fstBlock z)) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP A.numEdges_mem - simpa [Function.comp] using this + simpa using this exact lenLeFlagFn_mem_FP hn (mem_FP_comp (edgeU_mem_FP p) (Cobham.cons_mem_FP true)) theorem inRange_eq_true_iff {z : List Bool} @@ -168,7 +168,7 @@ theorem posU_mem_FP : A.posU p ∈ FP := by rw [Function.comp_apply, List.length_replicate, List.length_replicate] have hoff : (fun w => List.replicate (A.offU w).length true) ∈ FP := by have := mem_FP_comp A.offU_mem_FP unaryLength_mem_FP - simpa [Function.comp] using this + simpa using this exact Cobham.appendFn_mem_FP hmul hoff theorem cntU_eq_replicate (z : List Bool) : @@ -215,10 +215,10 @@ theorem verdictLang_mem_P : A.verdictLang p ∈ P := by obtain ⟨g, hgFP, hg⟩ := exists_decisionFn_of_mem_P A.ok_mem have hin : (fun z : List Bool => A.inRange p (Cobham.fstBlock z)) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (A.inRange_mem_FP p) - simpa [Function.comp] using this + simpa using this have hok : (fun z : List Bool => [g (okArg p z)]) ∈ FP := by have := mem_FP_comp (okArg_mem_FP p) hgFP - simpa [Function.comp] using this + simpa using this have hflag : (fun z : List Bool => Cobham.selectHead (A.inRange p (Cobham.fstBlock z)) [g (okArg p z)] [true]) ∈ FP := Cobham.selectHeadFn_mem_FP hin hok (constFn_mem_FP [true]) @@ -392,7 +392,7 @@ theorem card_reject {x : List Bool} {T : ℕ} (hN : A.numEdges x ≤ 2 ^ T) (π = Finset.univ.filter (fun ρ : Fin T → Bool => ¬ (PCPVerifier.coinIndex ρ < A.numEdges x → A.Sat x π (PCPVerifier.coinIndex ρ))) := by ext ρ - simp [Finset.mem_filter] + simp rw [hcompl, card_filter_coinIndex T (fun e => ¬ (e < A.numEdges x → A.Sat x π e))] congr 1 ext e @@ -448,7 +448,6 @@ theorem eventProb_le {x : List Bool} {T : ℕ} {gap : ℚ} have hNpos : 0 < N := by have h2 : (0 : ℕ) < 2 ^ T := Nat.two_pow_pos T omega - have hNQ : (0 : ℚ) < (N : ℚ) := by exact_mod_cast hNpos have hTQ : (0 : ℚ) < (2 : ℚ) ^ T := by positivity have hRQ : (R : ℚ) = (N : ℚ) - (S : ℚ) := by have : (S : ℚ) + (R : ℚ) = (N : ℚ) := by exact_mod_cast hsum diff --git a/Complexitylib/Classes/PCP/Internal/Cheeger.lean b/Complexitylib/Classes/PCP/Internal/Cheeger.lean index 9fc6b42e..90395896 100644 --- a/Complexitylib/Classes/PCP/Internal/Cheeger.lean +++ b/Complexitylib/Classes/PCP/Internal/Cheeger.lean @@ -136,7 +136,7 @@ theorem sum_darts_boundary (S : Finset G.V) : rw [dartsBetween, Finset.card_filter] push_cast refine Finset.sum_congr rfl fun p _ => ?_ - simp [Finset.mem_compl] + simp have h2 : ∑ p : G.V × G.D, (if p.1 ∉ S ∧ G.nbr p.1 p.2 ∈ S then (1 : ℝ) else 0) = ((G.dartsBetween S Sᶜ).card : ℝ) := by rw [← h1, G.sum_darts_swap (fun u w => if u ∉ S ∧ w ∈ S then (1 : ℝ) else 0)] @@ -214,7 +214,6 @@ theorem coarea {h : ℝ} (hexp : G.EdgeExpansion h) : _ < S.card := Finset.card_erase_lt_of_mem hv₀S have hhalf' : 2 * (G.support ψ').card ≤ G.order := by have := Finset.card_le_card hψ'supp - have h2 := Finset.card_erase_le (s := S) (a := v₀) omega have ihψ' := ih _ hcard' ψ' rfl hψ'pos hhalf' -- relate the two functions @@ -553,7 +552,6 @@ theorem spectralBound_padLoops_of_edgeExpansion {h : ℝ} (hexp : G.EdgeExpansio have hcs := G.lazyQ_sq_le f B have hQf := G.lazyQ_nonneg f have hQB := G.lazyQ_nonneg B - have hSf : 0 ≤ ∑ v : G.V, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ have hSB : 0 ≤ ∑ v : G.V, (B v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ show ∑ v : G.V, (B v) ^ 2 ≤ (1 - h ^ 2 / 4) ^ 2 * ∑ v : G.V, (f v) ^ 2 set lam := 1 - h ^ 2 / 4 with hlam diff --git a/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean b/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean index 75f88b58..b215d1b9 100644 --- a/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean +++ b/Complexitylib/Classes/PCP/Internal/CloudDisagreement.lean @@ -234,14 +234,10 @@ theorem cloud_disagreement_bound (A : (G.reduce E).Assignment) (v : Fin G.numVer exact_mod_cast hinj refine le_trans ?_ (le_trans hexp hinjR) -- plurality: `|devᶜ| ≥ length / card α` - have hlenq : (0 : ℝ) < ((G.cloudList v).length : ℝ) := by exact_mod_cast hlen - have hcardq : (0 : ℝ) < (Fintype.card α : ℝ) := by - exact_mod_cast (Fintype.card_pos (α := α)) have hplur : ((G.cloudList v).length : ℝ) ≤ (Fintype.card α : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ) := by exact_mod_cast G.length_le_card_agree A v have hlam : 0 ≤ 1 - E.lam := by linarith [E.lam_lt_one] - have hdeg : (0 : ℝ) ≤ (E.degree : ℝ) := by positivity have hdev : (0 : ℝ) ≤ ((G.devIdx A v).card : ℝ) := by positivity have hkey : ((G.devIdx A v).card : ℝ) / (Fintype.card α : ℝ) ≤ ((G.devIdx A v).card : ℝ) * (((G.devIdx A v)ᶜ).card : ℝ) diff --git a/Complexitylib/Classes/PCP/Internal/CoinEnum.lean b/Complexitylib/Classes/PCP/Internal/CoinEnum.lean index 381f31e2..169a58ea 100644 --- a/Complexitylib/Classes/PCP/Internal/CoinEnum.lean +++ b/Complexitylib/Classes/PCP/Internal/CoinEnum.lean @@ -99,7 +99,6 @@ theorem coinIndex_coinOfIndex {t : ℕ} (c : Fin (2 ^ t)) : = finFunctionFinEquiv.symm c := by funext i rw [PCPVerifier.coinDigits, PCPVerifier.coinOfIndex] - have hlt : (finFunctionFinEquiv.symm c i).val < 2 := (finFunctionFinEquiv.symm c i).isLt have hv : (finFunctionFinEquiv.symm c i).val = 0 ∨ (finFunctionFinEquiv.symm c i).val = 1 := by omega rcases hv with hv | hv diff --git a/Complexitylib/Classes/PCP/Internal/Compose.lean b/Complexitylib/Classes/PCP/Internal/Compose.lean index 98c0fa03..37dfced7 100644 --- a/Complexitylib/Classes/PCP/Internal/Compose.lean +++ b/Complexitylib/Classes/PCP/Internal/Compose.lean @@ -353,7 +353,6 @@ theorem unsatFrac_compose_ge (henc : Function.Injective enc) have hE : (Fintype.card R.Dart : ℚ) = ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by rw [R.card_dart] rw [RegCSP.unsatFrac, hE] - have hpos : (0 : ℚ) < 2 ^ ROf B := by positivity rcases Nat.eq_zero_or_pos (R.graph.order * R.graph.deg) with h0 | h0 · rw [h0] simp diff --git a/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean b/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean index a7592d2a..e64e55aa 100644 --- a/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean +++ b/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean @@ -85,20 +85,20 @@ theorem conW_mem_FP : conW ∈ FP := theorem unary_conC1_mem_FP : (fun y => List.replicate (conC1 y) true) ∈ FP := by have := mem_FP_comp (mem_FP_comp conY1_mem_FP Cobham.sndBlock_mem_FP) unaryLength_mem_FP - simpa [Function.comp, conC1] using this + simpa using this theorem unary_conC2_mem_FP : (fun y => List.replicate (conC2 y) true) ∈ FP := by have := mem_FP_comp (mem_FP_comp conY2_mem_FP Cobham.sndBlock_mem_FP) unaryLength_mem_FP - simpa [Function.comp, conC2] using this + simpa using this theorem unary_conC3_mem_FP : (fun y => List.replicate (conC3 y) true) ∈ FP := by have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) unaryLength_mem_FP - simpa [Function.comp, conC3] using this + simpa using this theorem unary_conC4_mem_FP : (fun y => List.replicate (conC4 y) true) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP - simpa [Function.comp, conC4] using this + simpa using this /-! ### The check -/ @@ -143,21 +143,21 @@ include hr in theorem conRho_mem_FP : conRho r ∈ FP := by have ht : (fun y : List Bool => List.replicate (r (conX y).length) true) ∈ FP := by have := mem_FP_comp conX_mem_FP hr - simpa [Function.comp] using this + simpa using this exact coinStr_mem_FP ht unary_conC1_mem_FP include hr in theorem conRho'_mem_FP : conRho' r ∈ FP := by have ht : (fun y : List Bool => List.replicate (r (conX y).length) true) ∈ FP := by have := mem_FP_comp conX_mem_FP hr - simpa [Function.comp] using this + simpa using this exact coinStr_mem_FP ht unary_conC2_mem_FP include hf hr in theorem conP_mem_FP : conP f r ∈ FP := by have hb : (fun y => f (pair (conX y) (conRho r y))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP conX_mem_FP (conRho_mem_FP r hr)) hf - simpa [Function.comp] using this + simpa using this have := posAt_mem_FP unary_conC3_mem_FP hb refine mem_FP_of_eq this fun y => ?_ rw [conP, List.length_replicate] @@ -166,7 +166,7 @@ include hf hr in theorem conP'_mem_FP : conP' f r ∈ FP := by have hb : (fun y => f (pair (conX y) (conRho' r y))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP conX_mem_FP (conRho'_mem_FP r hr)) hf - simpa [Function.comp] using this + simpa using this have := posAt_mem_FP unary_conC4_mem_FP hb refine mem_FP_of_eq this fun y => ?_ rw [conP', List.length_replicate] @@ -250,11 +250,11 @@ theorem consLang_mem_P (hrlog : r =O fun n => Nat.log 2 n) : consLang f r Q ∈ have hexp : (fun z : List Bool => List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) - simpa [Function.comp] using this + simpa using this have hexp2 : (fun y : List Bool => List.replicate (2 ^ r (Cobham.fstBlock (Cobham.fstBlock y)).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP hexp - simpa [Function.comp] using this + simpa using this have h1 : consL1 f r Q ∈ P := forall_unary_mem_P h2 hexp2 exact forall_unary_mem_P h1 hexp diff --git a/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean b/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean index 12a2f03f..fb65410d 100644 --- a/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean +++ b/Complexitylib/Classes/PCP/Internal/ConstraintGraph.lean @@ -201,7 +201,6 @@ value is at least one edge's worth. -/ theorem inv_numEdges_le_unsatFrac (h : ¬ G.Satisfiable) (a : G.Assignment) : 1 / (G.numEdges : ℚ) ≤ G.unsatFrac a := by have hpos : 0 < G.numEdges := numEdges_pos_of_not_satisfiable h - have hmq : (0 : ℚ) < (G.numEdges : ℚ) := by exact_mod_cast hpos have hne : (G.unsatEdges a).Nonempty := by by_contra hcon rw [Finset.not_nonempty_iff_eq_empty] at hcon diff --git a/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean b/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean index 73c8175b..34dfa7a1 100644 --- a/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean +++ b/Complexitylib/Classes/PCP/Internal/CubeBlocks.lean @@ -101,8 +101,6 @@ theorem prob_leftBlock (P : Cube a → Prop) : rw [hcard] norm_num rw [Finset.sum_congr rfl fun x _ => hinner x, ← Finset.mul_sum] - have hpa : (2 : ℝ) ^ a ≠ 0 := by positivity - have hpb : (2 : ℝ) ^ b ≠ 0 := by positivity rw [pow_add] field_simp @@ -130,8 +128,6 @@ theorem prob_rightBlock (P : Cube b → Prop) : rw [hcard] norm_num rw [Finset.sum_congr rfl fun y _ => hinner y, ← Finset.mul_sum] - have hpa : (2 : ℝ) ^ a ≠ 0 := by positivity - have hpb : (2 : ℝ) ^ b ≠ 0 := by positivity rw [pow_add] field_simp @@ -235,7 +231,6 @@ theorem prob₂_eq_prob_blocks {n : ℕ} (P : Cube n → Cube n → Prop) : rw [← rightBlock_blockEquiv ((cubeBlockEquiv n n).symm z), Equiv.apply_symm_apply] simp only [indicator, h1, h2] rw [hL, hR, Fintype.sum_prod_type, ← Finset.mul_sum, pow_add] - have h2n : (2 : ℝ) ^ n ≠ 0 := by positivity field_simp /-- A pair drawn from the first block of a bundled string is a uniform pair, @@ -297,8 +292,6 @@ theorem prob_blocks {a b : ℕ} (Q : Cube a → Cube b → Prop) : rw [expect_unfold] exact congrArg _ (Finset.sum_congr rfl fun u _ => expect_unfold _) rw [hL, hR, Fintype.sum_prod_type, ← Finset.mul_sum, pow_add] - have h2a : (2 : ℝ) ^ a ≠ 0 := by positivity - have h2b : (2 : ℝ) ^ b ≠ 0 := by positivity field_simp /-- **A bound that holds for every earlier outcome holds overall.** -/ diff --git a/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean b/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean index 53cd88d0..a7144f17 100644 --- a/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean +++ b/Complexitylib/Classes/PCP/Internal/DartCorrelation.lean @@ -374,7 +374,6 @@ theorem sum_sq_headCount_le (F : Finset (G.V × G.D)) : intro z have h := G.headCount_le F z have hR : (G.headCount F z : ℝ) ≤ (G.deg : ℝ) := by exact_mod_cast h - have hnn : (0 : ℝ) ≤ (G.headCount F z : ℝ) := by positivity nlinarith calc ∑ z : G.V, ((G.headCount F z : ℝ)) ^ 2 ≤ ∑ z : G.V, (G.deg : ℝ) * (G.headCount F z : ℝ) := Finset.sum_le_sum fun z _ => hterm z @@ -390,7 +389,6 @@ theorem sum_sq_dartCount_le (F : Finset (G.V × G.D)) : intro v have h := G.dartCount_le F v have hR : (G.dartCount F v : ℝ) ≤ (G.deg : ℝ) := by exact_mod_cast h - have hnn : (0 : ℝ) ≤ (G.dartCount F v : ℝ) := by positivity nlinarith calc ∑ v : G.V, ((G.dartCount F v : ℝ)) ^ 2 ≤ ∑ v : G.V, (G.deg : ℝ) * (G.dartCount F v : ℝ) := Finset.sum_le_sum fun v _ => hterm v diff --git a/Complexitylib/Classes/PCP/Internal/DataScan.lean b/Complexitylib/Classes/PCP/Internal/DataScan.lean index c5992f25..594058ae 100644 --- a/Complexitylib/Classes/PCP/Internal/DataScan.lean +++ b/Complexitylib/Classes/PCP/Internal/DataScan.lean @@ -294,10 +294,10 @@ theorem scanArg_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b (fun z => scanArg (a z).length (b z)) ∈ FP := by have hrep : (fun z => List.replicate (a z).length true) ∈ FP := by have := mem_FP_comp ha unaryLength_mem_FP - simpa [Function.comp] using this + simpa using this have hrev : (fun z => (b z).reverse) ∈ FP := by have := mem_FP_comp hb reverse_mem_FP - simpa [Function.comp] using this + simpa using this exact Cobham.pairFn_mem_FP hrep hrev /-- **The scan extracts the child.** Reading the concatenated serializations of diff --git a/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean b/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean index 76bf5479..12e1aed8 100644 --- a/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean +++ b/Complexitylib/Classes/PCP/Internal/DataScanSpec.lean @@ -100,7 +100,7 @@ theorem runSpec_toBits (i : ℕ) (y : Data) : have hsplit : (Data.l (x :: xs)).toBits = false :: (x.toBits ++ ((xs.map Data.toBits).flatten ++ [true])) := by rw [Data.toBits_l] - simp [List.append_assoc] + simp have htail : (Data.l xs).toBits = false :: ((xs.map Data.toBits).flatten ++ [true]) := by rw [Data.toBits_l] set F := (xs.map Data.toBits).flatten ++ [true] with hF @@ -141,7 +141,7 @@ theorem runSpec_toBits (i : ℕ) (y : Data) : simp only [hc, hacc₁] at hacc simpa using hacc.symm rw [hacc₂, hacc₁, if_pos hc, if_pos hc, if_pos hc, hR'] - simp [List.append_assoc] + simp · have hR' : R = [] := by simp only [if_neg hc, hacc₁] at hacc simpa using hacc.symm diff --git a/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean b/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean index e7618c9b..439668b1 100644 --- a/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean +++ b/Complexitylib/Classes/PCP/Internal/DegreeReduction.lean @@ -151,7 +151,6 @@ theorem cloudRotAux_involutive {l : List G.HalfEdge} (hnd : l.Nodup) {p : G.Half have hstep : G.cloudRotAux E l p j = (l.getD q.1.val p, q.2) := by rw [cloudRotAux, dif_pos hlt] have hget : l.getD q.1.val p = l[q.1.val] := (List.getElem_eq_getD p).symm - have hmem' : l[q.1.val] ∈ l := List.getElem_mem hq1 have hidx' : l.idxOf l[q.1.val] = q.1.val := hnd.idxOf_getElem _ hq1 have hlt' : l.idxOf (l.getD q.1.val p) < l.length := by rw [hget, hidx']; exact hq1 diff --git a/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean b/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean index e9e87519..439b04b2 100644 --- a/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean +++ b/Complexitylib/Classes/PCP/Internal/DegreeReductionSound.lean @@ -279,7 +279,6 @@ theorem unsatFrac_reduce_ge (A : (G.reduce E).Assignment) : calc c / (2 * (1 + (E.degree : ℝ))) * ((G.unsatVal : ℚ) : ℝ) * (2 * (G.numEdges : ℝ) * (1 + (E.degree : ℝ))) = c * ((G.unsatVal : ℚ) : ℝ) * (G.numEdges : ℝ) := by - have hd1 : (0 : ℝ) < 1 + (E.degree : ℝ) := by positivity field_simp _ ≤ (((G.reduce E).unsatDarts A).card : ℝ) := hkey diff --git a/Complexitylib/Classes/PCP/Internal/Dinur.lean b/Complexitylib/Classes/PCP/Internal/Dinur.lean index 09af2c77..a6068664 100644 --- a/Complexitylib/Classes/PCP/Internal/Dinur.lean +++ b/Complexitylib/Classes/PCP/Internal/Dinur.lean @@ -154,7 +154,6 @@ theorem preprocessLam_nonneg : 0 ≤ ConstraintGraph.preprocessLam E := by theorem preprocessConst_pos : 0 < ConstraintGraph.preprocessConst E DinurAlpha := by have hd : (0 : ℝ) < E.degree := by exact_mod_cast E.degree_pos have hl : 0 < 1 - E.lam := by linarith [E.lam_lt_one] - have hK : (0 : ℝ) < Fintype.card DinurAlpha := by exact_mod_cast (Fintype.card_pos) rw [ConstraintGraph.preprocessConst, ConstraintGraph.reduceConst] have : 0 < min (1 : ℝ) ((1 - E.lam) * (E.degree : ℝ) / (Fintype.card DinurAlpha : ℝ)) := by apply lt_min one_pos @@ -201,7 +200,6 @@ theorem le_unsatVal_step (q : ℕ) (hq2 : 2 ≤ q) (G : ConstraintGraph DinurAlp have hc : 0 ≤ RegCSP.powConst q DinurAlpha := by rw [RegCSP.powConst, card_dinurAlpha_eq] have h1 : (1 : ℝ) ≤ q := by exact_mod_cast (by omega : 1 ≤ q) - have hK0 : (0 : ℝ) < K := by exact_mod_cast one_le_K apply div_nonneg · linarith · have hsq : (0 : ℝ) ≤ (K : ℝ) ^ 2 := sq_nonneg _ diff --git a/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean b/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean index 14a526cf..0f98ddb8 100644 --- a/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean +++ b/Complexitylib/Classes/PCP/Internal/EdgeExpansion.lean @@ -103,10 +103,8 @@ theorem card_dartsBetween_compl_ge {lam : ℝ} (hlam : 0 ≤ lam) (h : G.Spectra (hn : 0 < G.order) (S : Finset G.V) : (1 - lam) * (G.deg : ℝ) * ((S.card : ℝ) * (Sᶜ.card : ℝ) / (G.order : ℝ)) ≤ ((G.dartsBetween S Sᶜ).card : ℝ) := by - have hnq : (0 : ℝ) < (G.order : ℝ) := by exact_mod_cast hn have hdq : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity set B : ℝ := (S.card : ℝ) * (Sᶜ.card : ℝ) / (G.order : ℝ) with hB - have hBnn : 0 ≤ B := by positivity -- both variances are `B` have hcompl : (S.card : ℝ) + (Sᶜ.card : ℝ) = (G.order : ℝ) := by have h : S.card + Sᶜ.card = Fintype.card G.V := Finset.card_add_card_compl S diff --git a/Complexitylib/Classes/PCP/Internal/Expander.lean b/Complexitylib/Classes/PCP/Internal/Expander.lean index f9ec772a..892fa4d3 100644 --- a/Complexitylib/Classes/PCP/Internal/Expander.lean +++ b/Complexitylib/Classes/PCP/Internal/Expander.lean @@ -141,7 +141,6 @@ omit [NumEnc G.V] in a factor. -/ theorem expanderize_bound_lt_one : ((G.deg : ℝ) + (E.degree : ℝ) * E.lam) / ((G.deg : ℝ) + (E.degree : ℝ)) < 1 := by - have hdG : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity have hdE : (0 : ℝ) < (E.degree : ℝ) := by exact_mod_cast E.degree_pos rw [div_lt_one (by positivity)] nlinarith [E.lam_lt_one, E.lam_nonneg] diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean b/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean index 9fb87277..0d8ee3f1 100644 --- a/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean +++ b/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean @@ -62,11 +62,6 @@ theorem sq_between (n : ℕ) (hn : 10 ≤ n) : have h2 : s * s ≤ 2 * n := Nat.sqrt_le (2 * n) refine ⟨h1.le, ?_⟩ -- `2 s + 1 ≤ n` since otherwise `n² ≤ 4 s² ≤ 8 n` - have h3 : 2 * s + 1 ≤ n := by - by_contra hcon - push Not at hcon - have : n ≤ 2 * s := by omega - nlinarith nlinarith /-! ### The empty graph -/ diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean b/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean index 6b6640ba..fda51783 100644 --- a/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean +++ b/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean @@ -273,8 +273,7 @@ theorem sum_sq_lift_le (hn : 0 < n) (hN : N ≤ 3 * n) (f : Fin n → ℝ) : ∑ u : Fin N, (f (proj n hn u)) ^ 2 ≤ 3 * ∑ v : Fin n, (f v) ^ 2 := by classical have h := sum_over_lift hn hN (fun u => (f (proj n hn u)) ^ 2) - rw [← h, Fintype.sum_prod_type] - rw [Finset.mul_sum] + rw [← h, Fintype.sum_prod_type, Finset.mul_sum] refine Finset.sum_le_sum fun v _ => ?_ have : ∀ i : Fin 3, (match lift N n v i with | some u => (f (proj n hn u)) ^ 2 | none => 0) ≤ (f v) ^ 2 := by @@ -343,7 +342,6 @@ theorem sum_sq_step_lift_le (hn : 0 < n) (hd : 0 < d) (rot : Fin N × Fin d → set G := base hd rot hrot with hG set F : Fin N → ℝ := fun w => f (proj n hn w) with hF have hord : (G.order : ℝ) = N := by rw [hG, order_ofRot] - have hN' : (0 : ℝ) < N := by exact_mod_cast hN0 have hordpos : 0 < G.order := by rw [hG, order_ofRot]; exact hN0 -- decompose `F` into its mean and its centred part have hdec : F = fun v => G.mean F + G.center F v := G.eq_mean_add_center F @@ -438,7 +436,6 @@ theorem liftN_eq_lift (N n : ℕ) (v : Fin n) (i : Fin 3) : theorem liftN_isSome {N n m : ℕ} (hm : (m - 1) * n ≤ N) (v : Fin n) {i : ℕ} (hi : i + 1 < m) : (liftN N n v i).isSome := by rw [liftN] - have hv : v.val < n := v.isLt have hle : v.val + i * n < (m - 1) * n := by have h1 : i + 1 ≤ m - 1 := by omega calc v.val + i * n < n + i * n := by omega diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean b/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean index 742e373b..b616f939 100644 --- a/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean +++ b/Complexitylib/Classes/PCP/Internal/ExpanderPad.lean @@ -143,7 +143,6 @@ theorem spectralBound_padLoops (k : ℕ) {lam : ℝ} (h : G.SpectralBound lam) : intro f hf have hspec := h f hf have hd : (0 : ℝ) < G.deg := by exact_mod_cast G.deg_pos - have hk : (0 : ℝ) ≤ k := by positivity have hD : (0 : ℝ) < (G.deg : ℝ) + k := by positivity rw [Real.sq_sqrt (by positivity)] set a : ℝ := (G.deg : ℝ) / ((G.deg : ℝ) + k) with ha @@ -164,7 +163,6 @@ theorem spectralBound_padLoops (k : ℕ) {lam : ℝ} (h : G.SpectralBound lam) : ≤ a * ∑ v : G.V, (G.step f v) ^ 2 + (1 - a) * ∑ v : G.V, (f v) ^ 2 := by rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] exact Finset.sum_le_sum fun v _ => hpt v - have hS : 0 ≤ ∑ v : G.V, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ have hcoef : ((G.deg : ℝ) * lam ^ 2 + k) / ((G.deg : ℝ) + k) = a * lam ^ 2 + (1 - a) := by rw [← hb, ha]; field_simp rw [hcoef] diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean b/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean index 7399ea6f..d6187367 100644 --- a/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean +++ b/Complexitylib/Classes/PCP/Internal/ExpanderRandom.lean @@ -78,9 +78,6 @@ theorem two_pow_mul_escB_le {s : ℕ} (hs : 1 ≤ s) (hsn : 2 * s ≤ n) : 2 ^ s * (n.choose s * escB n s ^ 30) ≤ Nat.factorial n ^ 30 := by set t := (s - 1) / 10 with ht set k := s - t with hk - have hmt : 10 * t ≤ s := by - rw [ht] - omega have hts : t ≤ s := by omega have h9 : 9 * s ≤ 10 * k := by omega have hkn : k ≤ n := by omega diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean b/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean index cdf7062f..7a2ae681 100644 --- a/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean +++ b/Complexitylib/Classes/PCP/Internal/ExpanderizeCSP.lean @@ -86,9 +86,6 @@ theorem unsatFrac_addTrivial (a : R.Assignment) : have hd : (0 : ℚ) < (R.graph.deg : ℚ) := by have := R.graph.deg_pos exact_mod_cast this - have hdH : (0 : ℚ) < (H.deg : ℚ) := by - have := H.deg_pos - exact_mod_cast this have hcards := R.card_unsatDarts_addTrivial H e a rcases Nat.eq_zero_or_pos R.graph.order with hz | hz · have hempty : (R.unsatDarts a).card = 0 := by diff --git a/Complexitylib/Classes/PCP/Internal/FamilyFin.lean b/Complexitylib/Classes/PCP/Internal/FamilyFin.lean index f8b61ec1..80e64234 100644 --- a/Complexitylib/Classes/PCP/Internal/FamilyFin.lean +++ b/Complexitylib/Classes/PCP/Internal/FamilyFin.lean @@ -145,7 +145,6 @@ theorem spectral_mergedG {n : ℕ} (hn : 0 < n) : (F.mergedG hd hn).SpectralBoun rw [show (4 : ℝ) / 5 = Real.sqrt ((4 / 5) ^ 2) by rw [Real.sqrt_sq (by norm_num)]] refine Real.sqrt_le_sqrt ?_ have hm3 : (3 : ℝ) ≤ (F.wid hd n : ℝ) := by exact_mod_cast F.three_le_wid hd hn - have hm0 : (0 : ℝ) < (F.wid hd n : ℝ) := by linarith set m : ℝ := (F.wid hd n : ℝ) have h1 : (1 - (2 / 5 : ℝ) ^ 2) / (2 * m) ≤ (1 - (2 / 5 : ℝ) ^ 2) / (2 * 3) := div_le_div_of_nonneg_left (by norm_num) (by norm_num) (by linarith) @@ -202,7 +201,6 @@ theorem spectral_paddedG {n : ℕ} (hn : 0 < n) : (F.paddedG hd hn).SpectralBoun have hk : (((F.famDeg - F.wid hd n * F.fitD : ℕ) : ℝ)) = (F.famDeg : ℝ) - (F.wid hd n : ℝ) * (F.fitD : ℝ) := by rw [Nat.cast_sub hle]; push_cast; ring - have hWpos : (0 : ℝ) < (F.widthBnd : ℝ) := by linarith have hDpos : (0 : ℝ) < (F.widthBnd : ℝ) * (F.fitD : ℝ) := by positivity rw [F.deg_mergedG hd hn, hk] push_cast diff --git a/Complexitylib/Classes/PCP/Internal/GapTheorem.lean b/Complexitylib/Classes/PCP/Internal/GapTheorem.lean index f9f90774..941a9f80 100644 --- a/Complexitylib/Classes/PCP/Internal/GapTheorem.lean +++ b/Complexitylib/Classes/PCP/Internal/GapTheorem.lean @@ -88,9 +88,6 @@ theorem two_pow_log_succ_le (n : ℕ) : 2 ^ (Nat.log 2 n + 1) ≤ 2 * n + 2 := b · subst h simp · have hlow : 2 ^ Nat.log 2 n ≤ n := Nat.pow_log_le_self 2 (by omega) - have hsplit : 2 ^ (Nat.log 2 n + 1) = 2 * 2 ^ Nat.log 2 n := by - rw [pow_succ] - ring omega private theorem pow_pow_comm (a b c : ℕ) : (a ^ b) ^ c = (a ^ c) ^ b := by diff --git a/Complexitylib/Classes/PCP/Internal/Hadamard.lean b/Complexitylib/Classes/PCP/Internal/Hadamard.lean index 50bce656..b147c3f1 100644 --- a/Complexitylib/Classes/PCP/Internal/Hadamard.lean +++ b/Complexitylib/Classes/PCP/Internal/Hadamard.lean @@ -101,12 +101,12 @@ theorem parityFun_basis (S : Finset (Fin n)) (i : Fin n) : · show chi (if i = i then (1 : ZMod 2) else 0) = -1 rw [if_pos rfl] show chi 1 = -1 - simp [chi] + simp · intro j _ hj show chi (if j = i then (1 : ZMod 2) else 0) = 1 rw [if_neg hj] show chi 0 = 1 - simp [chi] + simp · intro hni exact absurd hi hni · rw [if_neg hi] @@ -115,7 +115,7 @@ theorem parityFun_basis (S : Finset (Fin n)) (i : Fin n) : show chi (if j = i then (1 : ZMod 2) else 0) = 1 rw [if_neg hji] show chi 0 = 1 - simp [chi] + simp /-! ### The Hadamard code -/ @@ -160,7 +160,7 @@ theorem signOf_hadamard (a : Cube n) : · exact h · exact absurd h hi.2 rw [hzero, zero_mul] - simp [chi] + simp rw [hone, mul_one] refine Finset.prod_congr rfl fun i hi => ?_ simp only [Finset.mem_filter] at hi @@ -432,9 +432,8 @@ theorem expect_signOf (F : BitFun n) : rw [Finset.sum_const, Finset.card_univ, card_cube, nsmul_eq_mul, mul_one] norm_num rw [hcard] - have hpow : (2 : ℝ) ^ n ≠ 0 := by positivity field_simp - ring + ring_nf /-- **A nonzero linear form is balanced.** Over `𝔽₂` a nonzero linear form takes each value on exactly half the cube — the counting fact behind every "the check @@ -599,7 +598,6 @@ theorem expect_add (f g : BooleanFunction n) : theorem expect_one : 𝔼[fun _ : Cube n => (1 : ℝ)] = 1 := by rw [expect_unfold, Finset.sum_const, Finset.card_univ, card_cube, nsmul_eq_mul, mul_one] - have hpow : (2 : ℝ) ^ n ≠ 0 := by positivity push_cast field_simp diff --git a/Complexitylib/Classes/PCP/Internal/KilledCSP.lean b/Complexitylib/Classes/PCP/Internal/KilledCSP.lean index f22dc2ba..05fb10a0 100644 --- a/Complexitylib/Classes/PCP/Internal/KilledCSP.lean +++ b/Complexitylib/Classes/PCP/Internal/KilledCSP.lean @@ -199,7 +199,6 @@ theorem satisfiable_killedPow_of_satisfiable (hR : R.Satisfiable) : /-! ### The soundness witness -/ /-- A step of the effective walk that `σ` fails, whose two vertices both ends -have truthful opinions about, breaks the killed walk's constraint. This is the shape every soundness count is built from. -/ theorem not_satisfies_killedPow_of_faulty {σ : R.Assignment} (A : (R.killedPow q T hq).Assignment) (v : R.graph.V) diff --git a/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean b/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean index 2c879bd4..5be6a413 100644 --- a/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean +++ b/Complexitylib/Classes/PCP/Internal/KilledFirstMoment.lean @@ -1169,7 +1169,6 @@ theorem powering_soundness (A : (R.killedPow q T hq).Assignment) {H : ℕ} ≤ (((R.killedPow q T hq).unsatDarts A).card : ℝ) := by classical have hK : (0 : ℝ) < ((Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) : ℕ) : ℝ) := by - have hα : 0 < Fintype.card α := Fintype.card_pos have hd : 0 < R.graph.deg := R.graph.deg_pos have : 0 < Fintype.card α ^ 2 * (R.graph.deg ^ (T + 1) * q ^ T) := by positivity exact_mod_cast this diff --git a/Complexitylib/Classes/PCP/Internal/KilledWalk.lean b/Complexitylib/Classes/PCP/Internal/KilledWalk.lean index 9fcc3930..46e275dc 100644 --- a/Complexitylib/Classes/PCP/Internal/KilledWalk.lean +++ b/Complexitylib/Classes/PCP/Internal/KilledWalk.lean @@ -280,13 +280,13 @@ theorem card_preWalk_eq {T m : ℕ} (hm : m ≤ T) (w : Fin m → G.D) : by_cases hj : j.val < m · simp only [hj, dif_pos, Finset.mem_singleton] have hval := congrFun h ⟨j.val, hj⟩ - simpa [preWalk] using hval + simpa using hval · simp [hj] · intro h funext j have hmem := h ⟨j.val, lt_of_lt_of_le j.isLt hm⟩ simp only [j.isLt, dif_pos, Finset.mem_singleton] at hmem - simpa [preWalk] using hmem + simpa using hmem have hlt : (Finset.univ.filter fun j : Fin T => j.val < m).card = m := by have himg : (Finset.univ.filter fun j : Fin T => j.val < m).image Fin.val = Finset.range m := by diff --git a/Complexitylib/Classes/PCP/Internal/ListEncode.lean b/Complexitylib/Classes/PCP/Internal/ListEncode.lean index c419e439..d3792fe8 100644 --- a/Complexitylib/Classes/PCP/Internal/ListEncode.lean +++ b/Complexitylib/Classes/PCP/Internal/ListEncode.lean @@ -48,7 +48,7 @@ theorem listStep_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : listStep have hE' : (fun st : List Bool => E (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hx hctr) hE - simpa [Function.comp] using this + simpa using this exact Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hacc hE') (mem_FP_comp hctr (Cobham.cons_mem_FP true))) hx @@ -146,7 +146,7 @@ theorem listEncFn_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) (p : Poly have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) refine mem_FP_of_eq this fun z => ?_ rw [listEncFn] - simp [Function.comp] + simp theorem listEncFn_eq (E : List Bool → List Bool) (z : List Bool) : listEncFn E z diff --git a/Complexitylib/Classes/PCP/Internal/MaxLoop.lean b/Complexitylib/Classes/PCP/Internal/MaxLoop.lean index fa79952d..431c698a 100644 --- a/Complexitylib/Classes/PCP/Internal/MaxLoop.lean +++ b/Complexitylib/Classes/PCP/Internal/MaxLoop.lean @@ -60,7 +60,7 @@ theorem maxStep_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxStep f have hv : (fun st : List Bool => f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hz hi) hf - simpa [Function.comp] using this + simpa using this exact Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hm hv) hm hv) @@ -177,7 +177,7 @@ theorem maxFn_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxFn f ∈ have hiter := Cobham.iterate_mem_FP (maxStep_mem_FP hf) hinit Cobham.fstBlock_mem_FP hwidth hbound have := mem_FP_comp (mem_FP_comp hiter Cobham.fstBlock_mem_FP) Cobham.fstBlock_mem_FP - simpa [Function.comp, maxFn] using this + simpa using this theorem maxFn_eq (f : List Bool → List Bool) {n : ℕ} {z : List Bool} : (maxFn f (pair (List.replicate n true) z)).length = maxOver f z n := by diff --git a/Complexitylib/Classes/PCP/Internal/MergeGen.lean b/Complexitylib/Classes/PCP/Internal/MergeGen.lean index 8f1f4cf5..8c3df743 100644 --- a/Complexitylib/Classes/PCP/Internal/MergeGen.lean +++ b/Complexitylib/Classes/PCP/Internal/MergeGen.lean @@ -352,8 +352,7 @@ theorem sum_liftN_eq (hn : 0 < n) (hN : N ≤ m * n) (hm1 : (m - 1) * n ≤ N) ( (match liftN N n v i with | some _ => (0 : ℝ) | none => f v) := Fin.sum_univ_eq_sum_range (fun i => (match liftN N n v i with | some _ => (0 : ℝ) | none => f v)) m - rw [hconv] - rw [Finset.sum_eq_single (m - 1)] + rw [hconv, Finset.sum_eq_single (m - 1)] · intro b hb hbne rw [Finset.mem_range] at hb have : b + 1 < m := by omega diff --git a/Complexitylib/Classes/PCP/Internal/Mixing.lean b/Complexitylib/Classes/PCP/Internal/Mixing.lean index ba5c1bdb..62359ca5 100644 --- a/Complexitylib/Classes/PCP/Internal/Mixing.lean +++ b/Complexitylib/Classes/PCP/Internal/Mixing.lean @@ -87,7 +87,6 @@ theorem eq_mean_add_center (f : G.V → ℝ) : f = fun v => G.mean f + G.center funext v; simp [center] theorem sum_center (hn : 0 < G.order) (f : G.V → ℝ) : ∑ v : G.V, G.center f v = 0 := by - have hnq : (G.order : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne' simp only [center, Finset.sum_sub_distrib, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, mean, card_eq_order] field_simp @@ -96,7 +95,6 @@ theorem sum_center (hn : 0 < G.order) (f : G.V → ℝ) : ∑ v : G.V, G.center theorem sum_sq_center (hn : 0 < G.order) (f : G.V → ℝ) : ∑ v : G.V, (G.center f v) ^ 2 = (∑ v : G.V, (f v) ^ 2) - (∑ v : G.V, f v) ^ 2 / (G.order : ℝ) := by - have hnq : (G.order : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne' have expand : ∀ v : G.V, (G.center f v) ^ 2 = (f v) ^ 2 - 2 * G.mean f * f v + (G.mean f) ^ 2 := by intro v; simp only [center]; ring @@ -106,7 +104,7 @@ theorem sum_sq_center (hn : 0 < G.order) (f : G.V → ℝ) : _ = (∑ v : G.V, (f v) ^ 2) - 2 * G.mean f * (∑ v : G.V, f v) + (G.order : ℝ) * (G.mean f) ^ 2 := by rw [Finset.sum_add_distrib, Finset.sum_sub_distrib, ← Finset.mul_sum] - simp [mul_comm] + simp _ = (∑ v : G.V, (f v) ^ 2) - (∑ v : G.V, f v) ^ 2 / (G.order : ℝ) := by simp only [mean] field_simp @@ -124,7 +122,6 @@ theorem inner_stepIter_eq (hn : 0 < G.order) (t : ℕ) (f g : G.V → ℝ) : ∑ v : G.V, f v * G.stepIter t g v = (∑ v : G.V, f v) * (∑ v : G.V, g v) / (G.order : ℝ) + ∑ v : G.V, G.center f v * G.stepIter t (G.center g) v := by - have hnq : (G.order : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne' have hsumS : ∑ v : G.V, G.stepIter t (G.center g) v = 0 := by rw [G.sum_stepIter, G.sum_center hn] have hsumF : ∑ v : G.V, G.center f v = 0 := G.sum_center hn f diff --git a/Complexitylib/Classes/PCP/Internal/NatEncode.lean b/Complexitylib/Classes/PCP/Internal/NatEncode.lean index 7682d3d9..9981f8ef 100644 --- a/Complexitylib/Classes/PCP/Internal/NatEncode.lean +++ b/Complexitylib/Classes/PCP/Internal/NatEncode.lean @@ -153,7 +153,7 @@ theorem encodeListFn_mem_FP : encodeListFn ∈ FP := by have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) refine mem_FP_of_eq this fun z => ?_ rw [encodeListFn] - simp [Function.comp] + simp theorem encodeListFn_eq (z : List Bool) : encodeListFn z = DataEncode.bitstringEncode (Cobham.sndBlock z) := by @@ -171,11 +171,11 @@ theorem natEncodeFn_mem_FP : natEncodeFn ∈ FP := by have hw : (fun z : List Bool => List.replicate (Cobham.fstBlock z).length true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP unaryLength_mem_FP - simpa [Function.comp] using this + simpa using this have hv : (fun z : List Bool => List.replicate (Cobham.sndBlock z).length true) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP - simpa [Function.comp] using this + simpa using this have hcoin := coinStr_mem_FP hw hv have h1 : (fun z => pair [] (coinStr (Cobham.fstBlock z).length (Cobham.sndBlock z).length)) ∈ FP := @@ -184,9 +184,9 @@ theorem natEncodeFn_mem_FP : natEncodeFn ∈ FP := by have h3 : (fun z => pair [] (stripFn (pair [] (coinStr (Cobham.fstBlock z).length (Cobham.sndBlock z).length)))) ∈ FP := by refine Cobham.pairFn_mem_FP (constFn_mem_FP []) ?_ - simpa [Function.comp] using h2 + simpa using h2 have := mem_FP_comp h3 encodeListFn_mem_FP - simpa [Function.comp, natEncodeFn] using this + simpa using this /-- **It really is the number's encoding**, whenever the width holds the value. -/ diff --git a/Complexitylib/Classes/PCP/Internal/NumEnc.lean b/Complexitylib/Classes/PCP/Internal/NumEnc.lean index 45ee519b..c282acb5 100644 --- a/Complexitylib/Classes/PCP/Internal/NumEnc.lean +++ b/Complexitylib/Classes/PCP/Internal/NumEnc.lean @@ -217,9 +217,6 @@ instance instProd [NumEnc α] [NumEnc β] : NumEnc (α × β) where obtain ⟨b, hbb, hp⟩ := hb have hea := enc_dec _ a ha have heb := enc_dec _ b hbb - have hcb : 0 < card β := by - have := enc_lt b - omega show enc p.1 * card β + enc p.2 = i rw [← hp] show enc a * card β + enc b = i diff --git a/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean b/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean index fe12d69a..7007b475 100644 --- a/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean +++ b/Complexitylib/Classes/PCP/Internal/PCPtoSAT.lean @@ -104,8 +104,7 @@ def varIdx (t Q : ℕ) (ρ : Fin t → Bool) (i : ℕ) : ℕ := coinIndex ρ * Q theorem get_varIdx (t Q : ℕ) (x w : List Bool) (ρ : Fin t → Bool) {i : ℕ} (hi : i < (V.positions x (BitString.toList ρ)).length) : (V.tableOf t Q x w ρ)[i]? = some (Assignment.get w (varIdx t Q ρ i)) := by - rw [tableOf] - rw [List.getElem?_map, List.getElem?_range hi] + rw [tableOf, List.getElem?_map, List.getElem?_range hi] rfl /-! ### The clauses -/ diff --git a/Complexitylib/Classes/PCP/Internal/PermArith.lean b/Complexitylib/Classes/PCP/Internal/PermArith.lean index cb94c9ae..a9f6fa1d 100644 --- a/Complexitylib/Classes/PCP/Internal/PermArith.lean +++ b/Complexitylib/Classes/PCP/Internal/PermArith.lean @@ -172,8 +172,6 @@ union bound over all sets of size `s`. -/ theorem key_estimate {n s k B : ℕ} (hs : 1 ≤ s) (hsn : 2 * s ≤ n) (h9 : 9 * s ≤ 10 * k) (hB : B * 2 ^ k * n ^ k ≤ 3 ^ s * s ^ k * Nat.factorial n) : 2 ^ s * (n.choose s * B ^ 30) ≤ Nat.factorial n ^ 30 := by - have hks : s ≤ k * 30 := by omega - have hn0 : 0 < n := by omega obtain ⟨m, hm⟩ : ∃ m, k * 30 = s + m := ⟨k * 30 - s, by omega⟩ have hsspos : 0 < s ^ s := pow_pos (by omega) s have hnum := two_pow_three_pow_le h9 diff --git a/Complexitylib/Classes/PCP/Internal/PermCount.lean b/Complexitylib/Classes/PCP/Internal/PermCount.lean index 74ae64dd..c479ea2f 100644 --- a/Complexitylib/Classes/PCP/Internal/PermCount.lean +++ b/Complexitylib/Classes/PCP/Internal/PermCount.lean @@ -174,7 +174,6 @@ theorem card_perm_escape_le (S : Finset (Fin n)) (t : ℕ) : ⊆ (S.powersetCard k).biUnion fun K => permsInto S K := by intro σ hσ rw [Finset.mem_filter] at hσ - have hesc : escape σ S ≤ t := hσ.2 set A : Finset (Fin n) := S.filter fun v => σ v ∈ S with hA have hcompl : A.card + escape σ S = S.card := by rw [hA, escape] diff --git a/Complexitylib/Classes/PCP/Internal/PermGraph.lean b/Complexitylib/Classes/PCP/Internal/PermGraph.lean index 76a2df21..5e8a5e9f 100644 --- a/Complexitylib/Classes/PCP/Internal/PermGraph.lean +++ b/Complexitylib/Classes/PCP/Internal/PermGraph.lean @@ -121,8 +121,6 @@ theorem edgeExpansion_permsGraph (hD : 0 < D) (σ : Fin D → Equiv.Perm (Fin n) rw [order_permsGraph] at hS obtain ⟨i, hi⟩ := hesc S hS have hcD : (0 : ℝ) < 2 * (c : ℝ) * D := by - have h1 : (0 : ℝ) < c := by exact_mod_cast hc - have h2 : (0 : ℝ) < D := by exact_mod_cast hD positivity have hsum : (escape (σ i) S : ℝ) ≤ ∑ j : Fin D, (escape (σ j) S : ℝ) := by refine Finset.single_le_sum (f := fun j => (escape (σ j) S : ℝ)) (fun j _ => ?_) diff --git a/Complexitylib/Classes/PCP/Internal/PosScan.lean b/Complexitylib/Classes/PCP/Internal/PosScan.lean index 29511b68..606f82e8 100644 --- a/Complexitylib/Classes/PCP/Internal/PosScan.lean +++ b/Complexitylib/Classes/PCP/Internal/PosScan.lean @@ -67,14 +67,14 @@ theorem posAt_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ have harg : (fun z => DataScan.scanArg (a z).length (posInner (b z))) ∈ FP := DataScan.scanArg_mem_FP ha (posInner_mem_FP hb) have := mem_FP_comp harg (DataScan.childOf_mem_FP DataScan.scanPoly) - simpa [Function.comp] using this + simpa using this theorem posCount_mem_FP {b : List Bool → List Bool} (hb : b ∈ FP) : (fun z => posCount (b z)) ∈ FP := by have harg : (fun z => DataScan.scanArg (([] : List Bool)).length (posInner (b z))) ∈ FP := DataScan.scanArg_mem_FP (constFn_mem_FP []) (posInner_mem_FP hb) have := mem_FP_comp harg (DataScan.childCount_mem_FP DataScan.scanPoly) - simpa [Function.comp, posCount] using this + simpa using this /-! ### What the scan reads -/ diff --git a/Complexitylib/Classes/PCP/Internal/PositionsFP.lean b/Complexitylib/Classes/PCP/Internal/PositionsFP.lean index 5efa9da4..97d49495 100644 --- a/Complexitylib/Classes/PCP/Internal/PositionsFP.lean +++ b/Complexitylib/Classes/PCP/Internal/PositionsFP.lean @@ -38,7 +38,7 @@ noncomputable def posEntryFn (P : List Bool → List Bool) (w : List Bool) : Lis theorem posEntryFn_mem_FP {P : List Bool → List Bool} (hP : P ∈ FP) : posEntryFn P ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hP hP) natEncodeFn_mem_FP - simpa [Function.comp, posEntryFn] using this + simpa using this theorem posEntryFn_eq {P : List Bool → List Bool} (w : List Bool) : posEntryFn P w = DataEncode.bitstringEncode ((P w).length) := by @@ -86,14 +86,13 @@ theorem positions_mem_of_unary {pos : List Bool → ℕ → ℕ} {cnt : List Boo have hpe : p.eval z'.length = 4 * z'.length * (pE.eval (3 * z'.length + 2)) + 3 * z'.length + 6 := by rw [hp] - simp [Polynomial.eval_comp] + simp rw [hpe] have hkz : k ≤ z'.length := le_trans hk hf have hmul : k * pE.eval (3 * z'.length + 2) ≤ z'.length * pE.eval (3 * z'.length + 2) := Nat.mul_le_mul_right _ hkz have hcat' : (entryCat E (Cobham.sndBlock z') k).length ≤ z'.length * pE.eval (3 * z'.length + 2) := le_trans hcat hmul - have h4 := Nat.mul_le_mul_left 4 hcat' rw [show 4 * z'.length * pE.eval (3 * z'.length + 2) = 4 * (z'.length * pE.eval (3 * z'.length + 2)) from by ring] omega @@ -101,7 +100,7 @@ theorem positions_mem_of_unary {pos : List Bool → ℕ → ℕ} {cnt : List Boo · have hpair : (fun z : List Bool => pair (List.replicate (cnt z) true) z) ∈ FP := mem_FP_pairWithInput hcnt have := mem_FP_comp hpair (listEncFn_mem_FP hEfp p hbound) - simpa [Function.comp] using this + simpa using this · intro z refine listEncFn_eq_bitstringEncode _ ?_ ?_ · rw [Cobham.fstBlock_pair, List.length_replicate, List.length_map, List.length_range] diff --git a/Complexitylib/Classes/PCP/Internal/PowerCSP.lean b/Complexitylib/Classes/PCP/Internal/PowerCSP.lean index ac4fe798..74fb11da 100644 --- a/Complexitylib/Classes/PCP/Internal/PowerCSP.lean +++ b/Complexitylib/Classes/PCP/Internal/PowerCSP.lean @@ -217,7 +217,7 @@ theorem not_satisfies_power_of_faulty {σ : R.Assignment} theorem card_dart_power : Fintype.card (R.power L t h).Dart = R.graph.order * R.graph.deg ^ t := by rw [card_dart] - simp [graph_power] + simp /-- The value of an assignment of the powered system is the fraction of *walks* whose constraint it fails. -/ @@ -227,7 +227,7 @@ theorem unsatFrac_power (A : (R.power L t h).Assignment) : / ((R.graph.order * R.graph.deg ^ t : ℕ) : ℚ) := by rw [unsatFrac] congr 2 - simp [graph_power] + simp /-- **The first moment.** For each step index `k`, the walks whose `k`-th dart is one that `σ` fails number exactly `deg ^ (t-1)` times the faulty darts — one diff --git a/Complexitylib/Classes/PCP/Internal/PoweringBound.lean b/Complexitylib/Classes/PCP/Internal/PoweringBound.lean index 3369c189..e373ac37 100644 --- a/Complexitylib/Classes/PCP/Internal/PoweringBound.lean +++ b/Complexitylib/Classes/PCP/Internal/PoweringBound.lean @@ -75,17 +75,12 @@ theorem powering_algebra {U N d K q lam C : ℝ} (T' : ℕ) (hN : 0 < N) (hd : 0 + 2 * ((T' + 2 : ℕ) : ℝ) / (1 - lam)) ≤ C / (N * (d ^ (T' + 2) * q ^ (T' + 2))) := by have hlam' : 0 < 1 - lam := by linarith - have hq0 : 0 < q := by linarith set c : ℝ := (q - 1) / (4 * K ^ 2) with hc set u : ℝ := U / (N * d) with hu set W : ℝ := N * (d ^ (T' + 2) * q ^ (T' + 2)) with hW set Tr : ℝ := ((T' + 2 : ℕ) : ℝ) with hTr set E : ℝ := 2 * Tr ^ 2 * u + 2 * Tr / (1 - lam) with hE - have hc0 : 0 ≤ c := by rw [hc]; apply div_nonneg <;> nlinarith - have hu0 : 0 < u := by rw [hu]; positivity have hW0 : 0 < W := by rw [hW]; positivity - have hTr0 : 0 < Tr := by rw [hTr]; positivity - have hE0 : 0 < E := by rw [hE]; positivity have hF : U * ((q - 1) * (d ^ (T' + 2) * q ^ (T' + 2) / 2 * (d ^ (T' + 2) * q ^ (T' + 2) / 2))) / (K ^ 2 * (d ^ (T' + 2 + 1) * q ^ (T' + 2))) = c * u * W := by @@ -102,8 +97,7 @@ theorem powering_algebra {U N d K q lam C : ℝ} (T' : ℕ) (hN : 0 < N) (hd : 0 field_simp rw [hratio] at hcount have hgoal : c + 2 * Tr ^ 2 * u + 2 * Tr / (1 - lam) = c + E := by rw [hE]; ring - rw [hgoal] - rw [div_le_div_iff₀ (by positivity) hW0] + rw [hgoal, div_le_div_iff₀ (by positivity) hW0] have hcE : 0 < c + E := by positivity have h := mul_le_mul_of_nonneg_right hcount hcE.le have heq : c ^ 2 * u * W = W * (c ^ 2 * u / (c + E)) * (c + E) := by @@ -215,7 +209,6 @@ theorem unsatFrac_killedPow_clean (A : (R.killedPow q T hq).Assignment) {H : ℕ refine mul_le_mul_of_nonneg_left ?_ (by linarith) exact mul_le_mul hhalf hhalf (by positivity) (by positivity) have hB := R.sum_sq_goodCrossings_le q T hq A hlam0 hlam1 hspec hn - have hT2 : 2 ≤ T := by omega obtain ⟨T', rfl⟩ : ∃ T', T = T' + 2 := ⟨T - 2, by omega⟩ have hP0 : (0 : ℝ) < 2 * ((q : ℝ) ^ (T' + 2) * ((R.graph.deg : ℝ) ^ (T' + 2 - 2) * (((T' + 2 : ℕ) : ℝ) * ((T' + 2 : ℕ) : ℝ) @@ -223,7 +216,6 @@ theorem unsatFrac_killedPow_clean (A : (R.killedPow q T hq).Assignment) {H : ℕ * ((R.unsatDarts (R.kDecode q (T' + 2) hq A)).card : ℝ) / (R.graph.order : ℝ)) + ((T' + 2 : ℕ) : ℝ) * (1 / (1 - lam)) * ((R.graph.deg : ℝ) * ((R.unsatDarts (R.kDecode q (T' + 2) hq A)).card : ℝ))))) := by - have hlam' : 0 < 1 - lam := by linarith positivity have hcount := R.card_unsatDarts_ge' q (T' + 2) hq A (by positivity) hF hB hP0 have hsub : T' + 2 - 2 = T' := by omega @@ -301,7 +293,6 @@ theorem le_unsatVal_killedPow_min {H : ℕ} refine min_le_min_right _ ?_ have hs : 0 ≤ powSlope (powConst q α) T lam := by rw [powSlope] - have hlam' : 0 < 1 - lam := by linarith positivity exact mul_le_mul_of_nonneg_left hv hs @@ -334,7 +325,6 @@ theorem four_mul_pow_le {K q : ℕ} (hK : 1 ≤ K) (hq : 2 ≤ q) : have hpm : (0 : ℝ) < ((q - 1 : ℕ) : ℝ) ^ m := by positivity rw [le_div_iff₀ hpm] at hbern have : (4 * K : ℝ) * ((q - 1 : ℕ) : ℝ) ^ m ≤ (q : ℝ) ^ m := by - have hK0 : (0 : ℝ) ≤ ((q - 1 : ℕ) : ℝ) ^ m := hpm.le nlinarith exact_mod_cast this @@ -402,8 +392,6 @@ theorem slopeUnit_mul_le_powSlope {K : ℕ} {q : ℕ} (hK : 1 ≤ K) (hq : 2 ≤ (hlam1 : lam < 1) : slopeUnit (K : ℝ) lam * ((q : ℝ) - 1) ≤ RegCSP.powSlope (((q : ℝ) - 1) / (4 * (K : ℝ) ^ 2)) (powT K q : ℝ) lam := by - have hlam' : 0 < 1 - lam := by linarith - have hK0 : (0 : ℝ) < K := by exact_mod_cast (by omega : 0 < K) have hq1 : (1 : ℝ) ≤ (q : ℝ) - 1 := by have : (2 : ℝ) ≤ q := by exact_mod_cast hq linarith @@ -414,10 +402,8 @@ theorem slopeUnit_mul_le_powSlope {K : ℕ} {q : ℕ} (hK : 1 ≤ K) (hq : 2 ≤ rw [hTcast, RegCSP.powSlope, slopeUnit] set r := (q : ℝ) - 1 with hr set D₀ : ℝ := 1 / (4 * (K : ℝ) ^ 2) + 2 + 16 * K / (1 - lam) with hD₀ - have hD₀0 : 0 < D₀ := by rw [hD₀]; positivity have hden : r / (4 * (K : ℝ) ^ 2) + 2 + 2 * (8 * K * r) / (1 - lam) ≤ r * D₀ := by rw [hD₀] - have h2 : (2 : ℝ) ≤ r * 2 := by linarith have hx : r / (4 * (K : ℝ) ^ 2) = r * (1 / (4 * (K : ℝ) ^ 2)) := by ring have hy : 2 * (8 * K * r) / (1 - lam) = r * (16 * K / (1 - lam)) := by ring rw [hx, hy] diff --git a/Complexitylib/Classes/PCP/Internal/Preprocess.lean b/Complexitylib/Classes/PCP/Internal/Preprocess.lean index 308eb1a2..0acedec9 100644 --- a/Complexitylib/Classes/PCP/Internal/Preprocess.lean +++ b/Complexitylib/Classes/PCP/Internal/Preprocess.lean @@ -187,9 +187,7 @@ theorem spectralBound_preprocess : exact hL theorem preprocessLam_lt_one : preprocessLam E < 1 := by - have hd : (0 : ℝ) ≤ (E.degree : ℝ) := by positivity have hlam := E.lam_lt_one - have hlamnn := E.lam_nonneg have hmu : ((1 + (E.degree : ℝ)) + (E.degree : ℝ) * E.lam) / ((1 + (E.degree : ℝ)) + E.degree) < 1 := by rw [div_lt_one (by positivity)] diff --git a/Complexitylib/Classes/PCP/Internal/RegCSP.lean b/Complexitylib/Classes/PCP/Internal/RegCSP.lean index 1795a8e0..0010d801 100644 --- a/Complexitylib/Classes/PCP/Internal/RegCSP.lean +++ b/Complexitylib/Classes/PCP/Internal/RegCSP.lean @@ -96,7 +96,7 @@ def Satisfiable : Prop := ∃ a : R.Assignment, ∀ p, R.Satisfies a p /-- The number of darts. -/ theorem card_dart : Fintype.card R.Dart = R.graph.order * R.graph.deg := by - simp [Dart] + simp theorem card_unsatDarts_le (a : R.Assignment) : (R.unsatDarts a).card ≤ R.graph.order * R.graph.deg := by @@ -187,7 +187,6 @@ theorem inv_card_dart_le_unsatVal (h : ¬ R.Satisfiable) : 1 / ((R.graph.order * R.graph.deg : ℕ) : ℚ) ≤ R.unsatVal := by refine R.le_unsatVal fun a => ?_ have hpos : 0 < R.graph.order * R.graph.deg := R.card_dart_pos_of_not_satisfiable h - have hmq : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by exact_mod_cast hpos have hne : (R.unsatDarts a).Nonempty := by by_contra hcon rw [Finset.not_nonempty_iff_eq_empty] at hcon diff --git a/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean b/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean index f256de21..a7c7a928 100644 --- a/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean +++ b/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean @@ -81,9 +81,6 @@ theorem spectralBound_sizedExpanderize : theorem sizedExpanderize_bound_lt_one : ((R.graph.deg : ℝ) + (F.degree : ℝ) * F.lam) / ((R.graph.deg : ℝ) + (F.degree : ℝ)) < 1 := by - have hdR : (0 : ℝ) < (R.graph.deg : ℝ) := by - have := R.graph.deg_pos - positivity have hdF : (0 : ℝ) < (F.degree : ℝ) := by exact_mod_cast F.degree_pos rw [div_lt_one (by positivity)] nlinarith [F.lam_lt_one, F.lam_nonneg] @@ -109,7 +106,6 @@ theorem unsatVal_sizedExpanderize_ge [Fintype α] [Nonempty α] [DecidableEq α] have h1 : (0 : ℚ) < (R.graph.deg : ℚ) := by have := R.graph.deg_pos exact_mod_cast this - have h2 : (0 : ℚ) ≤ (F.degree : ℚ) := by positivity linarith have hd : (0 : ℚ) ≤ (R.graph.deg : ℚ) := by positivity rw [sizedExpanderize, unsatVal_addTrivial, deg_padded, F.deg_graph] diff --git a/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean b/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean index bfe9ed80..42df5bd0 100644 --- a/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean +++ b/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean @@ -88,7 +88,7 @@ theorem fstCoinsFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : (fun z => fstCoins t (a z) (b z)) ∈ FP := by have hlen : (fun z => List.replicate (t (a z).length) true) ∈ FP := by have := mem_FP_comp ha ht - simpa [Function.comp] using this + simpa using this have := Cobham.takeLenFn_mem_FP hlen hb refine mem_FP_of_eq this fun z => ?_ rw [fstCoins, List.length_replicate] @@ -98,7 +98,7 @@ theorem sndCoinsFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : (fun z => sndCoins t (a z) (b z)) ∈ FP := by have hlen : (fun z => List.replicate (t (a z).length) true) ∈ FP := by have := mem_FP_comp ha ht - simpa [Function.comp] using this + simpa using this have := dropLenFn_mem_FP hlen hb refine mem_FP_of_eq this fun z => ?_ rw [sndCoins, List.length_replicate] @@ -116,12 +116,12 @@ theorem sqPositions_mem (hf : f ∈ FP) (fstCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hx (fstCoinsFn_mem_FP ht hx hr)) hf - simpa [Function.comp] using this + simpa using this have h2 : (fun z : List Bool => f (pair (Cobham.fstBlock z) (sndCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hx (sndCoinsFn_mem_FP ht hx hr)) hf - simpa [Function.comp] using this + simpa using this refine ⟨fun z => false :: (posInner (f (pair (Cobham.fstBlock z) (fstCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ++ posInner (f (pair (Cobham.fstBlock z) @@ -130,7 +130,7 @@ theorem sqPositions_mem (hf : f ∈ FP) have hcons := mem_FP_comp hcat (Cobham.cons_mem_FP false) have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) refine mem_FP_of_eq this fun z => ?_ - simp [Function.comp] + simp · intro x ρ show false :: (posInner (f (pair (Cobham.fstBlock (pair x ρ)) (fstCoins t (Cobham.fstBlock (pair x ρ)) (Cobham.sndBlock (pair x ρ))))) @@ -152,7 +152,7 @@ theorem sqVerdict_mem_P (hf : f ∈ FP) sndCoinsFn_mem_FP ht vX_mem_FP vR_mem_FP have hfv : (fun z => f (pair (vX z) (fstCoins t (vX z) (vR z)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP vX_mem_FP hc1) hf - simpa [Function.comp] using this + simpa using this have hn : (fun z => posCount (f (pair (vX z) (fstCoins t (vX z) (vR z))))) ∈ FP := posCount_mem_FP hfv have hnlen : ∀ z, (posCount (f (pair (vX z) (fstCoins t (vX z) (vR z))))).length diff --git a/Complexitylib/Classes/PCP/Internal/SubsetNP.lean b/Complexitylib/Classes/PCP/Internal/SubsetNP.lean index 46dcdaa9..a4704a83 100644 --- a/Complexitylib/Classes/PCP/Internal/SubsetNP.lean +++ b/Complexitylib/Classes/PCP/Internal/SubsetNP.lean @@ -100,7 +100,7 @@ theorem exists_proof_of_table (t : ℕ) (x : List Bool) (f : ℕ → Bool) have hlen : ((List.range (V.maxQuery t x)).map f).length = V.maxQuery t x := by simp rw [← List.getElem_eq_getD (h := by rw [hlen]; exact hlt)] - simp [List.getElem_map] + simp have hmap : (V.positions x (BitString.toList ρ)).map (fun i => ((List.range (V.maxQuery t x)).map f).getD i false) = (V.positions x (BitString.toList ρ)).map f := @@ -244,8 +244,7 @@ theorem coinOfIndex_coinIndex {t : ℕ} (ρ : Fin t → Bool) (h : coinIndex ρ have hfin : (⟨coinIndex ρ, h⟩ : Fin (2 ^ t)) = finFunctionFinEquiv (coinDigits ρ) := Fin.ext rfl funext i - rw [coinOfIndex, hfin, Equiv.symm_apply_apply] - rw [coinDigits] + rw [coinOfIndex, hfin, Equiv.symm_apply_apply, coinDigits] cases ρ i <;> decide /-- The table a witness encodes: the answers for coin string `ρ` sit in the diff --git a/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean b/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean index 246a7db6..11e1149c 100644 --- a/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean +++ b/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean @@ -47,7 +47,7 @@ theorem lenLang_mem_P have hexp : (fun z : List Bool => List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) - simpa [Function.comp] using this + simpa using this have hQ : (fun _ : List Bool => List.replicate Q false) ∈ FP := Cobham.const_replicate_mem_FP Q have hb : (fun z : List Bool => diff --git a/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean b/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean index 8622d394..956d0ef9 100644 --- a/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean +++ b/Complexitylib/Classes/PCP/Internal/ThreeSATReduction.lean @@ -158,7 +158,6 @@ theorem edgeClause_lt {φ : CNF} (e : Fin (toGraph φ).numEdges) : /-- Every (clause, position) pair is realized by an edge. -/ theorem exists_edge {φ : CNF} {j : ℕ} (hj : j < φ.length) (q : Fin 3) : ∃ e : Fin (toGraph φ).numEdges, edgeClause e.val = j ∧ edgePos e.val = q := by - have hq := q.isLt refine ⟨⟨3 * j + q.val, ?_⟩, ?_, ?_⟩ · show 3 * j + q.val < 3 * φ.length; omega · show (3 * j + q.val) / 3 = j; omega @@ -213,8 +212,6 @@ def mkAssign (φ : CNF) (a : (toGraph φ).Assignment) : SAT.Assignment := /-- `mkAssign` reads back the label bit it was built from. -/ theorem get_mkAssign {φ : CNF} {a : (toGraph φ).Assignment} {v : ℕ} (hv : v ≤ φ.maxVar) : Assignment.get (mkAssign φ a) v = a (varVertex φ v) 0 := by - have hlen : v < (mkAssign φ a).length := by - simp [mkAssign]; omega have hr : v < (List.range (φ.maxVar + 1)).length := by simp; omega simp [Assignment.get, mkAssign, List.getElem?_map, List.getElem?_eq_getElem hr] diff --git a/Complexitylib/Classes/PCP/Internal/TowerFamily.lean b/Complexitylib/Classes/PCP/Internal/TowerFamily.lean index f63b27a2..caf4e916 100644 --- a/Complexitylib/Classes/PCP/Internal/TowerFamily.lean +++ b/Complexitylib/Classes/PCP/Internal/TowerFamily.lean @@ -142,7 +142,6 @@ theorem spectral_mergedGraph {n : ℕ} (hn : 0 < n) : refine Real.sqrt_le_sqrt ?_ have hm3 : (3 : ℝ) ≤ (B.fitWidth hd n : ℝ) := by exact_mod_cast B.three_le_fitWidth hd hn - have hm0 : (0 : ℝ) < (B.fitWidth hd n : ℝ) := by linarith set m : ℝ := (B.fitWidth hd n : ℝ) have h1 : (1 - (2 / 5 : ℝ) ^ 2) / (2 * m) ≤ (1 - (2 / 5 : ℝ) ^ 2) / (2 * 3) := by apply div_le_div_of_nonneg_left (by norm_num) (by norm_num) (by linarith) @@ -182,7 +181,6 @@ theorem famLam_nonneg : 0 ≤ B.famLam := Real.sqrt_nonneg _ theorem famLam_lt_one : B.famLam < 1 := by have hW : (3 : ℝ) ≤ (B.widthBound : ℝ) := by exact_mod_cast B.three_le_widthBound - have hWpos : (0 : ℝ) < (B.widthBound : ℝ) := by linarith have h0 : (0 : ℝ) ≤ 1 - 27 / (25 * B.widthBound) := by rw [sub_nonneg, div_le_one (by linarith)] linarith @@ -209,7 +207,6 @@ theorem spectral_paddedGraph {n : ℕ} (hn : 0 < n) : have hk : (((B.famDegree - B.fitWidth hd n * B.fitD : ℕ) : ℝ)) = (B.famDegree : ℝ) - (B.fitWidth hd n : ℝ) * (B.fitD : ℝ) := by rw [Nat.cast_sub hle]; push_cast; ring - have hWpos : (0 : ℝ) < (B.widthBound : ℝ) := by linarith have hDpos : (0 : ℝ) < (B.widthBound : ℝ) * (B.fitD : ℝ) := by positivity rw [B.deg_mergedGraph hd hn, hk] push_cast diff --git a/Complexitylib/Classes/PCP/Internal/TowerFin.lean b/Complexitylib/Classes/PCP/Internal/TowerFin.lean index c24d6222..b87ab1fc 100644 --- a/Complexitylib/Classes/PCP/Internal/TowerFin.lean +++ b/Complexitylib/Classes/PCP/Internal/TowerFin.lean @@ -68,7 +68,6 @@ theorem rot_power_two (G : RegGraph) (v : G.V) (s : Fin 2 → G.D) : rfl · show G.backLabel v s (Fin.rev 1) = _ show (G.rot (G.walkAt 2 v s (Fin.rev (1 : Fin 2)).val, s (Fin.rev 1))).2 = _ - norm_num rfl end RegGraph @@ -385,7 +384,7 @@ theorem rotVal_eq (k : ℕ) (v : Fin (F.size k)) (i : Fin (F.deg ^ 2)) : rw [hq1] dsimp only rw [hr] - simp [Equiv.symm_apply_apply] + simp theorem baseVal_lt {x a : ℕ} (hx : x < F.deg ^ 4) (ha : a < F.deg) : (F.baseVal x a).1 < F.deg ^ 4 ∧ (F.baseVal x a).2 < F.deg := by diff --git a/Complexitylib/Classes/PCP/Internal/TowerTable.lean b/Complexitylib/Classes/PCP/Internal/TowerTable.lean index 42e89b42..2b4c8478 100644 --- a/Complexitylib/Classes/PCP/Internal/TowerTable.lean +++ b/Complexitylib/Classes/PCP/Internal/TowerTable.lean @@ -206,9 +206,6 @@ theorem stepRec_eq {k j : ℕ} (hj : j < F.size (k + 1) * F.deg ^ 2) : have hp1 : p1 < F.deg ^ 4 := by have := (F.baseVal_lt hxlt halt).1 rwa [hp] at this - have hp2 : p2 < F.deg := by - have := (F.baseVal_lt hxlt halt).2 - rwa [hp] at this rw [stepRec] simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, divC_eq hd2, modC_eq hd2, divC_eq hd4, modC_eq hd4, divC_eq hd1, modC_eq hd1, List.length_replicate, diff --git a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean index 9f5eed1a..afdf515b 100644 --- a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean +++ b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean @@ -171,17 +171,17 @@ theorem dmRun_mem_FP (b : List Bool) : dmRun b ∈ FP := by Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * omega have hiter := Cobham.iterate_mem_FP dmStep_mem_FP hinit id_mem_FP hwidth hbound - simpa [Function.comp, dmRun] using hiter + simpa using hiter theorem divFn_mem_FP (b : List Bool) : divFn b ∈ FP := by have := mem_FP_comp (mem_FP_comp (dmRun_mem_FP b) Cobham.fstBlock_mem_FP) Cobham.fstBlock_mem_FP - simpa [Function.comp, divFn] using this + simpa using this theorem modFn_mem_FP (b : List Bool) : modFn b ∈ FP := by have := mem_FP_comp (mem_FP_comp (dmRun_mem_FP b) Cobham.fstBlock_mem_FP) Cobham.sndBlock_mem_FP - simpa [Function.comp, modFn] using this + simpa using this theorem divFn_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : divFn b s = List.replicate (s.length / b.length) true := by @@ -233,17 +233,17 @@ theorem dmRun2_mem_FP : dmRun2 ∈ FP := by Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * omega have hiter := Cobham.iterate_mem_FP dmStep_mem_FP hinit Cobham.sndBlock_mem_FP hwidth hbound - simpa [Function.comp, dmRun2] using hiter + simpa using hiter theorem divFn2_mem_FP : divFn2 ∈ FP := by have := mem_FP_comp (mem_FP_comp dmRun2_mem_FP Cobham.fstBlock_mem_FP) Cobham.fstBlock_mem_FP - simpa [Function.comp, divFn2] using this + simpa using this theorem modFn2_mem_FP : modFn2 ∈ FP := by have := mem_FP_comp (mem_FP_comp dmRun2_mem_FP Cobham.fstBlock_mem_FP) Cobham.sndBlock_mem_FP - simpa [Function.comp, modFn2] using this + simpa using this theorem divFn2_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : divFn2 (pair b s) = List.replicate (s.length / b.length) true := by diff --git a/Complexitylib/Classes/PCP/Internal/Union.lean b/Complexitylib/Classes/PCP/Internal/Union.lean index 91e9e3ce..5ac7956c 100644 --- a/Complexitylib/Classes/PCP/Internal/Union.lean +++ b/Complexitylib/Classes/PCP/Internal/Union.lean @@ -129,7 +129,6 @@ private theorem sum_mul_le_of_sq_le {X Y : G.V → ℝ} {A lam : ℝ} (hlam : 0 ≤ (∑ v : G.V, (X v) ^ 2) * ∑ v : G.V, (Y v) ^ 2 := Finset.sum_mul_sq_le_sq_mul_sq _ _ _ have hprod : (∑ v : G.V, (X v) ^ 2) * (∑ v : G.V, (Y v) ^ 2) ≤ (lam * A) ^ 2 := by - have h1 : (0 : ℝ) ≤ ∑ v : G.V, (X v) ^ 2 := Finset.sum_nonneg fun _ _ => sq_nonneg _ have h2 : (0 : ℝ) ≤ ∑ v : G.V, (Y v) ^ 2 := Finset.sum_nonneg fun _ _ => sq_nonneg _ calc (∑ v : G.V, (X v) ^ 2) * (∑ v : G.V, (Y v) ^ 2) ≤ A * (lam ^ 2 * A) := by @@ -148,7 +147,6 @@ theorem sum_sq_step_union_le {lam : ℝ} (hlam : 0 ≤ lam) (hH : H.SpectralBoun set A : ℝ := ∑ v : G.V, (f v) ^ 2 with hAdef have hA : 0 ≤ A := Finset.sum_nonneg fun _ _ => sq_nonneg _ have hdG : (0 : ℝ) < (G.deg : ℝ) := by have := G.deg_pos; positivity - have hdH : (0 : ℝ) < (H.deg : ℝ) := by have := H.deg_pos; positivity set X : G.V → ℝ := fun v => G.step f v with hXdef set Y : G.V → ℝ := fun v => H.step (fun u => f (e u)) (e.symm v) with hYdef -- the two individual bounds @@ -176,8 +174,7 @@ theorem sum_sq_step_union_le {lam : ℝ} (hlam : 0 ≤ lam) (hH : H.SpectralBoun field_simp ring have hden : (0 : ℝ) < ((G.deg : ℝ) + (H.deg : ℝ)) ^ 2 := by positivity - rw [Finset.sum_congr rfl fun v _ => hexp v, ← Finset.sum_div] - rw [div_le_iff₀ hden] + rw [Finset.sum_congr rfl fun v _ => hexp v, ← Finset.sum_div, div_le_iff₀ hden] have hsplit : ∑ v : G.V, ((G.deg : ℝ) ^ 2 * (X v) ^ 2 + 2 * (G.deg : ℝ) * (H.deg : ℝ) * (X v * Y v) + (H.deg : ℝ) ^ 2 * (Y v) ^ 2) = (G.deg : ℝ) ^ 2 * (∑ v : G.V, (X v) ^ 2) diff --git a/Complexitylib/Classes/PCP/Internal/VerifierLang.lean b/Complexitylib/Classes/PCP/Internal/VerifierLang.lean index 4cb41bce..98d5aa36 100644 --- a/Complexitylib/Classes/PCP/Internal/VerifierLang.lean +++ b/Complexitylib/Classes/PCP/Internal/VerifierLang.lean @@ -150,10 +150,10 @@ theorem accCoin_mem_FP accCoin r ∈ FP := by have ht : (fun y : List Bool => List.replicate (r (accX y).length) true) ∈ FP := by have := mem_FP_comp accX_mem_FP hr - simpa [Function.comp] using this + simpa using this have hc : (fun y : List Bool => List.replicate (Cobham.sndBlock y).length true) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP - simpa [Function.comp] using this + simpa using this exact coinStr_mem_FP ht hc theorem accView_mem_FP (hf : f ∈ FP) @@ -164,7 +164,7 @@ theorem accView_mem_FP (hf : f ∈ FP) Cobham.pairFn_mem_FP accX_mem_FP hcoin have hfv : (fun y => f (pair (accX y) (accCoin r y))) ∈ FP := by have := mem_FP_comp hview hf - simpa [Function.comp] using this + simpa using this have hcount : (fun y => posCount (f (pair (accX y) (accCoin r y)))) ∈ FP := posCount_mem_FP hfv have hoff : (fun y : List Bool => @@ -202,7 +202,7 @@ theorem accLang_mem_P (hf : f ∈ FP) have hlen : (fun z : List Bool => List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) - simpa [Function.comp] using this + simpa using this exact forall_unary_mem_P (accInner_mem_P V f r Q hf hr) hlen /-- What one iteration looks at, on a well-formed input. -/ diff --git a/Complexitylib/Classes/PCP/Internal/WalkDart.lean b/Complexitylib/Classes/PCP/Internal/WalkDart.lean index 9914a8a9..ad5ad6d0 100644 --- a/Complexitylib/Classes/PCP/Internal/WalkDart.lean +++ b/Complexitylib/Classes/PCP/Internal/WalkDart.lean @@ -94,7 +94,6 @@ theorem sum_stepDart {M : Type*} [AddCommMonoid M] : intro t hk f obtain ⟨t', rfl⟩ : ∃ t', t = t' + 1 := ⟨t - 1, by omega⟩ have hkt : k < t' := by omega - have ht' : 1 ≤ t' := by omega have hsplit : ∀ v : G.V, (∑ s : Fin (t' + 1) → G.D, f (G.walkAt (t' + 1) v s (k + 1), s ⟨k + 1, hk⟩)) @@ -167,7 +166,6 @@ theorem sum_stepDart_fixed (h : G.V → G.D → ℝ) : intro m hk x obtain ⟨m', rfl⟩ : ∃ m', m = m' + 1 := ⟨m - 1, by omega⟩ have hkm : k < m' := by omega - have hm1 : 1 ≤ m' := by omega have hd : (G.deg : ℝ) ≠ 0 := G.deg_ne_zero have hsplit : (∑ r : Fin (m' + 1) → G.D, h (G.walkAt (m' + 1) x r (k + 1)) (r ⟨k + 1, hk⟩)) @@ -281,12 +279,6 @@ theorem sum_two_darts_fixed (h₁ h₂ : G.V → G.D → ℝ) : (G.nbr x i) := fun i => ih l' m' hkl' hl' (G.nbr x i) rw [Finset.sum_congr rfl fun i _ => hIH i, ← Finset.mul_sum] - have hswap : ∀ i : G.D, (∑ a : G.D, ∑ b : G.D, - G.stepIter k (fun y => h₁ y a - * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i)) - = ∑ a : G.D, ∑ b : G.D, - G.stepIter k (fun y => h₁ y a - * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i) := fun _ => rfl have hcomm : (∑ i : G.D, ∑ a : G.D, ∑ b : G.D, G.stepIter k (fun y => h₁ y a * G.stepIter (l' - k - 1) (fun z => h₂ z b) (G.nbr y a)) (G.nbr x i)) @@ -329,7 +321,7 @@ theorem card_walks_stepDart_mem {t : ℕ} {k : ℕ} (hk : k < t) (S : Finset (G. rw [Finset.sum_congr rfl fun v _ => hind v] rw [G.sum_stepDart k t hk (fun p => if p ∈ S then 1 else 0)] rw [← Finset.card_filter (fun p => p ∈ S) Finset.univ] - simp [smul_eq_mul] + simp end RegGraph diff --git a/Complexitylib/Classes/PCP/Internal/WalkSplit.lean b/Complexitylib/Classes/PCP/Internal/WalkSplit.lean index a00c6ad7..7a1512b9 100644 --- a/Complexitylib/Classes/PCP/Internal/WalkSplit.lean +++ b/Complexitylib/Classes/PCP/Internal/WalkSplit.lean @@ -94,7 +94,7 @@ theorem segGlue_split {ℓ i : ℕ} (hi : i < ℓ) (W : Fin ℓ → G.D) : · simp [segGlue, segPre, preWalk, hk] · have hkey : k = ⟨i, hi⟩ := Fin.ext hk subst hkey - simp [segGlue] + simp · have h1 : ¬ (k.val < i) := by omega have h2 : ¬ (k.val = i) := by omega simp only [segGlue, dif_neg h1, dif_neg h2, segSuf] @@ -128,7 +128,6 @@ theorem revWalk_segSuf {ℓ : ℕ} (v : G.V) (W : Fin ℓ → G.D) {i : ℕ} (hi G.revWalk (G.walkAt ℓ v W (i + 1)) (G.segSuf W i) = G.segPre (G.revWalk v W) (show ℓ - (i + 1) ≤ ℓ by omega) := by funext k - have hk := k.isLt have hkl : k.val < ℓ := by omega have hlt : ℓ - (k.val + 1) < ℓ := by omega have hrev : ((Fin.rev k : Fin (ℓ - (i + 1)))).val = ℓ - (i + 1) - (k.val + 1) := diff --git a/Complexitylib/Classes/PCP/Internal/ZigZag.lean b/Complexitylib/Classes/PCP/Internal/ZigZag.lean index 14cd8b58..a6390b69 100644 --- a/Complexitylib/Classes/PCP/Internal/ZigZag.lean +++ b/Complexitylib/Classes/PCP/Internal/ZigZag.lean @@ -95,7 +95,7 @@ theorem zigzagRot_involutive : Function.Involutive (zigzagRot G H e) := by have : (p.1, p.2) = p := rfl rw [this, hp, H.rot_involutive] simp only [hrr, hqq, hpp] - simp [Equiv.apply_symm_apply] + simp /-- **The zig-zag product.** Its vertices are the darts of `G` and its degree is the square of `H`'s. -/ @@ -152,8 +152,7 @@ theorem step_zigzag (f : (zigzag G H e).V → ℝ) (x : (zigzag G H e).V) : have hsum : (∑ d : (zigzag G H e).D, f ((zigzag G H e).nbr x d)) = ∑ a : H.D, ∑ b : H.D, f ((zigzagRot G H e (x, (a, b))).1) := Fintype.sum_prod_type (f := fun d : H.D × H.D => f ((zigzagRot G H e (x, d)).1)) - rw [RegGraph.step, hdeg, hsum] - rw [cloudStep] + rw [RegGraph.step, hdeg, hsum, cloudStep] have hinner : ∀ a : H.D, ∑ b : H.D, f ((zigzagRot G H e (x, (a, b))).1) = (H.deg : ℝ) * cloudStep G H e f @@ -816,7 +815,6 @@ theorem spectralBound_zigzag {lamG lamH : ℝ} (hG : G.SpectralBound lamG) RegGraph.sum_step (zigzag G H e) f have hTf0 : ∑ x : G.V × G.D, (zigzag G H e).step f x = 0 := by rw [hmean]; exact hf' have hA0 : 0 ≤ ip G ((zigzag G H e).step f) ((zigzag G H e).step f) := ip_nonneg G _ - have hB0 : 0 ≤ ip G f f := ip_nonneg G f -- the test vector `g = (1/lam) • T f`, or `T f` itself in the degenerate case have hmain : ∀ c : ℝ, 0 < c → 2 * (ip G ((zigzag G H e).step f) ((zigzag G H e).step f) * c) @@ -886,7 +884,6 @@ theorem spectralBound_zigzag {lamG lamH : ℝ} (hG : G.SpectralBound lamG) rw [sum_sq_eq_ip, sum_sq_eq_ip, hz, ← h0] norm_num · have hc := hmain (1 / (lamG + lamH + lamH ^ 2)) (by positivity) - have hne : lamG + lamH + lamH ^ 2 ≠ 0 := ne_of_gt hpos have hsimp : (lamG + lamH + lamH ^ 2) * (ip G f f + (1 / (lamG + lamH + lamH ^ 2)) ^ 2 * ip G ((zigzag G H e).step f) ((zigzag G H e).step f)) From 9b9a6901223377d122f07b26f788c05e7c5e8809 Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Sat, 29 Aug 2026 12:17:17 -0700 Subject: [PATCH 23/24] claude dedup pass --- Complexitylib/Classes/PCP/Internal.lean | 8 - .../Classes/PCP/Internal/CNFCount.lean | 9 - .../PCP/Internal/ExpanderAssemble.lean | 285 -------------- .../Classes/PCP/Internal/ExpanderMerge.lean | 360 ++---------------- .../Classes/PCP/Internal/FamilyFin.lean | 18 +- .../Classes/PCP/Internal/KilledCSP.lean | 9 +- .../Classes/PCP/Internal/KilledWalk.lean | 3 +- .../Classes/PCP/Internal/Margulis.lean | 2 +- .../Classes/PCP/Internal/MergeGen.lean | 1 + .../Classes/PCP/Internal/PadCSP.lean | 163 -------- .../Classes/PCP/Internal/PadVerts.lean | 90 ----- .../Classes/PCP/Internal/Plurality.lean | 129 ------- .../Classes/PCP/Internal/PowerCSP.lean | 244 ------------ .../Classes/PCP/Internal/SizedExpander.lean | 137 ------- .../PCP/Internal/SizedExpanderize.lean | 117 ------ .../Classes/PCP/Internal/SubsetNP.lean | 12 +- .../Classes/PCP/Internal/TowerFamily.lean | 278 -------------- .../Classes/PCP/Internal/TowerFin.lean | 15 - .../Classes/PCP/Internal/UnaryDivMod.lean | 6 +- .../PCP/Internal/ZigZagBaseExists.lean | 12 +- .../Classes/PCP/Internal/ZigZagTower.lean | 2 +- Complexitylib/SAT/CookLevin.lean | 12 +- Complexitylib/SAT/Rename.lean | 13 +- 23 files changed, 51 insertions(+), 1874 deletions(-) delete mode 100644 Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/PadCSP.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/PadVerts.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/Plurality.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/PowerCSP.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/SizedExpander.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean delete mode 100644 Complexitylib/Classes/PCP/Internal/TowerFamily.lean diff --git a/Complexitylib/Classes/PCP/Internal.lean b/Complexitylib/Classes/PCP/Internal.lean index 3de5d284..765a4b86 100644 --- a/Complexitylib/Classes/PCP/Internal.lean +++ b/Complexitylib/Classes/PCP/Internal.lean @@ -35,7 +35,6 @@ public import Complexitylib.Classes.PCP.Internal.Dinur public import Complexitylib.Classes.PCP.Internal.Disagreement public import Complexitylib.Classes.PCP.Internal.EdgeExpansion public import Complexitylib.Classes.PCP.Internal.Expander -public import Complexitylib.Classes.PCP.Internal.ExpanderAssemble public import Complexitylib.Classes.PCP.Internal.ExpanderExists public import Complexitylib.Classes.PCP.Internal.ExpanderMerge public import Complexitylib.Classes.PCP.Internal.ExpanderPad @@ -61,24 +60,18 @@ public import Complexitylib.Classes.PCP.Internal.Mixing public import Complexitylib.Classes.PCP.Internal.NatEncode public import Complexitylib.Classes.PCP.Internal.PCPtoSAT public import Complexitylib.Classes.PCP.Internal.Pad -public import Complexitylib.Classes.PCP.Internal.PadCSP -public import Complexitylib.Classes.PCP.Internal.PadVerts public import Complexitylib.Classes.PCP.Internal.PermArith public import Complexitylib.Classes.PCP.Internal.PermCount public import Complexitylib.Classes.PCP.Internal.PermGraph -public import Complexitylib.Classes.PCP.Internal.Plurality public import Complexitylib.Classes.PCP.Internal.PosScan public import Complexitylib.Classes.PCP.Internal.PositionsFP public import Complexitylib.Classes.PCP.Internal.Power -public import Complexitylib.Classes.PCP.Internal.PowerCSP public import Complexitylib.Classes.PCP.Internal.PoweringBound public import Complexitylib.Classes.PCP.Internal.Preprocess public import Complexitylib.Classes.PCP.Internal.RegCSP public import Complexitylib.Classes.PCP.Internal.RegularGraph public import Complexitylib.Classes.PCP.Internal.SecondMoment public import Complexitylib.Classes.PCP.Internal.SelfLoops -public import Complexitylib.Classes.PCP.Internal.SizedExpander -public import Complexitylib.Classes.PCP.Internal.SizedExpanderize public import Complexitylib.Classes.PCP.Internal.SquareVerifier public import Complexitylib.Classes.PCP.Internal.StripTrailing public import Complexitylib.Classes.PCP.Internal.SubsetNP @@ -88,7 +81,6 @@ public import Complexitylib.Classes.PCP.Internal.TesterChecks public import Complexitylib.Classes.PCP.Internal.TesterCore public import Complexitylib.Classes.PCP.Internal.TesterInput public import Complexitylib.Classes.PCP.Internal.ThreeSATReduction -public import Complexitylib.Classes.PCP.Internal.TowerFamily public import Complexitylib.Classes.PCP.Internal.UnaryDivMod public import Complexitylib.Classes.PCP.Internal.UnaryExp public import Complexitylib.Classes.PCP.Internal.Union diff --git a/Complexitylib/Classes/PCP/Internal/CNFCount.lean b/Complexitylib/Classes/PCP/Internal/CNFCount.lean index ed1f934a..c7ef9f6f 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFCount.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFCount.lean @@ -131,15 +131,6 @@ theorem ccStep_iterate : ∀ (k : ℕ) (c s : List Bool), s.length ≤ 2 * k → /-! ### The scan as one function -/ -theorem length_selectHead_le (s x y : List Bool) : - (Cobham.selectHead s x y).length ≤ max x.length y.length := by - rw [Cobham.selectHead] - split - · exact le_max_left _ _ - · split - · exact le_max_right _ _ - · simp - theorem ccStep_one (c s : List Bool) : ∃ X Y, ccStep (pair c s) = pair X Y ∧ X.length ≤ c.length + 1 ∧ Y.length ≤ s.length := by diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean b/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean deleted file mode 100644 index 0d8ee3f1..00000000 --- a/Complexitylib/Classes/PCP/Internal/ExpanderAssemble.lean +++ /dev/null @@ -1,285 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.ExpanderMerge -public import Complexitylib.Classes.PCP.Internal.ExpanderPad -public import Complexitylib.Classes.PCP.Internal.Power -public import Complexitylib.Classes.PCP.Internal.Clique - -/-! -# An expander family from expanders of square size - -Explicit constructions such as Margulis's live on `m × m` grids. This module -turns a family on the squares into an `ExpanderFamily` on every vertex count: - -* the square graphs are powered until the bound is at most `1/2`, and their - darts renamed to a `Fin`; -* for `n ≥ 10` a square `N = m²` with `2n ≤ N ≤ 3n` exists, and the merge of - `ExpanderMerge` gives a graph on `n` vertices; -* for `n < 10` a clique with loops does, padded up to the common degree. - -## Main definitions - -- `Complexity.SquareFamily` — expanders on every `m * m` -- `Complexity.SquareFamily.toFamily` — the derived `ExpanderFamily` --/ - -@[expose] public section - -namespace Complexity - -/-- A family of constant-degree expanders on the squares `m * m`. -/ -structure SquareFamily where - /-- The constant degree. -/ - degree : ℕ - /-- The degree is positive. -/ - degree_pos : 0 < degree - /-- The rotation map on `m * m` vertices. -/ - rot : ∀ m : ℕ, Fin (m * m) × Fin degree → Fin (m * m) × Fin degree - /-- Each rotation map is an involution. -/ - rot_involutive : ∀ m, Function.Involutive (rot m) - /-- The uniform contraction factor. -/ - lam : ℝ - /-- The factor is nonnegative. -/ - lam_nonneg : 0 ≤ lam - /-- The factor is below one. -/ - lam_lt_one : lam < 1 - /-- Every member contracts mean-zero functions by `lam`. -/ - spectral : ∀ m : ℕ, - (RegGraph.ofRot degree degree_pos (m * m) (rot m) (rot_involutive m)).SpectralBound lam - -/-! ### A square between `2n` and `3n` -/ - -/-- For `n ≥ 10`, `(⌊√(2n)⌋ + 1)²` lies in `[2n, 3n]`. -/ -theorem sq_between (n : ℕ) (hn : 10 ≤ n) : - 2 * n ≤ (Nat.sqrt (2 * n) + 1) * (Nat.sqrt (2 * n) + 1) - ∧ (Nat.sqrt (2 * n) + 1) * (Nat.sqrt (2 * n) + 1) ≤ 3 * n := by - set s := Nat.sqrt (2 * n) with hs - have h1 : 2 * n < (s + 1) * (s + 1) := Nat.lt_succ_sqrt (2 * n) - have h2 : s * s ≤ 2 * n := Nat.sqrt_le (2 * n) - refine ⟨h1.le, ?_⟩ - -- `2 s + 1 ≤ n` since otherwise `n² ≤ 4 s² ≤ 8 n` - nlinarith - -/-! ### The empty graph -/ - -/-- The empty graph satisfies every bound. -/ -theorem spectralBound_zero (D : ℕ) (hD : 0 < D) (lam : ℝ) : - (RegGraph.ofRot D hD 0 id (fun _ => rfl)).SpectralBound lam := by - intro f _ - show (∑ v : Fin 0, ((RegGraph.ofRot D hD 0 id (fun _ => rfl)).step f v) ^ 2) - ≤ lam ^ 2 * ∑ v : Fin 0, (f v) ^ 2 - simp - -namespace SquareFamily - -variable (S : SquareFamily) - -/-! ### Powering the squares -/ - -theorem exists_pow_le_half : ∃ t : ℕ, S.lam ^ t ≤ 1 / 2 := by - obtain ⟨t, ht⟩ := exists_pow_lt_of_lt_one (by norm_num : (0 : ℝ) < 1 / 2) S.lam_lt_one - exact ⟨t, ht.le⟩ - -/-- The powering exponent: enough to bring the bound below one half. -/ -noncomputable def powExp : ℕ := Classical.choose S.exists_pow_le_half - -theorem pow_le_half : S.lam ^ S.powExp ≤ 1 / 2 := Classical.choose_spec S.exists_pow_le_half - -theorem pow_nonneg' : 0 ≤ S.lam ^ S.powExp := pow_nonneg S.lam_nonneg _ - -/-- The degree after powering. -/ -noncomputable def powDeg : ℕ := S.degree ^ S.powExp - -theorem powDeg_pos : 0 < S.powDeg := pow_pos S.degree_pos _ - -/-- Walk labels as a `Fin`. -/ -noncomputable def dartEquiv : (Fin S.powExp → Fin S.degree) ≃ Fin S.powDeg := - Fintype.equivFinOfCardEq (by rw [Fintype.card_fun, Fintype.card_fin, Fintype.card_fin]; rfl) - -/-- The powered square graph, with `Fin` darts. -/ -noncomputable def square (m : ℕ) : RegGraph := - ((RegGraph.ofRot S.degree S.degree_pos (m * m) (S.rot m) (S.rot_involutive m)).power - S.powExp).relabel S.dartEquiv - -theorem spectral_square (m : ℕ) : (S.square m).SpectralBound (S.lam ^ S.powExp) := - RegGraph.spectralBound_relabel _ _ (RegGraph.spectralBound_power _ (S.spectral m) _) - -/-- The powered square as rotation data. -/ -noncomputable def squareRot (m : ℕ) : Fin (m * m) × Fin S.powDeg → Fin (m * m) × Fin S.powDeg := - (S.square m).rot - -theorem squareRot_involutive (m : ℕ) : Function.Involutive (S.squareRot m) := - (S.square m).rot_involutive - -theorem spectral_squareRot (m : ℕ) : - (RegGraph.ofRot S.powDeg S.powDeg_pos (m * m) (S.squareRot m) - (S.squareRot_involutive m)).SpectralBound (S.lam ^ S.powExp) := - S.spectral_square m - -/-! ### The common degree -/ - -/-- The degree of the derived family. -/ -noncomputable def famDeg : ℕ := 3 * S.powDeg + 10 - -theorem famDeg_pos : 0 < S.famDeg := by rw [famDeg]; omega - -/-! ### Large `n`: merge -/ - -/-- The side of the square used for `n`. -/ -def mVal (n : ℕ) : ℕ := Nat.sqrt (2 * n) + 1 - -theorem mVal_spec {n : ℕ} (hn : 10 ≤ n) : - 2 * n ≤ mVal n * mVal n ∧ mVal n * mVal n ≤ 3 * n := sq_between n hn - -/-- The graph on `n ≥ 10` vertices: the merge of a powered square, padded to the -common degree. -/ -noncomputable def bigGraph (n : ℕ) (hn : 10 ≤ n) : RegGraph := - (((RegGraph.merged (N := mVal n * mVal n) (d := S.powDeg) (by omega) S.powDeg_pos - (mVal_spec hn).2 (S.squareRot (mVal n)) (S.squareRot_involutive (mVal n))).relabel - (finProdFinEquiv : Fin 3 × Fin S.powDeg ≃ Fin (3 * S.powDeg))).padLoops 10).relabel - (finSumFinEquiv : Fin (3 * S.powDeg) ⊕ Fin 10 ≃ Fin (3 * S.powDeg + 10)) - -/-- The bound for the large case. -/ -noncomputable def bigLam : ℝ := - Real.sqrt ((3 * (S.powDeg : ℝ) * (17 / 24) + 10) / (3 * (S.powDeg : ℝ) + 10)) - -theorem bigLam_lt_one : S.bigLam < 1 := by - rw [bigLam, Real.sqrt_lt' one_pos, one_pow, div_lt_one (by positivity)] - have : (0 : ℝ) < S.powDeg := by exact_mod_cast S.powDeg_pos - nlinarith - -theorem bigLam_nonneg : 0 ≤ S.bigLam := Real.sqrt_nonneg _ - -theorem spectral_bigGraph (n : ℕ) (hn : 10 ≤ n) : (S.bigGraph n hn).SpectralBound S.bigLam := by - have hl := S.pow_le_half - have hl0 := S.pow_nonneg' - have hl2 : (S.lam ^ S.powExp) ^ 2 ≤ 1 := by nlinarith - have hmerged := RegGraph.spectralBound_merged (N := mVal n * mVal n) (d := S.powDeg) - (by omega : 0 < n) S.powDeg_pos (mVal_spec hn).2 (S.squareRot (mVal n)) - (S.squareRot_involutive (mVal n)) hl2 (S.spectral_squareRot (mVal n)) (mVal_spec hn).1 - have hrel := RegGraph.spectralBound_relabel _ - (finProdFinEquiv : Fin 3 × Fin S.powDeg ≃ Fin (3 * S.powDeg)) hmerged - have hpad := RegGraph.spectralBound_padLoops _ 10 hrel - have hrel2 := RegGraph.spectralBound_relabel _ - (finSumFinEquiv : Fin (3 * S.powDeg) ⊕ Fin 10 ≃ Fin (3 * S.powDeg + 10)) hpad - refine hrel2.mono (Real.sqrt_nonneg _) ?_ - rw [bigLam] - apply Real.sqrt_le_sqrt - rw [RegGraph.deg_relabel, RegGraph.deg_merged] - push_cast - rw [Real.sq_sqrt (by positivity)] - have hD : (0 : ℝ) < 3 * (S.powDeg : ℝ) + 10 := by positivity - rw [div_le_div_iff_of_pos_right hD] - have hmu : 1 / 2 + 5 * (S.lam ^ S.powExp) ^ 2 / 6 ≤ 17 / 24 := by nlinarith - have : (0 : ℝ) ≤ 3 * (S.powDeg : ℝ) := by positivity - nlinarith - -/-! ### Small `n`: cliques -/ - -/-- The graph on `0 < n < 10` vertices: a clique with loops, padded. -/ -noncomputable def smallGraph (n : ℕ) (hn : 0 < n) (hle : n ≤ S.famDeg) : RegGraph := - ((RegGraph.cliqueLoops n hn).padLoops (S.famDeg - n)).relabel - ((finSumFinEquiv : Fin n ⊕ Fin (S.famDeg - n) ≃ Fin (n + (S.famDeg - n))).trans - (finCongr (Nat.add_sub_cancel' hle) : Fin (n + (S.famDeg - n)) ≃ Fin S.famDeg)) - -/-- The bound for the small case. -/ -noncomputable def smallLam : ℝ := Real.sqrt (((S.famDeg : ℝ) - 1) / S.famDeg) - -theorem smallLam_lt_one : S.smallLam < 1 := by - have : (0 : ℝ) < S.famDeg := by exact_mod_cast S.famDeg_pos - rw [smallLam, Real.sqrt_lt' one_pos, one_pow, div_lt_one this] - linarith - -theorem smallLam_nonneg : 0 ≤ S.smallLam := Real.sqrt_nonneg _ - -theorem deg_cliqueLoops (n : ℕ) (hn : 0 < n) : (RegGraph.cliqueLoops n hn).deg = n := - Fintype.card_fin n - -theorem spectral_smallGraph (n : ℕ) (hn : 0 < n) (hle : n ≤ S.famDeg) : - (S.smallGraph n hn hle).SpectralBound S.smallLam := by - have hpad := RegGraph.spectralBound_padLoops _ (S.famDeg - n) - (RegGraph.spectralBound_cliqueLoops hn) - have hrel := RegGraph.spectralBound_relabel _ - ((finSumFinEquiv : Fin n ⊕ Fin (S.famDeg - n) ≃ Fin (n + (S.famDeg - n))).trans - (finCongr (Nat.add_sub_cancel' hle) : Fin (n + (S.famDeg - n)) ≃ Fin S.famDeg)) hpad - refine hrel.mono (Real.sqrt_nonneg _) ?_ - rw [smallLam] - apply Real.sqrt_le_sqrt - rw [deg_cliqueLoops] - have hcast : ((S.famDeg - n : ℕ) : ℝ) = (S.famDeg : ℝ) - n := by - rw [Nat.cast_sub hle] - rw [hcast] - have hn' : (1 : ℝ) ≤ n := by exact_mod_cast hn - have hD : (0 : ℝ) < S.famDeg := by exact_mod_cast S.famDeg_pos - have hsum : (n : ℝ) + ((S.famDeg : ℝ) - n) = S.famDeg := by ring - rw [hsum, div_le_div_iff_of_pos_right hD] - nlinarith - -/-! ### The family -/ - -theorem le_famDeg {n : ℕ} (h : ¬ 10 ≤ n) : n ≤ S.famDeg := by rw [famDeg]; omega - -/-- The rotation map on `n` vertices, by cases. -/ -noncomputable def famRot (n : ℕ) : Fin n × Fin S.famDeg → Fin n × Fin S.famDeg := - if h : 10 ≤ n then (S.bigGraph n h).rot - else if h0 : 0 < n then (S.smallGraph n h0 (S.le_famDeg h)).rot - else id - -theorem famRot_involutive (n : ℕ) : Function.Involutive (S.famRot n) := by - intro x - unfold famRot - split_ifs with h h0 - · exact (S.bigGraph n h).rot_involutive x - · exact (S.smallGraph n h0 _).rot_involutive x - · rfl - -/-- The uniform bound. -/ -noncomputable def famLam : ℝ := max S.bigLam S.smallLam - -theorem famLam_nonneg : 0 ≤ S.famLam := le_max_of_le_left S.bigLam_nonneg - -theorem famLam_lt_one : S.famLam < 1 := max_lt S.bigLam_lt_one S.smallLam_lt_one - -theorem spectral_fam (n : ℕ) : - (RegGraph.ofRot S.famDeg S.famDeg_pos n (S.famRot n) (S.famRot_involutive n)).SpectralBound - S.famLam := by - by_cases h : 10 ≤ n - · have hb := S.spectral_bigGraph n h - have heq : RegGraph.ofRot S.famDeg S.famDeg_pos n (S.famRot n) (S.famRot_involutive n) - = S.bigGraph n h := by - unfold famRot - simp only [dif_pos h] - rfl - rw [heq] - exact hb.mono S.bigLam_nonneg (le_max_left _ _) - · by_cases h0 : 0 < n - · have hs := S.spectral_smallGraph n h0 (S.le_famDeg h) - have heq : RegGraph.ofRot S.famDeg S.famDeg_pos n (S.famRot n) (S.famRot_involutive n) - = S.smallGraph n h0 (S.le_famDeg h) := by - unfold famRot - simp only [dif_neg h, dif_pos h0] - rfl - rw [heq] - exact hs.mono S.smallLam_nonneg (le_max_right _ _) - · have hz : n = 0 := by omega - subst hz - exact spectralBound_zero _ _ _ - -/-- **The derived expander family.** -/ -noncomputable def toFamily : ExpanderFamily where - degree := S.famDeg - degree_pos := S.famDeg_pos - rot := S.famRot - rot_involutive := S.famRot_involutive - lam := S.famLam - lam_nonneg := S.famLam_nonneg - lam_lt_one := S.famLam_lt_one - spectral := S.spectral_fam - -end SquareFamily - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean b/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean index fda51783..accc8433 100644 --- a/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean +++ b/Complexitylib/Classes/PCP/Internal/ExpanderMerge.lean @@ -6,40 +6,37 @@ Authors: Bolton Bailey module public import Complexitylib.Classes.PCP.Internal.Expander public import Complexitylib.Classes.PCP.Internal.Mixing -public import Mathlib.Algebra.Order.Chebyshev -public import Mathlib.Data.Real.Sqrt /-! -# Expanders on every vertex count, by merging +# The pieces a merge is built from Explicit expander constructions come in special sizes — squares, powers — but -`ExpanderFamily` wants a member on *every* `n`. This module closes the gap: an -expander on `N` vertices with `2n ≤ N ≤ 3n` is folded onto `n` vertices by -identifying `u` with `u mod n`. Every new vertex absorbs two or three old ones, -so the degree triples, with self-loops padding the vertices that absorbed only -two. +`ExpanderFamily` wants a member on *every* `n`. An expander on `N` vertices is +folded onto `n` of them by identifying `u` with `u mod n`, with self-loops +padding the fibres that come up short. `MergeGen` carries out that fold at an +arbitrary width; this module holds the two ingredients it rests on. -The spectral bound survives, with an explicit loss. Write `f` for a mean-zero -function on the merged graph and `F = f ∘ π` for its lift. The merged step at -`v` is the average of the old steps at the two or three vertices over `v`, -together with `f v` itself for each padding loop, so by Jensen its square is at -most the average of their squares. Summing, the old steps contribute at most -`λ² ‖F‖² + (1 - λ²) N c²` where `c` is the mean of `F` — nonzero, because the -heavier fibres weigh more — and `N c²` is at most half of `‖f‖²` because the -heavy fibres number fewer than `n ≤ N / 2`. The padding loops contribute at -most `‖f‖²`. Altogether the new factor is `μ² = 1/2 + 5λ²/6`, below one as soon -as `λ² < 3/5`, which powering the base graph guarantees. +The first is the estimate on the old steps. Write `f` for a function on the +merged graph and `F = f ∘ π` for its lift. Splitting `F` into its mean and its +centred part and applying the base's spectral bound to the latter gives +`λ² ‖F‖² + (1 - λ²) N c²`, where `c` is the mean of `F` — nonzero, because the +heavier fibres weigh more. + +The second is that the fibres stay *balanced*: with `(m - 1) n ≤ N` at most one +of a vertex's `m` slots is empty, so however large the width, the padding costs +one loop per vertex. ## Main definitions -- `Complexity.RegGraph.mergeRot` — the merged rotation map -- `Complexity.RegGraph.merged` — the merged graph +- `Complexity.RegGraph.proj` — the new vertex an old one lands on +- `Complexity.RegGraph.liftN` — the old vertex in a given slot of a fibre ## Main results -- `Complexity.RegGraph.spectralBound_merged` — the spectral bound of the merge -- `Complexity.liftN`, `Complexity.card_liftN_none_le_one` — the balanced fibres - a general merge needs +- `Complexity.RegGraph.sum_sq_step_lift_le` — the old steps, with the mean + corrected +- `Complexity.RegGraph.card_liftN_none_le_one` — the balanced fibres a general + merge needs -/ @[expose] public section @@ -50,95 +47,11 @@ namespace RegGraph variable {N d n : ℕ} -/-! ### The merged rotation map -/ - -/-- The old vertex numbered `i` in the fibre over `v`, if it exists. -/ -def lift (N n : ℕ) (v : Fin n) (i : Fin 3) : Option (Fin N) := - if h : v.val + i.val * n < N then some ⟨v.val + i.val * n, h⟩ else none +/-! ### The fibres of a merge -/ /-- The new vertex an old vertex lands on. -/ def proj (n : ℕ) (hn : 0 < n) (u : Fin N) : Fin n := ⟨u.val % n, Nat.mod_lt _ hn⟩ -/-- The position of an old vertex in its fibre; below three when `N ≤ 3 n`. -/ -def slot (n : ℕ) (hN : N ≤ 3 * n) (u : Fin N) : Fin 3 := - ⟨u.val / n, by - rcases Nat.eq_zero_or_pos n with h0 | h0 - · subst h0; omega - · have := u.isLt - rw [Nat.div_lt_iff_lt_mul h0] - omega⟩ - -theorem lift_proj_slot (hn : 0 < n) (hN : N ≤ 3 * n) (u : Fin N) : - lift N n (proj n hn u) (slot n hN u) = some u := by - simp only [lift, proj, slot] - have h : u.val % n + u.val / n * n = u.val := by - rw [mul_comm]; exact Nat.mod_add_div u.val n - rw [dif_pos (by rw [h]; exact u.isLt)] - congr 1 - exact Fin.ext h - -theorem proj_lift (hn : 0 < n) (v : Fin n) (i : Fin 3) (u : Fin N) - (h : lift N n v i = some u) : proj n hn u = v := by - simp only [lift] at h - split_ifs at h with hlt - · simp only [Option.some.injEq] at h - rw [← h] - simp only [proj] - apply Fin.ext - show (v.val + i.val * n) % n = v.val - rw [Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt v.isLt] - -theorem slot_lift (hN : N ≤ 3 * n) (v : Fin n) (i : Fin 3) (u : Fin N) - (h : lift N n v i = some u) : slot n hN u = i := by - simp only [lift] at h - split_ifs at h with hlt - · simp only [Option.some.injEq] at h - rw [← h] - apply Fin.ext - show (v.val + i.val * n) / n = i.val - have hn : 0 < n := by omega - rw [Nat.add_mul_div_right _ _ hn, Nat.div_eq_of_lt v.isLt, zero_add] - -/-- The merged rotation map: a real dart follows the old rotation and is -re-addressed; a padding dart is a self-loop. -/ -def mergeRot (hn : 0 < n) (hN : N ≤ 3 * n) (rot : Fin N × Fin d → Fin N × Fin d) - (x : Fin n × (Fin 3 × Fin d)) : Fin n × (Fin 3 × Fin d) := - match lift N n x.1 x.2.1 with - | some u => - let y := rot (u, x.2.2) - (proj n hn y.1, (slot n hN y.1, y.2)) - | none => x - -theorem mergeRot_involutive (hn : 0 < n) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : - Function.Involutive (mergeRot hn hN rot) := by - intro x - obtain ⟨v, i, s⟩ := x - simp only [mergeRot] - cases hl : lift N n v i with - | none => simp [hl] - | some u => - simp only - rw [lift_proj_slot hn hN] - simp only - rcases hrs : rot (u, s) with ⟨u', s'⟩ - have hy : rot (u', s') = (u, s) := by rw [← hrs]; exact hrot (u, s) - simp only [hy, Prod.mk.injEq] - exact ⟨proj_lift hn v i u hl, slot_lift hN v i u hl, trivial⟩ - -/-- **The merged graph**: `n` vertices of degree `3 d`. -/ -def merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : RegGraph where - V := Fin n - D := Fin 3 × Fin d - decEqV := inferInstance - decEqD := inferInstance - fintypeV := inferInstance - fintypeD := inferInstance - nonemptyD := ⟨(0, ⟨0, hd⟩)⟩ - rot := mergeRot hn hN rot - rot_involutive := mergeRot_involutive hn hN rot hrot - /-! ### The spectral bound -/ section Spectral @@ -147,190 +60,6 @@ section Spectral abbrev base (hd : 0 < d) (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : RegGraph := ofRot d hd N rot hrot -/-- A term of the merged step at `v`: the old step at the `i`-th vertex over -`v`, or `f v` for a padding loop. -/ -noncomputable def term (hn : 0 < n) (hd : 0 < d) (rot : Fin N × Fin d → Fin N × Fin d) - (hrot : Function.Involutive rot) (f : Fin n → ℝ) (v : Fin n) (i : Fin 3) : ℝ := - match lift N n v i with - | some u => (base hd rot hrot).step (fun w => f (proj n hn w)) u - | none => f v - -theorem deg_merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) : - (merged hn hd hN rot hrot).deg = 3 * d := by - show Fintype.card (Fin 3 × Fin d) = 3 * d - rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] - -/-- **The merged step is the average of its terms.** -/ -theorem step_merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) - (f : Fin n → ℝ) (v : Fin n) : - (merged hn hd hN rot hrot).step f v = (∑ i : Fin 3, term hn hd rot hrot f v i) / 3 := by - have hd' : (d : ℝ) ≠ 0 := by exact_mod_cast hd.ne' - rw [step, deg_merged] - show (∑ x : Fin 3 × Fin d, f (mergeRot hn hN rot (v, x)).1) / ((3 * d : ℕ) : ℝ) = _ - rw [Fintype.sum_prod_type] - have hinner : ∀ i : Fin 3, ∑ s : Fin d, f (mergeRot hn hN rot (v, (i, s))).1 - = d * term hn hd rot hrot f v i := by - intro i - simp only [mergeRot, term] - cases hl : lift N n v i with - | none => - simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] - | some u => - simp only - rw [step, deg_ofRot] - show _ = (d : ℝ) * ((∑ i : Fin d, f (proj n hn (rot (u, i)).1)) / (d : ℝ)) - field_simp - rw [Finset.sum_congr rfl fun i _ => hinner i, ← Finset.mul_sum] - push_cast - field_simp - -/-- **Jensen**: the square of the average is at most the average of the squares. -/ -theorem sq_step_merged_le (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) - (f : Fin n → ℝ) (v : Fin n) : - ((merged hn hd hN rot hrot).step f v) ^ 2 - ≤ (∑ i : Fin 3, (term hn hd rot hrot f v i) ^ 2) / 3 := by - rw [step_merged, div_pow] - have h := sq_sum_le_card_mul_sum_sq (s := (Finset.univ : Finset (Fin 3))) - (f := term hn hd rot hrot f v) - rw [Finset.card_univ, Fintype.card_fin] at h - have h3 : (0 : ℝ) < 3 ^ 2 := by norm_num - rw [div_le_div_iff₀ h3 (by norm_num)] - push_cast at h - nlinarith [h] - -/-- The pairs `(v, i)` naming an old vertex, as the image of the old vertices. -/ -theorem sum_over_lift (hn : 0 < n) (hN : N ≤ 3 * n) (g : Fin N → ℝ) : - ∑ p : Fin n × Fin 3, (match lift N n p.1 p.2 with | some u => g u | none => 0) - = ∑ u : Fin N, g u := by - classical - have hinj : Function.Injective fun u : Fin N => (proj n hn u, slot n hN u) := by - intro u u' h - have h1 := lift_proj_slot hn hN u - have h2 := lift_proj_slot hn hN u' - simp only [Prod.mk.injEq] at h - rw [h.1, h.2, h2] at h1 - exact (Option.some.inj h1).symm - symm - calc ∑ u : Fin N, g u - = ∑ u : Fin N, (match lift N n (proj n hn u) (slot n hN u) with - | some u' => g u' | none => 0) := by - refine Finset.sum_congr rfl fun u _ => ?_ - rw [lift_proj_slot hn hN] - _ = ∑ p ∈ Finset.univ.image (fun u : Fin N => (proj n hn u, slot n hN u)), - (match lift N n p.1 p.2 with | some u' => g u' | none => 0) := by - rw [Finset.sum_image (fun u _ u' _ h => hinj h)] - _ = ∑ p : Fin n × Fin 3, (match lift N n p.1 p.2 with | some u' => g u' | none => 0) := by - refine Finset.sum_subset (Finset.subset_univ _) fun p _ hp => ?_ - cases hl : lift N n p.1 p.2 with - | none => rfl - | some u => - exfalso - apply hp - rw [Finset.mem_image] - refine ⟨u, Finset.mem_univ _, ?_⟩ - rw [proj_lift hn _ _ u hl, slot_lift hN _ _ u hl] - -theorem lift_zero (h2 : 2 * n ≤ N) (v : Fin n) : lift N n v 0 = some ⟨v.val, by omega⟩ := by - simp only [lift, Fin.val_zero, zero_mul, add_zero] - rw [dif_pos (by omega)] - -theorem lift_one (h2 : 2 * n ≤ N) (v : Fin n) : - lift N n v 1 = some ⟨v.val + n, by omega⟩ := by - simp only [lift, Fin.val_one, one_mul] - rw [dif_pos (by omega)] - -/-- **Splitting the terms**: the old steps, plus at most one padding loop per -vertex. -/ -theorem sum_sq_term_le (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) - (h2 : 2 * n ≤ N) (f : Fin n → ℝ) : - ∑ v : Fin n, ∑ i : Fin 3, (term hn hd rot hrot f v i) ^ 2 - ≤ (∑ u : Fin N, ((base hd rot hrot).step (fun w => f (proj n hn w)) u) ^ 2) - + ∑ v : Fin n, (f v) ^ 2 := by - classical - have hsplit : ∀ v i, (term hn hd rot hrot f v i) ^ 2 - = (match lift N n v i with - | some u => ((base hd rot hrot).step (fun w => f (proj n hn w)) u) ^ 2 - | none => 0) - + (match lift N n v i with | some _ => 0 | none => (f v) ^ 2) := by - intro v i - simp only [term] - cases lift N n v i <;> simp - simp_rw [hsplit, Finset.sum_add_distrib] - rw [← Fintype.sum_prod_type', sum_over_lift hn hN] - refine add_le_add le_rfl (Finset.sum_le_sum fun v _ => ?_) - rw [Fin.sum_univ_three, lift_zero h2, lift_one h2] - simp only [zero_add] - cases lift N n v 2 with - | some _ => show (0 : ℝ) ≤ f v ^ 2; exact sq_nonneg _ - | none => show f v ^ 2 ≤ f v ^ 2; exact le_rfl - -/-- **The lift's squares**: each `f v` is counted at most three times. -/ -theorem sum_sq_lift_le (hn : 0 < n) (hN : N ≤ 3 * n) (f : Fin n → ℝ) : - ∑ u : Fin N, (f (proj n hn u)) ^ 2 ≤ 3 * ∑ v : Fin n, (f v) ^ 2 := by - classical - have h := sum_over_lift hn hN (fun u => (f (proj n hn u)) ^ 2) - rw [← h, Fintype.sum_prod_type, Finset.mul_sum] - refine Finset.sum_le_sum fun v _ => ?_ - have : ∀ i : Fin 3, (match lift N n v i with | some u => (f (proj n hn u)) ^ 2 | none => 0) - ≤ (f v) ^ 2 := by - intro i - cases hl : lift N n v i with - | none => show (0 : ℝ) ≤ f v ^ 2; exact sq_nonneg _ - | some u => simp only; rw [proj_lift hn v i u hl] - calc ∑ i : Fin 3, (match lift N n v i with | some u => (f (proj n hn u)) ^ 2 | none => 0) - ≤ ∑ _i : Fin 3, (f v) ^ 2 := Finset.sum_le_sum fun i _ => this i - _ = 3 * (f v) ^ 2 := by simp - -/-- **The lift's sum** is the sum over the heavy fibres, when `f` has mean zero. -/ -theorem sum_lift_eq (hn : 0 < n) (hN : N ≤ 3 * n) (h2 : 2 * n ≤ N) (f : Fin n → ℝ) - (hf : ∑ v, f v = 0) : - ∑ u : Fin N, f (proj n hn u) - = ∑ v : Fin n, (match lift N n v 2 with | some _ => f v | none => 0) := by - classical - have h := sum_over_lift hn hN (fun u => f (proj n hn u)) - rw [← h, Fintype.sum_prod_type] - have hv : ∀ v : Fin n, ∑ i : Fin 3, - (match lift N n v i with | some u => f (proj n hn u) | none => 0) - = 2 * f v + (match lift N n v 2 with | some _ => f v | none => 0) := by - intro v - rw [Fin.sum_univ_three, lift_zero h2, lift_one h2] - simp only - rw [proj_lift hn v 0 _ (lift_zero h2 v), proj_lift hn v 1 _ (lift_one h2 v)] - cases hl : lift N n v 2 with - | none => simp; ring - | some u => simp only; rw [proj_lift hn v 2 u hl]; ring - rw [Finset.sum_congr rfl fun v _ => hv v, Finset.sum_add_distrib, ← Finset.mul_sum, hf] - ring - -/-- **The mean of the lift is small**: `N c² ≤ ‖f‖² / 2`. -/ -theorem sq_sum_lift_le (hn : 0 < n) (hN : N ≤ 3 * n) (h2 : 2 * n ≤ N) (f : Fin n → ℝ) - (hf : ∑ v, f v = 0) : - (∑ u : Fin N, f (proj n hn u)) ^ 2 ≤ (n : ℝ) * ∑ v : Fin n, (f v) ^ 2 := by - classical - rw [sum_lift_eq hn hN h2 f hf] - set H : Finset (Fin n) := Finset.univ.filter fun v => (lift N n v 2).isSome with hH - have hsum : ∑ v : Fin n, (match lift N n v 2 with | some _ => f v | none => 0) - = ∑ v ∈ H, f v := by - rw [hH, Finset.sum_filter] - refine Finset.sum_congr rfl fun v _ => ?_ - cases lift N n v 2 <;> simp - rw [hsum] - have hcs := sq_sum_le_card_mul_sum_sq (s := H) (f := f) - have hcard : (H.card : ℝ) ≤ n := by - have : H.card ≤ Fintype.card (Fin n) := Finset.card_le_univ H - rw [Fintype.card_fin] at this - exact_mod_cast this - have hsub : ∑ v ∈ H, (f v) ^ 2 ≤ ∑ v : Fin n, (f v) ^ 2 := - Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) fun v _ _ => sq_nonneg _ - have h0 : 0 ≤ ∑ v ∈ H, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ - calc (∑ v ∈ H, f v) ^ 2 ≤ H.card * ∑ v ∈ H, (f v) ^ 2 := hcs - _ ≤ n * ∑ v : Fin n, (f v) ^ 2 := by - exact mul_le_mul hcard hsub h0 (by positivity) - /-- **The old steps of the lift**, with the mean corrected. -/ theorem sum_sq_step_lift_le (hn : 0 < n) (hd : 0 < d) (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) {lam : ℝ} (hspec : (base hd rot hrot).SpectralBound lam) @@ -376,51 +105,13 @@ theorem sum_sq_step_lift_le (hn : 0 < n) (hd : 0 < d) (rot : Fin N × Fin d → have hnn : 0 ≤ (∑ u, F u) ^ 2 / (N : ℝ) := by positivity nlinarith [hspec', hnn] -/-- **The spectral bound of the merge.** -/ -theorem spectralBound_merged (hn : 0 < n) (hd : 0 < d) (hN : N ≤ 3 * n) - (rot : Fin N × Fin d → Fin N × Fin d) (hrot : Function.Involutive rot) - {lam : ℝ} (hlam : lam ^ 2 ≤ 1) - (hspec : (base hd rot hrot).SpectralBound lam) (h2 : 2 * n ≤ N) : - (merged hn hd hN rot hrot).SpectralBound (Real.sqrt (1 / 2 + 5 * lam ^ 2 / 6)) := by - intro f hf - have hN0 : 0 < N := by omega - have hN' : (0 : ℝ) < N := by exact_mod_cast hN0 - have hsqrt : Real.sqrt (1 / 2 + 5 * lam ^ 2 / 6) ^ 2 = 1 / 2 + 5 * lam ^ 2 / 6 := - Real.sq_sqrt (by positivity) - rw [hsqrt] - have hf' : ∑ v : Fin n, f v = 0 := hf - have hjensen : ∑ v : Fin n, ((merged hn hd hN rot hrot).step f v) ^ 2 - ≤ (∑ v : Fin n, ∑ i : Fin 3, (term hn hd rot hrot f v i) ^ 2) / 3 := by - rw [Finset.sum_div] - exact Finset.sum_le_sum fun v _ => sq_step_merged_le hn hd hN rot hrot f v - have hterms := sum_sq_term_le hn hd hN rot hrot h2 f - have hold := sum_sq_step_lift_le hn hd rot hrot hspec hN0 f - have hlift := sum_sq_lift_le hn hN f - have hmean := sq_sum_lift_le hn hN h2 f hf' - have hmean' : (∑ u : Fin N, f (proj n hn u)) ^ 2 / (N : ℝ) - ≤ (1 / 2) * ∑ v : Fin n, (f v) ^ 2 := by - rw [div_le_iff₀ hN'] - have h2' : (2 : ℝ) * n ≤ N := by exact_mod_cast h2 - have hS : 0 ≤ ∑ v : Fin n, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ - nlinarith [hmean, h2', hS] - have hS : 0 ≤ ∑ v : Fin n, (f v) ^ 2 := Finset.sum_nonneg fun v _ => sq_nonneg _ - have hl0 : 0 ≤ lam ^ 2 := sq_nonneg _ - have hl1 : 0 ≤ 1 - lam ^ 2 := by linarith - show ∑ v : Fin n, ((merged hn hd hN rot hrot).step f v) ^ 2 - ≤ (1 / 2 + 5 * lam ^ 2 / 6) * ∑ v : Fin n, (f v) ^ 2 - have hA := mul_le_mul_of_nonneg_left hlift hl0 - have hB := mul_le_mul_of_nonneg_left hmean' hl1 - nlinarith [hjensen, hterms, hold, hA, hB] - end Spectral /-! ### Balanced fibres, for a merge of any width -The merge above folds `N ≤ 3 n` vertices onto `n`. To fold the sparse sizes a -zig-zag tower produces, the width has to be arbitrary, and what makes that work -is that the fibres stay *balanced*: with `(m - 1) n ≤ N ≤ m n` every fibre has -`m - 1` or `m` elements, so at most one of the `m` slots is empty and the -padding costs one loop per vertex however large `m` is. +With `(m - 1) n ≤ N ≤ m n` every fibre has `m - 1` or `m` elements, so at most +one of the `m` slots is empty and the padding costs one loop per vertex however +large `m` is. These are the two facts a general merge rests on; they are stated for a natural-number slot index, which is the form the general construction needs. -/ @@ -429,9 +120,6 @@ natural-number slot index, which is the form the general construction needs. -/ def liftN (N n : ℕ) (v : Fin n) (i : ℕ) : Option (Fin N) := if h : v.val + i * n < N then some ⟨v.val + i * n, h⟩ else none -theorem liftN_eq_lift (N n : ℕ) (v : Fin n) (i : Fin 3) : - liftN N n v i.val = lift N n v i := rfl - /-- **Every slot but the last is filled**, when `(m - 1) n ≤ N`. -/ theorem liftN_isSome {N n m : ℕ} (hm : (m - 1) * n ≤ N) (v : Fin n) {i : ℕ} (hi : i + 1 < m) : (liftN N n v i).isSome := by diff --git a/Complexitylib/Classes/PCP/Internal/FamilyFin.lean b/Complexitylib/Classes/PCP/Internal/FamilyFin.lean index 80e64234..a42c396d 100644 --- a/Complexitylib/Classes/PCP/Internal/FamilyFin.lean +++ b/Complexitylib/Classes/PCP/Internal/FamilyFin.lean @@ -5,21 +5,21 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.PCP.Internal.TowerFin -public import Complexitylib.Classes.PCP.Internal.TowerFamily +public import Complexitylib.Classes.PCP.Internal.MergeGen /-! # An expander of every size, numbered `TowerFin` gives an expander at the tower's own sizes; a constraint graph asks for one on exactly its own vertex count, and Dinur's degree reduction asks for -one on every vertex degree. This module closes the gap the way `TowerFamily` -does — fold the first large enough member onto `n` vertices, then pad the degree -with self-loops — but keeps every naming explicit, so that the rotation map -stays a formula in numbers. - -The one place `TowerFamily` numbers its darts by an arbitrary bijection is here -replaced by packing a slot and a dart with `finProdFinEquiv` and the padding -with `finSumFinEquiv`. +one on every vertex degree. This module closes the gap — fold the first large +enough member onto `n` vertices, then pad the degree with self-loops — keeping +every naming explicit, so that the rotation map stays a formula in numbers. + +Nothing is numbered by an arbitrary bijection: a slot and a dart are packed with +`finProdFinEquiv`, and the padding with `finSumFinEquiv`. That is what lets +`famRotVal` compute the family's rotation map on raw numerals, which is what an +algorithm has to be handed. ## Main definitions diff --git a/Complexitylib/Classes/PCP/Internal/KilledCSP.lean b/Complexitylib/Classes/PCP/Internal/KilledCSP.lean index 05fb10a0..e33dd8bf 100644 --- a/Complexitylib/Classes/PCP/Internal/KilledCSP.lean +++ b/Complexitylib/Classes/PCP/Internal/KilledCSP.lean @@ -24,10 +24,11 @@ finite of size `∑_{ℓ ≤ T} deg ^ ℓ`, so the alphabet stays a constant `|α| ^ (∑_{ℓ ≤ T} deg ^ ℓ)`, independent of the number of vertices — which is what makes the alphabet-reduction step afterwards possible. -Variable-length indices are the point of the redesign. With the fixed-length -indices of `PowerCSP`, a short prefix had to be padded out with self-loops, and -the padded indices formed a vanishing sub-cube that the plurality bound could -not see; that module's docstring records why this sinks soundness there. +Variable-length indices are the point of the design. Were the indices instead +walks of one fixed length, a short prefix would have to be padded out with +self-loops, and the padded indices would form a vanishing sub-cube that the +plurality bound cannot see — which sinks soundness. `KilledWalk` records the +counting behind that failure. ## The constraint diff --git a/Complexitylib/Classes/PCP/Internal/KilledWalk.lean b/Complexitylib/Classes/PCP/Internal/KilledWalk.lean index 46e275dc..d23af7e8 100644 --- a/Complexitylib/Classes/PCP/Internal/KilledWalk.lean +++ b/Complexitylib/Classes/PCP/Internal/KilledWalk.lean @@ -24,7 +24,8 @@ Soundness decodes an assignment of the powered system by plurality and needs the opinions at the two ends of a checked step to be truthful. Summed over the checked steps that amounts to `∑ a_i · b_j` over the prefix length `i` and the suffix length `j`. With walks of *fixed* length those are tied by `i + j = t - 1` -and the sum can vanish, as `PowerCSP`'s module docstring explains. Killing makes +and the sum can vanish — the two ends can be truthful at complementary lengths +and never at the same step, so nothing is charged. Killing makes `i` and `j` **independent**, so the sum factorises into a product of two plurality bounds. That factorisation is the whole reason for this construction. diff --git a/Complexitylib/Classes/PCP/Internal/Margulis.lean b/Complexitylib/Classes/PCP/Internal/Margulis.lean index c22eb7a5..9e094482 100644 --- a/Complexitylib/Classes/PCP/Internal/Margulis.lean +++ b/Complexitylib/Classes/PCP/Internal/Margulis.lean @@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Bolton Bailey -/ module -public import Complexitylib.Classes.PCP.Internal.ExpanderAssemble +public import Complexitylib.Classes.PCP.Internal.RegularGraph public import Mathlib.Data.ZMod.Basic /-! diff --git a/Complexitylib/Classes/PCP/Internal/MergeGen.lean b/Complexitylib/Classes/PCP/Internal/MergeGen.lean index 8c3df743..759909b0 100644 --- a/Complexitylib/Classes/PCP/Internal/MergeGen.lean +++ b/Complexitylib/Classes/PCP/Internal/MergeGen.lean @@ -5,6 +5,7 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.PCP.Internal.ExpanderMerge +public import Mathlib.Data.Real.Sqrt /-! # Merging at an arbitrary width diff --git a/Complexitylib/Classes/PCP/Internal/PadCSP.lean b/Complexitylib/Classes/PCP/Internal/PadCSP.lean deleted file mode 100644 index cfcb8781..00000000 --- a/Complexitylib/Classes/PCP/Internal/PadCSP.lean +++ /dev/null @@ -1,163 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.PadVerts -public import Complexitylib.Classes.PCP.Internal.RegCSP - -/-! -# Padding a constraint system - -`PadVerts` enlarges a regular graph; here the constraints come along. The fresh -vertices carry self-loops, and those loops are given the trivial constraint, so -they are satisfied by every assignment and never contribute an unsatisfied dart. - -Nothing is lost except dilution: the unsatisfied darts are exactly the old ones, -while the total number of darts grows in proportion to the number of vertices. -The unsatisfiability value is therefore scaled by the ratio of the old vertex -count to the new — a constant factor, since padding is only ever to within a -constant multiple. - -## Main definitions - -- `Complexity.RegCSP.padVerts` — the padded constraint system - -## Main results - -- `Complexity.RegCSP.card_unsatDarts_padVerts` — the unsatisfied darts are the - old ones -- `Complexity.RegCSP.satisfiable_padVerts_iff` — satisfiability is unchanged -- `Complexity.RegCSP.unsatVal_padVerts_ge` — the value is diluted by exactly the - ratio of the vertex counts --/ - -@[expose] public section - -namespace Complexity - -namespace RegCSP - -variable {α : Type} - -/-- The padded constraint system: fresh vertices, whose self-loops carry the -constraint that is always satisfied. -/ -def padVerts (R : RegCSP α) (k : ℕ) : RegCSP α where - graph := R.graph.padVerts k - rel := fun v i x y => - match v with - | Sum.inl w => R.rel w i x y - | Sum.inr _ => true - -@[simp] theorem graph_padVerts (R : RegCSP α) (k : ℕ) : - (R.padVerts k).graph = R.graph.padVerts k := rfl - -/-- Restricting an assignment of the padded system to the original vertices. -/ -def unpad (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) : R.Assignment := - fun v => a (Sum.inl v) - -/-- Extending an assignment to the padded system. -/ -noncomputable def repad [Nonempty α] (R : RegCSP α) {k : ℕ} (a : R.Assignment) : - (R.padVerts k).Assignment := - fun v => - match v with - | Sum.inl w => a w - | Sum.inr _ => Classical.arbitrary α - -theorem unpad_repad [Nonempty α] (R : RegCSP α) {k : ℕ} (a : R.Assignment) : - R.unpad (R.repad (k := k) a) = a := rfl - -theorem satisfies_padVerts_inl (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) - (v : R.graph.V) (i : R.graph.D) : - (R.padVerts k).Satisfies a (Sum.inl v, i) ↔ R.Satisfies (R.unpad a) (v, i) := Iff.rfl - -theorem satisfies_padVerts_inr (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) - (j : Fin k) (i : R.graph.D) : (R.padVerts k).Satisfies a (Sum.inr j, i) := rfl - -/-- **The unsatisfied darts are exactly the old ones.** -/ -theorem unsatDarts_padVerts (R : RegCSP α) {k : ℕ} (a : (R.padVerts k).Assignment) : - (R.padVerts k).unsatDarts a - = (R.unsatDarts (R.unpad a)).image fun p => (Sum.inl p.1, p.2) := by - classical - ext p - constructor - · intro hp - rw [mem_unsatDarts] at hp - obtain ⟨v | j, i⟩ := p - · exact Finset.mem_image.2 ⟨(v, i), (mem_unsatDarts R).2 hp, rfl⟩ - · exact absurd (R.satisfies_padVerts_inr a j i) hp - · intro hp - obtain ⟨⟨w, i'⟩, hw, heq⟩ := Finset.mem_image.1 hp - rw [← heq, mem_unsatDarts] - rw [mem_unsatDarts] at hw - exact hw - -theorem card_unsatDarts_padVerts (R : RegCSP α) {k : ℕ} - (a : (R.padVerts k).Assignment) : - ((R.padVerts k).unsatDarts a).card = (R.unsatDarts (R.unpad a)).card := by - classical - have hinj : Function.Injective - (fun p : R.Dart => ((Sum.inl p.1, p.2) : (R.padVerts k).Dart)) := by - intro p q h - simp only [Prod.mk.injEq] at h - exact Prod.ext (by injection h.1) h.2 - rw [unsatDarts_padVerts] - exact Finset.card_image_of_injective _ hinj - -/-- **Satisfiability is unchanged.** -/ -theorem satisfiable_padVerts_iff [Nonempty α] (R : RegCSP α) (k : ℕ) : - (R.padVerts k).Satisfiable ↔ R.Satisfiable := by - constructor - · rintro ⟨a, ha⟩ - refine ⟨R.unpad a, fun p => ?_⟩ - obtain ⟨v, i⟩ := p - exact (R.satisfies_padVerts_inl a v i).1 (ha (Sum.inl v, i)) - · rintro ⟨b, hb⟩ - refine ⟨R.repad b, fun p => ?_⟩ - obtain ⟨v | j, i⟩ := p - · rw [satisfies_padVerts_inl, unpad_repad] - exact hb (v, i) - · exact R.satisfies_padVerts_inr _ j i - -/-! ### The dilution -/ - -theorem unsatFrac_padVerts (R : RegCSP α) (k : ℕ) (a : (R.padVerts k).Assignment) : - (R.padVerts k).unsatFrac a - = ((R.unsatDarts (R.unpad a)).card : ℚ) - / (((R.graph.order + k) * R.graph.deg : ℕ) : ℚ) := by - rw [unsatFrac, card_unsatDarts_padVerts] - congr 2 - rw [graph_padVerts, RegGraph.order_padVerts, RegGraph.deg_padVerts] - -/-- **Padding dilutes the value by the ratio of the vertex counts.** -/ -theorem unsatVal_padVerts_ge [Fintype α] [Nonempty α] [DecidableEq α] - (R : RegCSP α) (k : ℕ) (hord : 0 < R.graph.order) : - R.unsatVal * ((R.graph.order : ℕ) : ℚ) / (((R.graph.order + k : ℕ)) : ℚ) - ≤ (R.padVerts k).unsatVal := by - classical - have hd : (0 : ℚ) < (R.graph.deg : ℕ) := by - have := R.graph.deg_pos - exact_mod_cast this - have ho : (0 : ℚ) < (R.graph.order : ℕ) := by exact_mod_cast hord - have hok : (0 : ℚ) < ((R.graph.order + k : ℕ) : ℚ) := by - have : 0 < R.graph.order + k := by omega - exact_mod_cast this - have hod : (0 : ℚ) < ((R.graph.order * R.graph.deg : ℕ) : ℚ) := by - have : 0 < R.graph.order * R.graph.deg := Nat.mul_pos hord R.graph.deg_pos - exact_mod_cast this - have hokd : (0 : ℚ) < (((R.graph.order + k) * R.graph.deg : ℕ) : ℚ) := by - have : 0 < (R.graph.order + k) * R.graph.deg := - Nat.mul_pos (by omega) R.graph.deg_pos - exact_mod_cast this - refine Finset.le_inf' _ _ fun a _ => ?_ - have hle : R.unsatVal ≤ R.unsatFrac (R.unpad a) := R.unsatVal_le _ - rw [unsatFrac] at hle - rw [le_div_iff₀ hod] at hle - rw [unsatFrac_padVerts, div_le_div_iff₀ hok hokd] - push_cast at hle ⊢ - nlinarith [hle, hd, ho, hok] - -end RegCSP - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PadVerts.lean b/Complexitylib/Classes/PCP/Internal/PadVerts.lean deleted file mode 100644 index 85860881..00000000 --- a/Complexitylib/Classes/PCP/Internal/PadVerts.lean +++ /dev/null @@ -1,90 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.RegularGraph - -/-! -# Padding a regular graph with fresh vertices - -`SizedExpander` supplies an expander of approximately, not exactly, a requested -size, so the graph it is to be superposed on must first be brought up to the -expander's size. A regular graph cannot simply gain isolated vertices — that -would break regularity — so the fresh vertices carry self-loops instead, one per -label. - -The padded graph is disconnected and so has no spectral gap of its own; that is -of no concern, because expanderization takes the gap from the expander it -superposes, not from the graph underneath. - -## Main definitions - -- `Complexity.RegGraph.padVerts` — the graph on a prescribed larger vertex set - -## Main results - -- `Complexity.RegGraph.order_padVerts`, `Complexity.RegGraph.deg_padVerts` --/ - -@[expose] public section - -namespace Complexity - -namespace RegGraph - -variable (G : RegGraph) - -/-- The rotation map of the padded graph: the old darts as before, and a -self-loop at each fresh vertex. -/ -def padRot (k : ℕ) : (G.V ⊕ Fin k) × G.D → (G.V ⊕ Fin k) × G.D - | (Sum.inl v, i) => (Sum.inl (G.rot (v, i)).1, (G.rot (v, i)).2) - | (Sum.inr j, i) => (Sum.inr j, i) - -theorem padRot_involutive (k : ℕ) : Function.Involutive (G.padRot k) := by - intro p - obtain ⟨v | j, i⟩ := p - · show G.padRot k (Sum.inl (G.rot (v, i)).1, (G.rot (v, i)).2) = _ - rw [padRot] - have h := G.rot_involutive (v, i) - simp only [Prod.mk.injEq] - constructor - · exact congrArg (fun p => Sum.inl p.1) h - · exact congrArg (fun p => p.2) h - · rfl - -/-- **The graph with `k` fresh looped vertices added.** -/ -def padVerts (k : ℕ) : RegGraph where - V := G.V ⊕ Fin k - D := G.D - decEqV := by - haveI := G.decEqV - exact inferInstance - decEqD := G.decEqD - fintypeV := by - haveI := G.fintypeV - exact inferInstance - fintypeD := G.fintypeD - nonemptyD := G.nonemptyD - rot := G.padRot k - rot_involutive := G.padRot_involutive k - -@[simp] theorem deg_padVerts (k : ℕ) : (G.padVerts k).deg = G.deg := rfl - -@[simp] theorem order_padVerts (k : ℕ) : (G.padVerts k).order = G.order + k := by - show Fintype.card (G.V ⊕ Fin k) = Fintype.card G.V + k - rw [Fintype.card_sum, Fintype.card_fin] - -/-- Padding to a prescribed size. -/ -def padTo (N : ℕ) : RegGraph := G.padVerts (N - G.order) - -@[simp] theorem deg_padTo (N : ℕ) : (G.padTo N).deg = G.deg := rfl - -theorem order_padTo {N : ℕ} (h : G.order ≤ N) : (G.padTo N).order = N := by - rw [padTo, order_padVerts] - omega - -end RegGraph - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/Plurality.lean b/Complexitylib/Classes/PCP/Internal/Plurality.lean deleted file mode 100644 index b3b2efa9..00000000 --- a/Complexitylib/Classes/PCP/Internal/Plurality.lean +++ /dev/null @@ -1,129 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.PowerCSP -public import Mathlib.Data.Finset.Max - -/-! -# The plurality assignment - -Soundness of Dinur's powering step is proved by *decoding*: an arbitrary -assignment of the powered system, whose labels are opinions that need not be -consistent with each other, is turned into a single assignment of the original -system, and the walks whose constraints fail are counted against it. - -The decoding is by plurality. The endpoint `u` of a length-`h` walk `w` out of -`v` holds an opinion about `v` — read off at the index `revWalk v w`, the -reversal of `w`, which is the walk from `u` back to `v`. Letting `w` range over -all `deg ^ h` walks out of `v` gives a multiset of opinions about `v`, and -`plurality` picks a most frequent one. - -Two consequences are recorded: the plurality value is at least as popular as any -other value, and it is held by at least a `1 / |α|` fraction of the walks. The -second is the pigeonhole that keeps the decoded assignment from being vacuous. - -## Main definitions - -- `RegCSP.opinionAbout` — what the far end of a walk says about its start -- `RegCSP.opinionCount` — how many walks out of `v` ascribe a given value to it -- `RegCSP.plurality` — the decoded assignment - -## Main results - -- `RegCSP.opinionAbout_walkEnd_revWalk`, `RegCSP.opinionAbout_padWalk` — the - opinions the powered constraint reads are entries of the plurality's multiset -- `RegCSP.opinionCount_le_plurality` — no value beats the plurality -- `RegCSP.card_le_card_mul_opinionCount_plurality` — the plurality is held by at - least a `1 / |α|` fraction of walks --/ - -@[expose] public section - -namespace Complexity - -namespace RegCSP - -variable {α : Type} (R : RegCSP α) (L : R.graph.Loops) (t h : ℕ) - -/-- The value that the far end of the length-`h` walk `w` out of `v` ascribes to -`v`, read at the index `revWalk v w` — the walk back from that end to `v`. -/ -def opinionAbout (A : (R.power L t h).Assignment) (v : R.graph.V) - (w : Fin h → R.graph.D) : α := - A (R.graph.walkEnd h v w) (R.graph.revWalk v w) - -/-- **Reversal duality.** The value `v` reads at the walk `w` *is* the opinion -that `w`'s far end holds about `v`. Both reversal lemmas of `Power` are used: -reversing `w` lands back at `v`, and reversing it twice returns `w`. -/ -theorem opinionAbout_walkEnd_revWalk (A : (R.power L t h).Assignment) (v : R.graph.V) - (w : Fin h → R.graph.D) : - R.opinionAbout L t h A (R.graph.walkEnd h v w) (R.graph.revWalk v w) = A v w := by - rw [opinionAbout, R.graph.walkEnd_revWalk v w, R.graph.revWalk_revWalk v w] - -/-- **The bridge to decoding.** The opinion that the *start* of a walk holds -about its `k`-th vertex — exactly what the powered constraint reads — is one of -the opinions about that vertex whose mode is `plurality`. So bounding how often -the powered constraint reads an untruthful opinion is a statement about the -plurality's own multiset. -/ -theorem opinionAbout_padWalk (A : (R.power L t h).Assignment) (v : R.graph.V) - (s : Fin t → R.graph.D) {k : ℕ} (hkh : k ≤ h) (hkt : k ≤ t) : - R.opinionAbout L t h A (R.graph.walkAt t v s k) - (R.graph.revWalk v (L.padWalk v s k h)) - = A v (L.padWalk v s k h) := by - rw [← L.walkEnd_padWalk v s hkh hkt, R.opinionAbout_walkEnd_revWalk] - -section Decode - -variable [DecidableEq α] [Fintype α] [Nonempty α] - -/-- The number of length-`h` walks out of `v` whose far end ascribes the value -`a` to `v`. -/ -def opinionCount (A : (R.power L t h).Assignment) (v : R.graph.V) (a : α) : ℕ := - (Finset.univ.filter fun w : Fin h → R.graph.D => R.opinionAbout L t h A v w = a).card - -/-- The plurality decoding: each vertex is given a value that the ends of the -walks out of it ascribe to it most often. -/ -noncomputable def plurality (A : (R.power L t h).Assignment) (v : R.graph.V) : α := - (Finset.exists_max_image (Finset.univ : Finset α) (R.opinionCount L t h A v) - ⟨Classical.arbitrary α, Finset.mem_univ _⟩).choose - -/-- No value is ascribed to `v` more often than its plurality value. -/ -theorem opinionCount_le_plurality (A : (R.power L t h).Assignment) (v : R.graph.V) (a : α) : - R.opinionCount L t h A v a ≤ R.opinionCount L t h A v (R.plurality L t h A v) := - (Finset.exists_max_image (Finset.univ : Finset α) (R.opinionCount L t h A v) - ⟨Classical.arbitrary α, Finset.mem_univ _⟩).choose_spec.2 a (Finset.mem_univ a) - -omit [Nonempty α] in -/-- The counts over all values partition the walks. -/ -theorem sum_opinionCount (A : (R.power L t h).Assignment) (v : R.graph.V) : - ∑ a : α, R.opinionCount L t h A v a = R.graph.deg ^ h := by - classical - have hcard : Fintype.card (Fin h → R.graph.D) = R.graph.deg ^ h := R.graph.card_walks h - calc ∑ a : α, R.opinionCount L t h A v a - = ∑ a : α, (Finset.univ.filter fun w : Fin h → R.graph.D => - R.opinionAbout L t h A v w = a).card := rfl - _ = (Finset.univ : Finset (Fin h → R.graph.D)).card := by - rw [← Finset.card_eq_sum_card_fiberwise] - intro w _ - exact Finset.mem_univ _ - _ = R.graph.deg ^ h := by rw [Finset.card_univ, hcard] - -/-- **Pigeonhole.** The plurality value is ascribed to `v` by at least a -`1 / |α|` fraction of the walks out of `v`. -/ -theorem card_le_card_mul_opinionCount_plurality (A : (R.power L t h).Assignment) - (v : R.graph.V) : - R.graph.deg ^ h - ≤ Fintype.card α * R.opinionCount L t h A v (R.plurality L t h A v) := by - calc R.graph.deg ^ h = ∑ a : α, R.opinionCount L t h A v a := (R.sum_opinionCount L t h A v).symm - _ ≤ ∑ _a : α, R.opinionCount L t h A v (R.plurality L t h A v) := - Finset.sum_le_sum fun a _ => R.opinionCount_le_plurality L t h A v a - _ = Fintype.card α * R.opinionCount L t h A v (R.plurality L t h A v) := by - rw [Finset.sum_const, Finset.card_univ, smul_eq_mul] - -end Decode - -end RegCSP - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/PowerCSP.lean b/Complexitylib/Classes/PCP/Internal/PowerCSP.lean deleted file mode 100644 index 74fb11da..00000000 --- a/Complexitylib/Classes/PCP/Internal/PowerCSP.lean +++ /dev/null @@ -1,244 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.Power -public import Complexitylib.Classes.PCP.Internal.RegCSP -public import Complexitylib.Classes.PCP.Internal.WalkDart - -/-! -# Powering a constraint system - -Dinur's gap amplification step. The `t`-th power of a constraint system `R` has -the same vertices; its constraints are indexed by the **walks of length `t`** in -`R`'s graph, and its alphabet consists of *opinions*. - -## Opinions - -A label of the powered system at `v` is a function -`(Fin h → G.D) → α`: for every length-`h` walk out of `v`, a claim about the -label of that walk's endpoint. Since `G` has self-loops, `Loops.padWalk` names -every vertex within distance `h` of `v` by such a walk, so a label is exactly an -opinion about the ball of radius `h` around `v` — while remaining a *constant* -sized alphabet, `|α| ^ (deg ^ h)`, independent of the number of vertices. That -is what makes the alphabet-reduction step afterwards possible. - -## The powered constraint - -The constraint on the walk `(v, s)` compares the opinions held at its two ends. -For each step `k` of the walk that lies in the **middle window** — close enough -to the start (`k ≤ h`) that the start has an opinion about `v k`, and close -enough to the end (`t - (k+1) ≤ h`) that the end has an opinion about `v (k+1)` -— it demands that those two opinions satisfy `R`'s own constraint on the `k`-th -dart. The end's opinion is addressed through the *reversed* walk, which is why -`Power`'s reversal machinery is needed here. - -Steps outside the middle window are not checked: neither endpoint is required to -have an opinion about them. - -## What is proved here - -Perfect completeness: a satisfying assignment `σ` of `R` induces the *truthful* -opinion assignment `v ↦ (w ↦ σ (walkEnd h v w))`, which satisfies every walk -constraint, because on the middle window the two opinions are literally `σ`'s -values at the two ends of a dart of `R`. - -The converse — that the value *doubles*, the analytic heart of Dinur's proof — -is the soundness direction and is not proved here. - -## ⚠️ Soundness needs a different walk law - -Soundness decodes `A` by plurality (`Plurality`) and needs, for each checked -step `k`, that the two opinions the constraint reads are truthful with -probability at least `1 / |α|` each. That fails for the construction above, and -not for want of effort: - -* the plurality at `x` is taken over **all** `deg ^ h` walk indices out of `x`, - whereas the index the constraint reads at step `k` is - `revWalk (padWalk … k h)`, whose last `h - k` labels are the *fixed* loop - label. Those indices form a sub-cube of relative size `deg ^ (k - h)`, so a - popular-overall opinion may be wrong on every index the constraint ever - reads. - -Defining the plurality over the mixture of padded distributions instead fixes -each step in isolation but not the first moment, which needs -`∑_{k ∈ W} a_k · b_{t-1-k} > 0` for the prefix- and suffix-truthfulness -profiles `a, b`. Fixed-length walks force `i + j = t - 1` on the prefix and -suffix lengths, so `a` and `b` can be supported on mirror-disjoint halves of the -window and the sum vanishes; an adversarial `A` whose opinions depend only on -the walk length realises this. - -The construction that works is Dinur's: stop the walk with probability `1/q` at -each step. Memorylessness makes the prefix and suffix lengths **independent**, -so the double sum factorises into a product of two mixture bounds and each -factor is at least `1 / |α|`. Concretely: label darts by -`Fin T → G.D × Fin q`, let the effective length be the first index whose second -component is `0`, reverse only that prefix (keeping the tail, which preserves -involutivity), and index opinions by *variable-length* walks so that no padding -is needed. Every step of the effective walk is then checkable, and no window is -required. - -What the present construction does support is the single matching position: -with `t = 2 * h + 1` and `k = h`, the prefix and suffix are unpadded walks of -length exactly `h`, so both distributions are uniform and independent, giving -soundness with no amplification. That is a fine sanity check, but it is not -enough for the PCP theorem, which needs the gain to grow with `t`. - -## Main definitions - -- `Opinion` — the alphabet of the powered system -- `RegCSP.power` — the powered constraint system -- `RegCSP.truthful` — the opinion assignment induced by an assignment of `R` - -## Main results - -- `RegCSP.graph_power`, `RegCSP.rel_power_iff` -- `RegCSP.satisfies_power_truthful` — the truthful assignment satisfies every - walk constraint -- `RegCSP.satisfiable_power_of_satisfiable` — perfect completeness -- `RegCSP.not_satisfies_power_of_faulty` — a faulty dart in the middle window - with truthful opinions at both ends breaks the walk's constraint -- `RegCSP.card_dart_power`, `RegCSP.unsatFrac_power` — the powered value is a - fraction of walks -- `RegCSP.card_walks_faulty` — the first moment: `deg ^ (t-1)` walks per faulty - dart per step index --/ - -@[expose] public section - -namespace Complexity - -/-- A label of the powered system: for each length-`h` walk out of the vertex, a -claim about the label of that walk's endpoint. -/ -abbrev Opinion (G : RegGraph) (h : ℕ) (α : Type) : Type := (Fin h → G.D) → α - -namespace RegCSP - -variable {α : Type} (R : RegCSP α) (L : R.graph.Loops) (t h : ℕ) - -/-- The `t`-th power of `R`, with opinions of radius `h` as its alphabet: one -constraint per length-`t` walk, checking `R`'s constraints on the steps of the -walk that both endpoints have an opinion about. -/ -def power (R : RegCSP α) (L : R.graph.Loops) (t h : ℕ) : - RegCSP (Opinion R.graph h α) where - graph := R.graph.power t - rel v s a b := decide (∀ k : Fin t, k.val ≤ h → t - (k.val + 1) ≤ h → - R.rel (R.graph.walkAt t v s k.val) (s k) - (a (L.padWalk v s k.val h)) - (b (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) - (t - (k.val + 1)) h)) = true) - -@[simp] theorem graph_power : (R.power L t h).graph = R.graph.power t := rfl - -theorem rel_power_iff (v : R.graph.V) (s : Fin t → R.graph.D) - (a b : Opinion R.graph h α) : - (R.power L t h).rel v s a b = true ↔ - ∀ k : Fin t, k.val ≤ h → t - (k.val + 1) ≤ h → - R.rel (R.graph.walkAt t v s k.val) (s k) - (a (L.padWalk v s k.val h)) - (b (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) - (t - (k.val + 1)) h)) = true := by - simp [power] - -/-- The truthful opinion assignment induced by an assignment of `R`: every -vertex reports the true labels of the endpoints of the walks out of it. -/ -def truthful (σ : R.Assignment) : (R.power L t h).Assignment := - fun v w => σ (R.graph.walkEnd h v w) - -/-- On the middle window the truthful opinions are exactly `σ`'s values at the -two ends of the corresponding dart of `R`, so a satisfying `σ` satisfies every -walk constraint. -/ -theorem satisfies_power_truthful {σ : R.Assignment} (hσ : ∀ p, R.Satisfies σ p) - (p : (R.power L t h).Dart) : (R.power L t h).Satisfies (R.truthful L t h σ) p := by - obtain ⟨v, s⟩ := p - have hnbr : (R.power L t h).graph.nbr v s = R.graph.walkEnd t v s := R.graph.nbr_power t v s - rw [Satisfies, satisfies] - dsimp only - rw [hnbr, rel_power_iff] - intro k hk1 hk2 - have hkt : k.val < t := k.isLt - -- the start's opinion about the `k`-th vertex - have hstart : R.truthful L t h σ v (L.padWalk v s k.val h) - = σ (R.graph.walkAt t v s k.val) := by - rw [truthful, L.walkEnd_padWalk v s hk1 (le_of_lt hkt)] - -- the end's opinion about the `(k+1)`-st vertex, addressed along the reversal - have harith : t - (t - (k.val + 1)) = k.val + 1 := by omega - have hend : R.truthful L t h σ (R.graph.walkEnd t v s) - (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) (t - (k.val + 1)) h) - = σ (R.graph.walkAt t v s (k.val + 1)) := by - rw [truthful, L.walkEnd_padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) hk2 (by omega), - R.graph.walkAt_revWalk v s (t - (k.val + 1)) (by omega), harith] - rw [hstart, hend] - have hdart := hσ (R.graph.walkAt t v s k.val, s k) - rw [Satisfies, satisfies] at hdart - rwa [R.graph.walkAt_succ_of_lt v s hkt] - -/-- **Perfect completeness of powering.** -/ -theorem satisfiable_power_of_satisfiable (hR : R.Satisfiable) : - (R.power L t h).Satisfiable := by - obtain ⟨σ, hσ⟩ := hR - exact ⟨R.truthful L t h σ, fun p => R.satisfies_power_truthful L t h hσ p⟩ - -/-- **The soundness-side counterpart.** If some step of the walk lies in the -middle window, carries a dart that `σ` fails, and both endpoints happen to -report `σ`'s values for that dart's two vertices, then the walk's constraint -fails. - -This is the bridge from counting *faulty darts along walks* to the value of the -powered system: it is what makes a walk that meets a faulty dart an unsatisfied -constraint, provided the two opinions involved are truthful. Bounding how often -they are not is the remaining analytic work. -/ -theorem not_satisfies_power_of_faulty {σ : R.Assignment} - (A : (R.power L t h).Assignment) (v : R.graph.V) (s : Fin t → R.graph.D) - (k : Fin t) (hk1 : k.val ≤ h) (hk2 : t - (k.val + 1) ≤ h) - (hfault : ¬ R.Satisfies σ (R.graph.walkAt t v s k.val, s k)) - (htruth₁ : A v (L.padWalk v s k.val h) = σ (R.graph.walkAt t v s k.val)) - (htruth₂ : A (R.graph.walkEnd t v s) - (L.padWalk (R.graph.walkEnd t v s) (R.graph.revWalk v s) (t - (k.val + 1)) h) - = σ (R.graph.walkAt t v s (k.val + 1))) : - ¬ (R.power L t h).Satisfies A (v, s) := by - intro hsat - have hnbr : (R.power L t h).graph.nbr v s = R.graph.walkEnd t v s := R.graph.nbr_power t v s - rw [Satisfies, satisfies] at hsat - dsimp only at hsat - rw [hnbr, rel_power_iff] at hsat - have hk := hsat k hk1 hk2 - rw [htruth₁, htruth₂] at hk - rw [Satisfies, satisfies] at hfault - dsimp only at hfault - rw [← R.graph.walkAt_succ_of_lt v s k.isLt] at hfault - exact hfault hk - -/-! ### Counting -/ - -/-- The powered system has one constraint per walk. -/ -theorem card_dart_power : - Fintype.card (R.power L t h).Dart = R.graph.order * R.graph.deg ^ t := by - rw [card_dart] - simp - -/-- The value of an assignment of the powered system is the fraction of *walks* -whose constraint it fails. -/ -theorem unsatFrac_power (A : (R.power L t h).Assignment) : - (R.power L t h).unsatFrac A - = (((R.power L t h).unsatDarts A).card : ℚ) - / ((R.graph.order * R.graph.deg ^ t : ℕ) : ℚ) := by - rw [unsatFrac] - congr 2 - simp - -/-- **The first moment.** For each step index `k`, the walks whose `k`-th dart -is one that `σ` fails number exactly `deg ^ (t-1)` times the faulty darts — one -`deg ^ (t-1)`-sized fibre per faulty dart, by `sum_stepDart`. This is what makes -the expected number of faulty steps along a walk proportional to `unsatFrac σ`. -/ -theorem card_walks_faulty (σ : R.Assignment) {k : ℕ} (hk : k < t) : - (∑ v : R.graph.V, (Finset.univ.filter fun s : Fin t → R.graph.D => - (R.graph.walkAt t v s k, s ⟨k, hk⟩) ∈ R.unsatDarts σ).card) - = R.graph.deg ^ (t - 1) * (R.unsatDarts σ).card := - R.graph.card_walks_stepDart_mem hk (R.unsatDarts σ) - -end RegCSP - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SizedExpander.lean b/Complexitylib/Classes/PCP/Internal/SizedExpander.lean deleted file mode 100644 index dca0d333..00000000 --- a/Complexitylib/Classes/PCP/Internal/SizedExpander.lean +++ /dev/null @@ -1,137 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.ZigZagTower - -/-! -# Expanders of approximately a given size - -The zig-zag tower produces expanders only at the sizes `(deg ^ 4) ^ (k + 1)`, -which are far apart. `Pad` shows that this is no obstacle: a constraint graph -may be enlarged with isolated vertices, at no cost to anything the amplification -measures, so it is enough to have an expander on *some* size between `n` and a -constant multiple of `n`. - -This module records that weaker interface and builds one from a `ZigZagBase`, -by taking the first member of the tower large enough. Minimality of the choice -is what bounds the overshoot: the previous member was too small, and each round -multiplies the size by exactly `deg ^ 4`. - -## Main definitions - -- `Complexity.SizedExpanderFamily` — expanders of approximately prescribed size -- `Complexity.ZigZagBase.toSized` — the family the tower gives - -## Main results - -- `Complexity.ZigZagBase.order_toSized_le` — the overshoot is a constant factor --/ - -@[expose] public section - -namespace Complexity - -/-- A family of constant-degree expanders, one of approximately each size: the -graph for `n` has between `n` and `factor * n` vertices. -/ -structure SizedExpanderFamily where - /-- The common degree. -/ - degree : ℕ - /-- The degree is positive. -/ - degree_pos : 0 < degree - /-- How far the size may overshoot. -/ - factor : ℕ - /-- The graph provided for a requested size. -/ - graph : ℕ → RegGraph - /-- Every member has the common degree. -/ - deg_graph : ∀ n, (graph n).deg = degree - /-- It is at least as large as requested. -/ - order_ge : ∀ n, n ≤ (graph n).order - /-- And not too much larger. -/ - order_le : ∀ n, 1 ≤ n → (graph n).order ≤ factor * n - /-- The uniform contraction factor. -/ - lam : ℝ - /-- It is nonnegative. -/ - lam_nonneg : 0 ≤ lam - /-- And below one. -/ - lam_lt_one : lam < 1 - /-- Every member contracts mean-zero functions by `lam`. -/ - spectral : ∀ n, (graph n).SpectralBound lam - -namespace ZigZagBase - -variable (B : ZigZagBase) (hd : 1 < B.base.deg) - -/-- The first index whose member is large enough. -/ -noncomputable def towerIndex (n : ℕ) : ℕ := - Nat.find (B.exists_order_ge hd n) - -theorem le_order_towerIndex (n : ℕ) : - n ≤ (tower B (B.towerIndex hd n)).graph.order := - Nat.find_spec (B.exists_order_ge hd n) - -theorem order_towerIndex_le (n : ℕ) (hn : 1 ≤ n) : - (tower B (B.towerIndex hd n)).graph.order ≤ B.base.deg ^ 4 * n := by - classical - rcases Nat.eq_zero_or_pos (B.towerIndex hd n) with h0 | hpos - · rw [towerIndex] at h0 ⊢ - rw [h0, order_tower] - calc (B.base.deg ^ 4) ^ (0 + 1) = B.base.deg ^ 4 := by ring - _ ≤ B.base.deg ^ 4 * n := Nat.le_mul_of_pos_right _ hn - · obtain ⟨m, hm⟩ : ∃ m, B.towerIndex hd n = m + 1 := ⟨B.towerIndex hd n - 1, by omega⟩ - have hfind : Nat.find (B.exists_order_ge hd n) = m + 1 := hm - have hlt : ¬ n ≤ (tower B m).graph.order := - Nat.find_min (B.exists_order_ge hd n) (m := m) (by rw [hfind]; omega) - have hmlt : (tower B m).graph.order < n := by omega - rw [hm, order_tower] - have hprev : (B.base.deg ^ 4) ^ (m + 1) < n := by - rw [← order_tower] - exact hmlt - calc (B.base.deg ^ 4) ^ (m + 1 + 1) = B.base.deg ^ 4 * (B.base.deg ^ 4) ^ (m + 1) := by - ring - _ ≤ B.base.deg ^ 4 * n := Nat.mul_le_mul_left _ (le_of_lt hprev) - -/-- **The tower, as a size-flexible family.** -/ -noncomputable def toSized : SizedExpanderFamily where - degree := B.base.deg ^ 2 - degree_pos := by - have := B.base.deg_pos - positivity - factor := B.base.deg ^ 4 - graph := fun n => (tower B (B.towerIndex hd n)).graph - deg_graph := fun n => deg_tower B _ - order_ge := B.le_order_towerIndex hd - order_le := B.order_towerIndex_le hd - lam := 2 / 5 - lam_nonneg := by norm_num - lam_lt_one := by norm_num - spectral := fun n => spectral_tower B _ - -/-! ### The member used for a requested size -/ - -/-- The tower member chosen for size `n`: the first one at least twice as big, -which is the overshoot the merge needs. -/ -noncomputable def fitIndex (n : ℕ) : ℕ := B.towerIndex hd (2 * n) - -theorem two_mul_le_order_fit (n : ℕ) : - 2 * n ≤ (tower B (B.fitIndex hd n)).graph.order := - B.le_order_towerIndex hd (2 * n) - -theorem order_fit_le (n : ℕ) (hn : 1 ≤ n) : - (tower B (B.fitIndex hd n)).graph.order ≤ (2 * B.base.deg ^ 4) * n := by - have h := B.order_towerIndex_le hd (2 * n) (by omega) - calc (tower B (B.fitIndex hd n)).graph.order ≤ B.base.deg ^ 4 * (2 * n) := h - _ = (2 * B.base.deg ^ 4) * n := by ring - -theorem deg_fit (n : ℕ) : (tower B (B.fitIndex hd n)).graph.deg = B.base.deg ^ 2 := - deg_tower B _ - -theorem spectral_fit (n : ℕ) : - (tower B (B.fitIndex hd n)).graph.SpectralBound (2 / 5) := - spectral_tower B _ - -end ZigZagBase - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean b/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean deleted file mode 100644 index a7c7a928..00000000 --- a/Complexitylib/Classes/PCP/Internal/SizedExpanderize.lean +++ /dev/null @@ -1,117 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.SizedExpander -public import Complexitylib.Classes.PCP.Internal.PadCSP -public import Complexitylib.Classes.PCP.Internal.ExpanderizeCSP - -/-! -# Expanderizing with an approximately sized family - -`ExpanderizeCSP` superposes an expander on a constraint system, which asks for -one on exactly the system's vertex count. The zig-zag tower offers only -approximate sizes, so the system is first enlarged to meet the expander: -`PadCSP` shows the enlargement costs only the ratio of the two vertex counts, -and that ratio is bounded by the family's `factor`. - -## Main definitions - -- `Complexity.RegCSP.sizedExpanderize` — pad, then superpose - -## Main results - -- `Complexity.RegCSP.spectralBound_sizedExpanderize` — it has a spectral gap -- `Complexity.RegCSP.satisfiable_sizedExpanderize_iff` — completeness -- `Complexity.RegCSP.unsatVal_sizedExpanderize_ge` — soundness, with the two - constant losses made explicit --/ - -@[expose] public section - -namespace Complexity - -namespace RegCSP - -variable {α : Type} (R : RegCSP α) (F : SizedExpanderFamily) - -/-- The size the family offers for this system. -/ -def fitSize : ℕ := (F.graph R.graph.order).order - -theorem le_fitSize : R.graph.order ≤ R.fitSize F := F.order_ge _ - -/-- The system, enlarged to the size the family offers. -/ -def padded : RegCSP α := R.padVerts (R.fitSize F - R.graph.order) - -theorem order_padded : (R.padded F).graph.order = R.fitSize F := by - rw [padded, graph_padVerts, RegGraph.order_padVerts] - have := R.le_fitSize F - omega - -@[simp] theorem deg_padded : (R.padded F).graph.deg = R.graph.deg := rfl - -/-- The family member's vertices name the enlarged system's. -/ -noncomputable def fitEquiv : (F.graph R.graph.order).V ≃ (R.padded F).graph.V := - Fintype.equivOfCardEq (by - show (F.graph R.graph.order).order = (R.padded F).graph.order - rw [order_padded] - rfl) - -/-- **Expanderization against an approximately sized family.** -/ -noncomputable def sizedExpanderize : RegCSP α := - (R.padded F).addTrivial (F.graph R.graph.order) (R.fitEquiv F) - -@[simp] theorem deg_sizedExpanderize : - (R.sizedExpanderize F).graph.deg = R.graph.deg + F.degree := by - rw [sizedExpanderize, graph_addTrivial, RegGraph.deg_union, deg_padded, F.deg_graph] - -/-- **The expanderized system has a spectral gap.** -/ -theorem spectralBound_sizedExpanderize : - (R.sizedExpanderize F).graph.SpectralBound - (((R.graph.deg : ℝ) + (F.degree : ℝ) * F.lam) - / ((R.graph.deg : ℝ) + (F.degree : ℝ))) := by - have h := RegGraph.spectralBound_union (R.padded F).graph (F.graph R.graph.order) - (R.fitEquiv F) F.lam_nonneg (F.spectral R.graph.order) - rw [F.deg_graph] at h - exact h - -/-- The bound is below one, which is what powering needs. -/ -theorem sizedExpanderize_bound_lt_one : - ((R.graph.deg : ℝ) + (F.degree : ℝ) * F.lam) - / ((R.graph.deg : ℝ) + (F.degree : ℝ)) < 1 := by - have hdF : (0 : ℝ) < (F.degree : ℝ) := by exact_mod_cast F.degree_pos - rw [div_lt_one (by positivity)] - nlinarith [F.lam_lt_one, F.lam_nonneg] - -/-- **Completeness**: enlarging and superposing preserves satisfiability. -/ -theorem satisfiable_sizedExpanderize_iff [Nonempty α] : - (R.sizedExpanderize F).Satisfiable ↔ R.Satisfiable := by - rw [sizedExpanderize, satisfiable_addTrivial_iff, padded, satisfiable_padVerts_iff] - -/-- **Soundness**: the value survives, down to the two constant factors — the -dilution from enlarging, and the dilution from the superposed degree. -/ -theorem unsatVal_sizedExpanderize_ge [Fintype α] [Nonempty α] [DecidableEq α] - (hord : 0 < R.graph.order) : - R.unsatVal * ((R.graph.order : ℕ) : ℚ) / ((R.fitSize F : ℕ) : ℚ) - * (R.graph.deg : ℚ) / ((R.graph.deg : ℚ) + (F.degree : ℚ)) - ≤ (R.sizedExpanderize F).unsatVal := by - have hk : R.graph.order + (R.fitSize F - R.graph.order) = R.fitSize F := by - have := R.le_fitSize F - omega - have hge := R.unsatVal_padVerts_ge (R.fitSize F - R.graph.order) hord - rw [hk] at hge - have hde : (0 : ℚ) < (R.graph.deg : ℚ) + (F.degree : ℚ) := by - have h1 : (0 : ℚ) < (R.graph.deg : ℚ) := by - have := R.graph.deg_pos - exact_mod_cast this - linarith - have hd : (0 : ℚ) ≤ (R.graph.deg : ℚ) := by positivity - rw [sizedExpanderize, unsatVal_addTrivial, deg_padded, F.deg_graph] - rw [div_le_div_iff_of_pos_right hde] - exact mul_le_mul_of_nonneg_right hge hd - -end RegCSP - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/SubsetNP.lean b/Complexitylib/Classes/PCP/Internal/SubsetNP.lean index a4704a83..a42718b2 100644 --- a/Complexitylib/Classes/PCP/Internal/SubsetNP.lean +++ b/Complexitylib/Classes/PCP/Internal/SubsetNP.lean @@ -59,16 +59,6 @@ theorem accepts_iff_acceptsWith (x π ρ : List Bool) : /-! ### Realising a table by a proof -/ -/-- Every entry of a list is at most its running maximum. -/ -theorem le_foldr_max (l : List ℕ) {p : ℕ} (hp : p ∈ l) : p ≤ l.foldr max 0 := by - induction l with - | nil => exact absurd hp (by simp) - | cons a l ih => - rcases List.mem_cons.mp hp with h | h - · subst h - exact le_max_left _ _ - · exact le_trans (ih h) (le_max_right _ _) - /-- A bound past every position the verifier can query on `x` with `t` coins. -/ noncomputable def maxQuery (V : PCPVerifier) (t : ℕ) (x : List Bool) : ℕ := (Finset.univ.sup fun ρ : Fin t → Bool => @@ -76,7 +66,7 @@ noncomputable def maxQuery (V : PCPVerifier) (t : ℕ) (x : List Bool) : ℕ := theorem lt_maxQuery {t : ℕ} {x : List Bool} {ρ : Fin t → Bool} {p : ℕ} (hp : p ∈ V.positions x (BitString.toList ρ)) : p < V.maxQuery t x := by - have h1 : p ≤ (V.positions x (BitString.toList ρ)).foldr max 0 := le_foldr_max _ hp + have h1 : p ≤ (V.positions x (BitString.toList ρ)).foldr max 0 := List.le_max_of_le' 0 hp le_rfl have h2 : (V.positions x (BitString.toList ρ)).foldr max 0 ≤ Finset.univ.sup fun σ : Fin t → Bool => (V.positions x (BitString.toList σ)).foldr max 0 := diff --git a/Complexitylib/Classes/PCP/Internal/TowerFamily.lean b/Complexitylib/Classes/PCP/Internal/TowerFamily.lean deleted file mode 100644 index caf4e916..00000000 --- a/Complexitylib/Classes/PCP/Internal/TowerFamily.lean +++ /dev/null @@ -1,278 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey --/ -module -public import Complexitylib.Classes.PCP.Internal.SizedExpander -public import Complexitylib.Classes.PCP.Internal.MergeGen - -/-! -# The exact-size family a tower gives - -Assembling the pieces: for a requested size `n`, take the first tower member at -least twice as large, number its vertices and darts, fold it onto `n` at the -width the overshoot dictates, and pad the degree up to a bound that does not -depend on `n`. - -Each step has been justified separately — `toFinForm` numbers the types, -`spectralBound_mergedN` folds at any width, `spectralBound_padLoops` pads the -degree — and this module only has to supply the arithmetic linking them. - -## Main definitions - -- `Complexity.ZigZagBase.famGraph` — the member for a requested size - -## Main results - -- `Complexity.ZigZagBase.order_famGraph`, `deg_famGraph` — it has exactly the - requested size, and a degree independent of it --/ - -@[expose] public section - -namespace Complexity - -namespace ZigZagBase - -variable (B : ZigZagBase) (hd : 1 < B.base.deg) - -/-- The width bound: the overshoot of the tower is at most `2 deg ^ 4`. -/ -def widthBound : ℕ := 2 * B.base.deg ^ 4 + 1 - -/-- The family's degree: the width bound times the tower's degree. -/ -def famDegree : ℕ := B.widthBound * B.base.deg ^ 2 - -theorem famDegree_pos : 0 < B.famDegree := by - have h1 : 0 < B.widthBound := by - rw [widthBound] - omega - have h2 : 0 < B.base.deg ^ 2 := by - have := B.base.deg_pos - positivity - rw [famDegree] - exact Nat.mul_pos h1 h2 - -/-- The size of the tower member used for `n`. -/ -noncomputable def fitN (n : ℕ) : ℕ := (tower B (B.fitIndex hd n)).graph.order - -/-- The degree of every tower member. -/ -def fitD : ℕ := B.base.deg ^ 2 - -theorem fitD_pos : 0 < B.fitD := by - have := B.base.deg_pos - rw [fitD] - positivity - -/-- The tower member used for size `n`, with both its types numbered. -/ -noncomputable def fitGraph (n : ℕ) : RegGraph := - (tower B (B.fitIndex hd n)).graph.toFinFormOf (B.fitN hd n) B.fitD rfl (deg_fit B hd n) - -@[simp] theorem order_fitGraph (n : ℕ) : (B.fitGraph hd n).order = B.fitN hd n := - RegGraph.order_toFinFormOf _ _ _ _ _ - -@[simp] theorem deg_fitGraph (n : ℕ) : (B.fitGraph hd n).deg = B.fitD := - RegGraph.deg_toFinFormOf _ _ _ _ _ - -theorem spectral_fitGraph (n : ℕ) : (B.fitGraph hd n).SpectralBound (2 / 5) := - RegGraph.spectralBound_toFinFormOf _ _ _ _ _ (spectral_fit B hd n) - -/-- The width used to fold that member onto `n`. -/ -noncomputable def fitWidth (n : ℕ) : ℕ := RegGraph.mergeWidth (B.fitN hd n) n - -theorem three_le_fitWidth {n : ℕ} (hn : 0 < n) : 3 ≤ B.fitWidth hd n := - RegGraph.three_le_mergeWidth hn (two_mul_le_order_fit B hd n) - -theorem fitWidth_pos {n : ℕ} (hn : 0 < n) : 0 < B.fitWidth hd n := by - have := B.three_le_fitWidth hd hn - omega - -theorem fitWidth_le {n : ℕ} (hn : 0 < n) : B.fitWidth hd n ≤ B.widthBound := by - rw [fitWidth, widthBound] - exact RegGraph.mergeWidth_le hn (order_fit_le B hd n hn) - -theorem fitN_le_fitWidth_mul {n : ℕ} (hn : 0 < n) : B.fitN hd n ≤ B.fitWidth hd n * n := - RegGraph.le_mergeWidth_mul _ hn - -theorem fitWidth_sub_one_mul_le (n : ℕ) : (B.fitWidth hd n - 1) * n ≤ B.fitN hd n := - RegGraph.mergeWidth_sub_one_mul_le _ _ - -theorem two_mul_le_fitN (n : ℕ) : 2 * n ≤ B.fitN hd n := two_mul_le_order_fit B hd n - -/-- The rotation map of that member, at the numeric type it lives on. -/ -noncomputable def fitRot (n : ℕ) : - Fin (B.fitN hd n) × Fin B.fitD → Fin (B.fitN hd n) × Fin B.fitD := - (B.fitGraph hd n).rot - -theorem fitRot_involutive (n : ℕ) : Function.Involutive (B.fitRot hd n) := - (B.fitGraph hd n).rot_involutive - -theorem base_fitGraph (n : ℕ) : - RegGraph.ofRot B.fitD B.fitD_pos (B.fitN hd n) (B.fitRot hd n) (B.fitRot_involutive hd n) - = B.fitGraph hd n := rfl - -/-! ### The fold -/ - -/-- The tower member folded onto exactly `n` vertices. -/ -noncomputable def mergedGraph {n : ℕ} (hn : 0 < n) : RegGraph := - RegGraph.mergedN hn B.fitD_pos (B.fitWidth_pos hd hn) (B.fitN_le_fitWidth_mul hd hn) - (B.fitRot hd n) (B.fitRot_involutive hd n) - -@[simp] theorem order_mergedGraph {n : ℕ} (hn : 0 < n) : (B.mergedGraph hd hn).order = n := - RegGraph.order_mergedN _ _ _ _ _ _ - -@[simp] theorem deg_mergedGraph {n : ℕ} (hn : 0 < n) : - (B.mergedGraph hd hn).deg = B.fitWidth hd n * B.fitD := - RegGraph.deg_mergedN _ _ _ _ _ _ - -/-- Folding at width at least three keeps the contraction below `4/5`. -/ -theorem spectral_mergedGraph {n : ℕ} (hn : 0 < n) : - (B.mergedGraph hd hn).SpectralBound (4 / 5) := by - have hspec : (RegGraph.base B.fitD_pos (B.fitRot hd n) - (B.fitRot_involutive hd n)).SpectralBound (2 / 5) := by - rw [show RegGraph.base B.fitD_pos (B.fitRot hd n) (B.fitRot_involutive hd n) - = B.fitGraph hd n from B.base_fitGraph hd n] - exact B.spectral_fitGraph hd n - have hmerged := RegGraph.spectralBound_mergedN hn B.fitD_pos (B.fitWidth_pos hd hn) - (B.fitN_le_fitWidth_mul hd hn) (B.fitWidth_sub_one_mul_le hd n) (B.two_mul_le_fitN hd n) - (B.fitRot hd n) (B.fitRot_involutive hd n) (by norm_num) hspec - refine hmerged.mono (Real.sqrt_nonneg _) ?_ - rw [show (4 : ℝ) / 5 = Real.sqrt ((4 / 5) ^ 2) by - rw [Real.sqrt_sq (by norm_num)]] - refine Real.sqrt_le_sqrt ?_ - have hm3 : (3 : ℝ) ≤ (B.fitWidth hd n : ℝ) := by - exact_mod_cast B.three_le_fitWidth hd hn - set m : ℝ := (B.fitWidth hd n : ℝ) - have h1 : (1 - (2 / 5 : ℝ) ^ 2) / (2 * m) ≤ (1 - (2 / 5 : ℝ) ^ 2) / (2 * 3) := by - apply div_le_div_of_nonneg_left (by norm_num) (by norm_num) (by linarith) - have h2 : (1 : ℝ) / m ≤ 1 / 3 := by - apply div_le_div_of_nonneg_left (by norm_num) (by norm_num) hm3 - nlinarith [h1, h2] - -/-! ### The padding -/ - -theorem fitWidth_mul_fitD_le {n : ℕ} (hn : 0 < n) : - B.fitWidth hd n * B.fitD ≤ B.famDegree := - Nat.mul_le_mul_right _ (B.fitWidth_le hd hn) - -/-- The fold padded up to the family's uniform degree. -/ -noncomputable def paddedGraph {n : ℕ} (hn : 0 < n) : RegGraph := - (B.mergedGraph hd hn).padLoops (B.famDegree - B.fitWidth hd n * B.fitD) - -@[simp] theorem order_paddedGraph {n : ℕ} (hn : 0 < n) : (B.paddedGraph hd hn).order = n := - B.order_mergedGraph hd hn - -@[simp] theorem deg_paddedGraph {n : ℕ} (hn : 0 < n) : - (B.paddedGraph hd hn).deg = B.famDegree := by - rw [paddedGraph, RegGraph.deg_padLoops, deg_mergedGraph] - have := B.fitWidth_mul_fitD_le hd hn - omega - -/-- The uniform contraction factor of the family. -/ -noncomputable def famLam : ℝ := Real.sqrt (1 - 27 / (25 * B.widthBound)) - -theorem three_le_widthBound : 3 ≤ B.widthBound := by - have := B.base.deg_pos - have : 1 ≤ B.base.deg ^ 4 := Nat.one_le_pow _ _ this - rw [widthBound] - omega - -theorem famLam_nonneg : 0 ≤ B.famLam := Real.sqrt_nonneg _ - -theorem famLam_lt_one : B.famLam < 1 := by - have hW : (3 : ℝ) ≤ (B.widthBound : ℝ) := by exact_mod_cast B.three_le_widthBound - have h0 : (0 : ℝ) ≤ 1 - 27 / (25 * B.widthBound) := by - rw [sub_nonneg, div_le_one (by linarith)] - linarith - have hlt : (1 : ℝ) - 27 / (25 * B.widthBound) < 1 := by - have : (0 : ℝ) < 27 / (25 * B.widthBound) := by positivity - linarith - calc B.famLam = Real.sqrt (1 - 27 / (25 * B.widthBound)) := rfl - _ < Real.sqrt 1 := Real.sqrt_lt_sqrt h0 hlt - _ = 1 := Real.sqrt_one - -theorem spectral_paddedGraph {n : ℕ} (hn : 0 < n) : - (B.paddedGraph hd hn).SpectralBound B.famLam := by - have hpad := RegGraph.spectralBound_padLoops (G := B.mergedGraph hd hn) - (B.famDegree - B.fitWidth hd n * B.fitD) (B.spectral_mergedGraph hd hn) - refine hpad.mono (Real.sqrt_nonneg _) ?_ - rw [famLam] - refine Real.sqrt_le_sqrt ?_ - have hle : B.fitWidth hd n * B.fitD ≤ B.famDegree := B.fitWidth_mul_fitD_le hd hn - have hF : (0 : ℝ) < (B.fitD : ℝ) := by exact_mod_cast B.fitD_pos - have hW : (3 : ℝ) ≤ (B.widthBound : ℝ) := by exact_mod_cast B.three_le_widthBound - have hm : (3 : ℝ) ≤ (B.fitWidth hd n : ℝ) := by exact_mod_cast B.three_le_fitWidth hd hn - have hDeg : ((B.famDegree : ℝ)) = (B.widthBound : ℝ) * (B.fitD : ℝ) := by - rw [famDegree, fitD]; push_cast; ring - have hk : (((B.famDegree - B.fitWidth hd n * B.fitD : ℕ) : ℝ)) - = (B.famDegree : ℝ) - (B.fitWidth hd n : ℝ) * (B.fitD : ℝ) := by - rw [Nat.cast_sub hle]; push_cast; ring - have hDpos : (0 : ℝ) < (B.widthBound : ℝ) * (B.fitD : ℝ) := by positivity - rw [B.deg_mergedGraph hd hn, hk] - push_cast - rw [hDeg, show ((B.fitWidth hd n : ℝ) * (B.fitD : ℝ) - + ((B.widthBound : ℝ) * (B.fitD : ℝ) - (B.fitWidth hd n : ℝ) * (B.fitD : ℝ))) - = (B.widthBound : ℝ) * (B.fitD : ℝ) from by ring, div_le_iff₀ hDpos, sub_mul, one_mul, - show 27 / (25 * (B.widthBound : ℝ)) * ((B.widthBound : ℝ) * (B.fitD : ℝ)) - = 27 * (B.fitD : ℝ) / 25 from by field_simp] - nlinarith [mul_le_mul_of_nonneg_right hm (le_of_lt hF)] - -/-! ### The family -/ - -/-- The member of the family on `n` vertices, for `n` positive: the padded fold, -with its darts numbered by the family's uniform degree. -/ -noncomputable def famGraphPos {n : ℕ} (hn : 0 < n) : RegGraph := - (B.paddedGraph hd hn).relabel - (Fintype.equivFinOfCardEq (B.deg_paddedGraph hd hn)) - -theorem famGraphPos_V {n : ℕ} (hn : 0 < n) : (B.famGraphPos hd hn).V = Fin n := rfl - -theorem famGraphPos_D {n : ℕ} (hn : 0 < n) : (B.famGraphPos hd hn).D = Fin B.famDegree := rfl - -theorem spectral_famGraphPos {n : ℕ} (hn : 0 < n) : - (B.famGraphPos hd hn).SpectralBound B.famLam := - RegGraph.spectralBound_relabel _ _ (B.spectral_paddedGraph hd hn) - -/-- The family's rotation map: the padded fold when there is anything to fold, -and the identity on the empty vertex set otherwise. -/ -noncomputable def famRot (n : ℕ) : - Fin n × Fin B.famDegree → Fin n × Fin B.famDegree := - if hn : 0 < n then (B.famGraphPos hd hn).rot else id - -theorem famRot_involutive (n : ℕ) : Function.Involutive (B.famRot hd n) := by - rw [famRot] - split - · exact (B.famGraphPos hd ‹_›).rot_involutive - · exact fun x => rfl - -theorem famRot_eq {n : ℕ} (hn : 0 < n) : B.famRot hd n = (B.famGraphPos hd hn).rot := by - rw [famRot, dif_pos hn] - -theorem spectral_famRot (n : ℕ) : - (RegGraph.ofRot B.famDegree B.famDegree_pos n (B.famRot hd n) - (B.famRot_involutive hd n)).SpectralBound B.famLam := by - rcases Nat.eq_zero_or_pos n with h | hn - · subst h - exact RegGraph.spectralBound_of_isEmpty (by exact Fin.isEmpty' ) _ - · have key : ∀ (r : Fin n × Fin B.famDegree → Fin n × Fin B.famDegree) - (hr : Function.Involutive r), r = (B.famGraphPos hd hn).rot → - (RegGraph.ofRot B.famDegree B.famDegree_pos n r hr).SpectralBound B.famLam := by - rintro r hr rfl - exact B.spectral_famGraphPos hd hn - exact key _ _ (B.famRot_eq hd hn) - -/-- The expander family a zig-zag base generates: one member at every size, of a -degree that does not depend on the size, all contracting by the same factor. -/ -noncomputable def family : ExpanderFamily where - degree := B.famDegree - degree_pos := B.famDegree_pos - rot := B.famRot hd - rot_involutive := B.famRot_involutive hd - lam := B.famLam - lam_nonneg := B.famLam_nonneg - lam_lt_one := B.famLam_lt_one - spectral := B.spectral_famRot hd - -end ZigZagBase - -end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/TowerFin.lean b/Complexitylib/Classes/PCP/Internal/TowerFin.lean index b87ab1fc..2480c7c1 100644 --- a/Complexitylib/Classes/PCP/Internal/TowerFin.lean +++ b/Complexitylib/Classes/PCP/Internal/TowerFin.lean @@ -31,7 +31,6 @@ level's types be `Fin` on the nose rather than up to a transport. - `Complexity.FinBase.graphAt_succ` — one level is a zig-zag of the previous - `Complexity.FinBase.spectral_graphAt` — every level has bound `2 / 5` - `Complexity.FinBase.rotVal_eq` — the numeric recursion computes it -- `Complexity.FinBase.toSized` — the numbered tower as a size-flexible family - `Complexity.nonempty_finBase` — a numbered base exists -/ @@ -441,20 +440,6 @@ theorem size_level_le (hd : 1 < F.deg) (n : ℕ) (hn : 1 ≤ n) : calc (F.deg ^ 4) ^ (m + 1 + 1) = F.deg ^ 4 * (F.deg ^ 4) ^ (m + 1) := by ring _ ≤ F.deg ^ 4 * n := Nat.mul_le_mul_left _ hprev.le -/-- **The numbered tower, as a size-flexible family.** -/ -noncomputable def toSized (hd : 1 < F.deg) : SizedExpanderFamily where - degree := F.deg ^ 2 - degree_pos := F.sq_pos - factor := F.deg ^ 4 - graph := fun n => F.graphAt (F.level hd n) - deg_graph := fun n => F.deg_graphAt _ - order_ge := fun n => by rw [order_graphAt]; exact F.le_size_level hd n - order_le := fun n hn => by rw [order_graphAt]; exact F.size_level_le hd n hn - lam := 2 / 5 - lam_nonneg := by norm_num - lam_lt_one := by norm_num - spectral := fun n => spectral_graphAt F _ - end FinBase /-! ### Numbering a base -/ diff --git a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean index afdf515b..27534762 100644 --- a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean +++ b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean @@ -106,7 +106,7 @@ theorem dmStep_iterate {B : List Bool} (hb : 0 < B.length) : /-! ### Halving -/ -theorem length_selectHead_le' (s x y : List Bool) : +theorem length_selectHead_le (s x y : List Bool) : (Cobham.selectHead s x y).length ≤ max x.length y.length := by rw [Cobham.selectHead] split @@ -125,9 +125,9 @@ theorem dmStep_one (q r b : List Bool) : have hb : Cobham.sndBlock (pair (pair q r) b) = b := Cobham.sndBlock_pair _ _ rw [dmStep, hq, hr, hb] refine ⟨_, _, rfl, ?_, ?_⟩ - · refine le_trans (length_selectHead_le' _ _ _) ?_ + · refine le_trans (length_selectHead_le _ _ _) ?_ simp - · refine le_trans (length_selectHead_le' _ _ _) ?_ + · refine le_trans (length_selectHead_le _ _ _) ?_ simp theorem dmStep_shape : ∀ (k : ℕ) (q r b : List Bool), diff --git a/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean b/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean index a7bb430f..5f626e45 100644 --- a/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean +++ b/Complexitylib/Classes/PCP/Internal/ZigZagBaseExists.lean @@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Bolton Bailey -/ module -public import Complexitylib.Classes.PCP.Internal.SizedExpander +public import Complexitylib.Classes.PCP.Internal.ZigZagTower public import Complexitylib.Classes.PCP.Internal.ExpanderExists /-! @@ -30,8 +30,6 @@ Applied to `randExpander`, this shows a `ZigZagBase` exists. ## Main results - `Complexity.nonempty_zigZagBase` — a base graph exists -- `Complexity.nonempty_sizedExpanderFamily` — so the tower's size-flexible - family exists too -/ @[expose] public section @@ -83,18 +81,10 @@ theorem one_lt_deg_toZigZagBase (h : 1 < E.degree) : 1 < E.toZigZagBase.base.deg rw [deg_toZigZagBase] exact Nat.one_lt_pow (by have := E.one_le_fifthExp; omega) h -/-- **The tower's size-flexible family, from any expander family.** -/ -noncomputable def toSizedFamily (h : 1 < E.degree) : SizedExpanderFamily := - E.toZigZagBase.toSized (E.one_lt_deg_toZigZagBase h) - end ExpanderFamily /-- **A base graph for the tower exists.** -/ theorem nonempty_zigZagBase : Nonempty ZigZagBase := ⟨randExpander.toZigZagBase⟩ -/-- **A size-flexible family exists.** -/ -theorem nonempty_sizedExpanderFamily : Nonempty SizedExpanderFamily := - ⟨randExpander.toSizedFamily (by show 1 < 120; norm_num)⟩ - end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean b/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean index 4ba9cb98..7072b1dc 100644 --- a/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean +++ b/Complexitylib/Classes/PCP/Internal/ZigZagTower.lean @@ -6,7 +6,7 @@ Authors: Bolton Bailey module public import Complexitylib.Classes.PCP.Internal.ZigZag public import Complexitylib.Classes.PCP.Internal.Power -public import Complexitylib.Classes.PCP.Internal.ExpanderAssemble +public import Complexitylib.Classes.PCP.Internal.ExpanderPad /-! # The zig-zag tower diff --git a/Complexitylib/SAT/CookLevin.lean b/Complexitylib/SAT/CookLevin.lean index a54b4712..3d545216 100644 --- a/Complexitylib/SAT/CookLevin.lean +++ b/Complexitylib/SAT/CookLevin.lean @@ -796,16 +796,6 @@ theorem assignOf_get {M : ℕ} (g : ℕ → Bool) {v : ℕ} (h : v < M) : (assignOf M g).get v = g v := by simp [assignOf, Assignment.get, h] -/-- Every element of a list is bounded by the list's `foldr max 0`. -/ -theorem le_foldr_max {v : ℕ} {l : List ℕ} (h : v ∈ l) : v ≤ l.foldr max 0 := by - induction l with - | nil => simp at h - | cons a t ih => - rw [List.foldr_cons] - rcases List.mem_cons.mp h with h' | h' - · subst h'; exact le_max_left _ _ - · exact le_trans (ih h') (le_max_right _ _) - /-- Indicator assignment for a finite list of "true" variables: every listed variable reads `true`, every other variable reads `false`. The truncation length is one past the list's maximum, so listed variables stay in range while @@ -815,7 +805,7 @@ def listAssign (l : List ℕ) : Assignment := assignOf (l.foldr max 0 + 1) (fun /-- `listAssign l` reads `true` on every listed variable. -/ theorem listAssign_get_true {l : List ℕ} {v : ℕ} (h : v ∈ l) : (listAssign l).get v = true := by - rw [listAssign, assignOf_get _ (Nat.lt_succ_of_le (le_foldr_max h))] + rw [listAssign, assignOf_get _ (Nat.lt_succ_of_le (List.le_max_of_le' 0 h le_rfl))] simp [h] /-- `listAssign l` reads `false` on every unlisted variable. -/ diff --git a/Complexitylib/SAT/Rename.lean b/Complexitylib/SAT/Rename.lean index 97bc896a..2284073a 100644 --- a/Complexitylib/SAT/Rename.lean +++ b/Complexitylib/SAT/Rename.lean @@ -6,6 +6,7 @@ Authors: Samuel Schlesinger module public import Complexitylib.SAT.Semantics +public import Mathlib.Data.List.MinMax /-! # Variable renaming and satisfiability transport @@ -84,16 +85,6 @@ theorem Assignment.ofFn_get {M v : ℕ} (g : ℕ → Bool) (h : v < M) : (Assignment.ofFn M g).get v = g v := by simp [Assignment.ofFn, Assignment.get, List.getElem?_map, List.getElem?_range h] -/-- Every member is at most the `foldr max` of its list. -/ -private theorem le_foldr_max' {v : ℕ} {l : List ℕ} (h : v ∈ l) : - v ≤ l.foldr max 0 := by - induction l with - | nil => exact (List.not_mem_nil h).elim - | cons a l ih => - rcases List.mem_cons.mp h with rfl | h - · exact le_max_left _ _ - · exact le_trans (ih h) (le_max_right _ _) - -- ════════════════════════════════════════════════════════════════════════ -- Evaluation commutes with renaming -- ════════════════════════════════════════════════════════════════════════ @@ -145,7 +136,7 @@ theorem CNF.Satisfiable.mapVar {f : ℕ → ℕ} (hf : Function.Injective f) {φ · have hfv : f v < M := by rw [hM] exact Nat.lt_succ_of_le - (le_foldr_max' (List.mem_map_of_mem (List.mem_range.mpr hv))) + (List.le_max_of_le' 0 (List.mem_map_of_mem (List.mem_range.mpr hv)) le_rfl) rw [hα, Assignment.ofFn_get _ hfv] cases hβv : β.get v with | false => From 9901e8cda36ad8e82ab80402d34f04392c215e9e Mon Sep 17 00:00:00 2001 From: Bolton Bailey Date: Sun, 30 Aug 2026 07:22:55 -0700 Subject: [PATCH 24/24] pair names + build --- .../Containments/Internal/BinArith.lean | 68 ++--- .../Containments/Internal/BlockAccept.lean | 40 +-- .../Containments/Internal/BlockMember.lean | 48 ++-- .../Containments/Internal/BlockSearch.lean | 20 +- .../Containments/Internal/CodeRewind.lean | 12 +- .../Containments/Internal/FPBridge.lean | 10 +- .../Containments/Internal/IPAssemble.lean | 24 +- .../Classes/Containments/Internal/IPLeaf.lean | 62 ++--- .../Classes/Containments/Internal/IPStep.lean | 52 ++-- .../Internal/NLSearchAssemble.lean | 4 +- .../Containments/Internal/PVerdict.lean | 18 +- .../Containments/Internal/SavitchBits.lean | 30 +-- .../Containments/Internal/SavitchFrame.lean | 30 +-- .../Containments/Internal/SavitchStep.lean | 8 +- .../Containments/Internal/TranscriptEnc.lean | 20 +- Complexitylib/Classes/Interactive.lean | 14 +- Complexitylib/Classes/PCP.lean | 3 +- Complexitylib/Classes/PCP/Defs.lean | 2 +- Complexitylib/Classes/PCP/Internal.lean | 36 +++ .../Classes/PCP/Internal/AlgEdge.lean | 34 +-- .../Classes/PCP/Internal/AlgFamily.lean | 18 +- .../Classes/PCP/Internal/AlgGapCSP.lean | 30 +-- .../Classes/PCP/Internal/AlgGraph.lean | 40 +-- .../Classes/PCP/Internal/AlgInit.lean | 28 +- .../Classes/PCP/Internal/AlgKey.lean | 20 +- .../Classes/PCP/Internal/AlgKeyFn.lean | 40 +-- .../Classes/PCP/Internal/AlgKilled.lean | 56 ++-- .../Classes/PCP/Internal/AlgLevel.lean | 50 ++-- .../Classes/PCP/Internal/AlgLog.lean | 28 +- .../Classes/PCP/Internal/AlgPCP.lean | 2 +- .../Classes/PCP/Internal/AlgPreRot.lean | 250 +++++++++--------- .../Classes/PCP/Internal/BaseAlg.lean | 70 ++--- .../Classes/PCP/Internal/BinToUnary.lean | 20 +- .../Classes/PCP/Internal/BitwiseFP.lean | 16 +- .../Classes/PCP/Internal/CNFCount.lean | 28 +- .../Classes/PCP/Internal/CNFMaxVar.lean | 14 +- .../Classes/PCP/Internal/CNFSegment.lean | 66 ++--- .../Classes/PCP/Internal/CSPVerifier.lean | 80 +++--- .../Classes/PCP/Internal/ConsistencyLang.lean | 42 +-- .../Classes/PCP/Internal/DataScan.lean | 42 +-- .../PCP/Internal/GuessVerifyGeneric.lean | 28 +- .../Classes/PCP/Internal/ListEncode.lean | 40 +-- .../Classes/PCP/Internal/Materialize.lean | 30 +-- .../Classes/PCP/Internal/MaxLoop.lean | 44 +-- .../Classes/PCP/Internal/NatEncode.lean | 40 +-- .../Classes/PCP/Internal/PositionsFP.lean | 26 +- .../Classes/PCP/Internal/SquareVerifier.lean | 38 +-- .../Classes/PCP/Internal/StripTrailing.lean | 20 +- .../Classes/PCP/Internal/SubsetNPFinal.lean | 12 +- .../Classes/PCP/Internal/TowerTable.lean | 12 +- .../Classes/PCP/Internal/UnaryDivMod.lean | 82 +++--- .../Classes/PCP/Internal/UnaryList.lean | 2 +- .../Classes/PCP/Internal/VerifierLang.lean | 28 +- Complexitylib/Classes/PH.lean | 13 +- .../Classes/PH/SipserLautemann/Matrix.lean | 10 +- .../Classes/PH/SipserLautemann/Verdict.lean | 28 +- 56 files changed, 976 insertions(+), 952 deletions(-) diff --git a/Complexitylib/Classes/Containments/Internal/BinArith.lean b/Complexitylib/Classes/Containments/Internal/BinArith.lean index e2dc564b..919ab1e8 100644 --- a/Complexitylib/Classes/Containments/Internal/BinArith.lean +++ b/Complexitylib/Classes/Containments/Internal/BinArith.lean @@ -206,15 +206,15 @@ def addPack (c acc ru rv : List Bool) : List Bool := pair c (pair acc (pair ru r /-- One step of the packed scan. -/ def addStepP (z : List Bool) : List Bool := - selectHead (lenLeFlag (fstBlock (sndBlock (sndBlock z))) [false]) + selectHead (lenLeFlag (pairFst (pairSnd (pairSnd z))) [false]) (addPack - (majBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) - (bit1 (sndBlock (sndBlock (sndBlock z))))) - (fstBlock (sndBlock z) ++ - sumBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) - (bit1 (sndBlock (sndBlock (sndBlock z))))) - ((fstBlock (sndBlock (sndBlock z))).drop 1) - ((sndBlock (sndBlock (sndBlock z))).drop 1)) + (majBit (pairFst z) (bit1 (pairFst (pairSnd (pairSnd z)))) + (bit1 (pairSnd (pairSnd (pairSnd z))))) + (pairFst (pairSnd z) ++ + sumBit (pairFst z) (bit1 (pairFst (pairSnd (pairSnd z)))) + (bit1 (pairSnd (pairSnd (pairSnd z))))) + ((pairFst (pairSnd (pairSnd z))).drop 1) + ((pairSnd (pairSnd (pairSnd z))).drop 1)) z /-- **The packed step is the unpacked step.** -/ @@ -223,7 +223,7 @@ theorem addStepP_pack (c acc ru rv : List Bool) : = addPack (addStep (c, acc, ru, rv)).1 (addStep (c, acc, ru, rv)).2.1 (addStep (c, acc, ru, rv)).2.2.1 (addStep (c, acc, ru, rv)).2.2.2 := by rw [addStepP, addPack] - simp only [fstBlock_pair, sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] cases ru with | nil => have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl @@ -260,10 +260,10 @@ theorem addStepP_iterate_args (c acc ru rv : List Bool) (n : ℕ) : def addRun (u v : List Bool) : List Bool := addStepP^[u.length] (addPack [false] [] u v) /-- The sum bits of `u` and `v`. -/ -def addBits (u v : List Bool) : List Bool := fstBlock (sndBlock (addRun u v)) +def addBits (u v : List Bool) : List Bool := pairFst (pairSnd (addRun u v)) /-- The carry out of `u + v`. -/ -def addCarry (u v : List Bool) : List Bool := fstBlock (addRun u v) +def addCarry (u v : List Bool) : List Bool := pairFst (addRun u v) theorem addRun_eq (u v : List Bool) (h : v.length = u.length) : addRun u v = addPack [(addBitsLE false u v).1] (addBitsLE false u v).2 [] [] := by @@ -302,12 +302,12 @@ theorem addBits_length (u v : List Bool) (h : v.length = u.length) : theorem addStepP_mem_FP : addStepP ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -318,27 +318,27 @@ theorem addStepP_mem_FP : addStepP ∈ FP := by have hru := hfst hww have hrv := hsnd hww have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] - have htakeU : (fun z => bit1 (fstBlock (sndBlock (sndBlock z)))) ∈ FP := by + have htakeU : (fun z => bit1 (pairFst (pairSnd (pairSnd z)))) ∈ FP := by have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hru hone) simpa [bit1] using this - have htakeV : (fun z => bit1 (sndBlock (sndBlock (sndBlock z)))) ∈ FP := by + have htakeV : (fun z => bit1 (pairSnd (pairSnd (pairSnd z)))) ∈ FP := by have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hrv hone) simpa [bit1] using this - have hdropU : (fun z => (fstBlock (sndBlock (sndBlock z))).drop 1) ∈ FP := by + have hdropU : (fun z => (pairFst (pairSnd (pairSnd z))).drop 1) ∈ FP := by have := dropLenFn_mem_FP hone hru simpa using this - have hdropV : (fun z => (sndBlock (sndBlock (sndBlock z))).drop 1) ∈ FP := by + have hdropV : (fun z => (pairSnd (pairSnd (pairSnd z))).drop 1) ∈ FP := by have := dropLenFn_mem_FP hone hrv simpa using this have hxor : ∀ {a b : List Bool → List Bool}, a ∈ FP → b ∈ FP → (fun z => xorBit (a z) (b z)) ∈ FP := fun ha hb => Cobham.selectHeadFn_mem_FP ha (notBitFn_mem_FP hb) hb - have hmaj : (fun z => majBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) - (bit1 (sndBlock (sndBlock (sndBlock z))))) ∈ FP := + have hmaj : (fun z => majBit (pairFst z) (bit1 (pairFst (pairSnd (pairSnd z)))) + (bit1 (pairSnd (pairSnd (pairSnd z))))) ∈ FP := orBitFn_mem_FP (andBitFn_mem_FP hc htakeU) (orBitFn_mem_FP (andBitFn_mem_FP hc htakeV) (andBitFn_mem_FP htakeU htakeV)) - have hsum : (fun z => sumBit (fstBlock z) (bit1 (fstBlock (sndBlock (sndBlock z)))) - (bit1 (sndBlock (sndBlock (sndBlock z))))) ∈ FP := + have hsum : (fun z => sumBit (pairFst z) (bit1 (pairFst (pairSnd (pairSnd z)))) + (bit1 (pairSnd (pairSnd (pairSnd z))))) ∈ FP := hxor (hxor hc htakeU) htakeV exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hru hone) (Cobham.pairFn_mem_FP hmaj @@ -490,19 +490,19 @@ def ltPack (f ru rv : List Bool) : List Bool := pair f (pair ru rv) /-- One step of the packed comparison. -/ def ltStepP (z : List Bool) : List Bool := - selectHead (lenLeFlag (fstBlock (sndBlock z)) [false]) + selectHead (lenLeFlag (pairFst (pairSnd z)) [false]) (ltPack - (selectHead (eqFlag (bit1 (fstBlock (sndBlock z))) (bit1 (sndBlock (sndBlock z)))) - (fstBlock z) (bit1 (sndBlock (sndBlock z)))) - ((fstBlock (sndBlock z)).drop 1) - ((sndBlock (sndBlock z)).drop 1)) + (selectHead (eqFlag (bit1 (pairFst (pairSnd z))) (bit1 (pairSnd (pairSnd z)))) + (pairFst z) (bit1 (pairSnd (pairSnd z)))) + ((pairFst (pairSnd z)).drop 1) + ((pairSnd (pairSnd z)).drop 1)) z theorem ltStepP_pack (f ru rv : List Bool) : ltStepP (ltPack f ru rv) = ltPack (ltStep (f, ru, rv)).1 (ltStep (f, ru, rv)).2.1 (ltStep (f, ru, rv)).2.2 := by rw [ltStepP, ltPack] - simp only [fstBlock_pair, sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] cases ru with | nil => have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl @@ -534,7 +534,7 @@ theorem ltStepP_iterate_args (f ru rv : List Bool) (n : ℕ) : def ltRun (u v : List Bool) : List Bool := ltStepP^[u.length] (ltPack [false] u v) /-- Is `u` below `v`, as a flag. -/ -def ltFlag (u v : List Bool) : List Bool := fstBlock (ltRun u v) +def ltFlag (u v : List Bool) : List Bool := pairFst (ltRun u v) theorem ltFlag_eq (u v : List Bool) (h : v.length = u.length) : ltFlag u v = [ltBitsLE false u v] := by @@ -567,12 +567,12 @@ theorem ltFlag_flag (u v : List Bool) (h : v.length = u.length) : theorem ltStepP_mem_FP : ltStepP ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -581,16 +581,16 @@ theorem ltStepP_mem_FP : ltStepP ∈ FP := by have hru := hfst hw have hrv := hsnd hw have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] - have hbU : (fun z => bit1 (fstBlock (sndBlock z))) ∈ FP := by + have hbU : (fun z => bit1 (pairFst (pairSnd z))) ∈ FP := by have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hru hone) simpa [bit1] using this - have hbV : (fun z => bit1 (sndBlock (sndBlock z))) ∈ FP := by + have hbV : (fun z => bit1 (pairSnd (pairSnd z))) ∈ FP := by have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hrv hone) simpa [bit1] using this - have hdU : (fun z => (fstBlock (sndBlock z)).drop 1) ∈ FP := by + have hdU : (fun z => (pairFst (pairSnd z)).drop 1) ∈ FP := by have := dropLenFn_mem_FP hone hru simpa using this - have hdV : (fun z => (sndBlock (sndBlock z)).drop 1) ∈ FP := by + have hdV : (fun z => (pairSnd (pairSnd z)).drop 1) ∈ FP := by have := dropLenFn_mem_FP hone hrv simpa using this exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hru hone) diff --git a/Complexitylib/Classes/Containments/Internal/BlockAccept.lean b/Complexitylib/Classes/Containments/Internal/BlockAccept.lean index 91929e48..a9773473 100644 --- a/Complexitylib/Classes/Containments/Internal/BlockAccept.lean +++ b/Complexitylib/Classes/Containments/Internal/BlockAccept.lean @@ -58,18 +58,18 @@ def acceptPack (R ruler flag rest : List Bool) : List Bool := /-- One step of the accept scan. -/ noncomputable def acceptStep (k : ℕ) (qcode z : List Bool) : List Bool := - pair (fstBlock z) + pair (pairFst z) (selectHead - (lenLeFlag (sndBlock (sndBlock z)) - (wideRuler (codeBlocks k) (fstBlock (fstBlock z)))) + (lenLeFlag (pairSnd (pairSnd z)) + (wideRuler (codeBlocks k) (pairFst (pairFst z)))) (pair - (orBit (fstBlock (sndBlock z)) - (acceptFlag qcode (fstBlock (fstBlock z)) (sndBlock (fstBlock z)) - ((sndBlock (sndBlock z)).take - (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length))) - ((sndBlock (sndBlock z)).drop - (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length)) - (sndBlock z)) + (orBit (pairFst (pairSnd z)) + (acceptFlag qcode (pairFst (pairFst z)) (pairSnd (pairFst z)) + ((pairSnd (pairSnd z)).take + (wideRuler (codeBlocks k) (pairFst (pairFst z))).length))) + ((pairSnd (pairSnd z)).drop + (wideRuler (codeBlocks k) (pairFst (pairFst z))).length)) + (pairSnd z)) /-- The unpacked step the packed one performs. -/ noncomputable def acceptPairStep (k : ℕ) (qcode R ruler : List Bool) : @@ -82,7 +82,7 @@ theorem acceptStep_pack (k : ℕ) (qcode R ruler flag rest : List Bool) : = acceptPack R ruler (acceptPairStep k qcode R ruler (flag, rest)).1 (acceptPairStep k qcode R ruler (flag, rest)).2 := by rw [acceptStep, acceptPack] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] by_cases hle : (wideRuler (codeBlocks k) R).length ≤ rest.length · rw [acceptPairStep, anyStepPair_pos _ (acceptFlag qcode R ruler) (flag, rest) hle, Cobham.selectHead, @@ -116,14 +116,14 @@ theorem acceptStep_iterate (k : ℕ) (qcode R ruler : List Bool) /-- Does any record of `V` pass the accepting test? -/ noncomputable def acceptScan (k : ℕ) (qcode R ruler V : List Bool) : List Bool := - fstBlock (sndBlock ((acceptStep k qcode)^[V.length] (acceptPack R ruler [false] V))) + pairFst (pairSnd ((acceptStep k qcode)^[V.length] (acceptPack R ruler [false] V))) theorem acceptScan_flag (k : ℕ) (qcode R ruler V : List Bool) : acceptScan k qcode R ruler V = [true] ∨ acceptScan k qcode R ruler V = [false] := by rw [acceptScan, show V = ((([false] : List Bool), V)).2 from rfl, show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, acceptStep_iterate, acceptPack] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] exact anyStepPair_flag _ (fun z => acceptFlag_flag qcode R ruler z) (Or.inr rfl) _ /-- **The scan finds an accepting record exactly when there is one.** -/ @@ -139,7 +139,7 @@ theorem acceptScan_eq_true_iff (k : ℕ) (qcode R ruler V : List Bool) rw [acceptScan, show V = ((([false] : List Bool), V)).2 from rfl, show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, acceptStep_iterate, acceptPack] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] rw [acceptPairStep, anyStepPair_flag_eq_true_iff _ (fun z => acceptFlag_flag qcode R ruler z) _ (Or.inr rfl)] constructor @@ -157,12 +157,12 @@ theorem acceptScan_eq_true_iff (k : ℕ) (qcode R ruler V : List Bool) theorem acceptStep_mem_FP (k : ℕ) (qcode : List Bool) : acceptStep k qcode ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -173,11 +173,11 @@ theorem acceptStep_mem_FP (k : ℕ) (qcode : List Bool) : acceptStep k qcode ∈ have hflag := hfst htail have hrest := hsnd htail have hwide := wideRulerFn_mem_FP hR (codeBlocks k) - have htake : (fun z => (sndBlock (sndBlock z)).take - (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length) ∈ FP := + have htake : (fun z => (pairSnd (pairSnd z)).take + (wideRuler (codeBlocks k) (pairFst (pairFst z))).length) ∈ FP := Cobham.takeLenFn_mem_FP hwide hrest - have hdrop : (fun z => (sndBlock (sndBlock z)).drop - (wideRuler (codeBlocks k) (fstBlock (fstBlock z))).length) ∈ FP := + have hdrop : (fun z => (pairSnd (pairSnd z)).drop + (wideRuler (codeBlocks k) (pairFst (pairFst z))).length) ∈ FP := dropLenFn_mem_FP hwide hrest exact Cobham.pairFn_mem_FP hhead (Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hrest hwide) diff --git a/Complexitylib/Classes/Containments/Internal/BlockMember.lean b/Complexitylib/Classes/Containments/Internal/BlockMember.lean index d5004e95..52804de5 100644 --- a/Complexitylib/Classes/Containments/Internal/BlockMember.lean +++ b/Complexitylib/Classes/Containments/Internal/BlockMember.lean @@ -191,23 +191,23 @@ def memPack (R u f rest : List Bool) : List Bool := pair R (pair (pair u f) rest /-- One step of the scan on the packed state. -/ def memStep (z : List Bool) : List Bool := - pair (Cobham.fstBlock z) + pair (pairFst z) (Cobham.selectHead - (Cobham.lenLeFlag (Cobham.sndBlock (Cobham.sndBlock z)) (Cobham.fstBlock z)) + (Cobham.lenLeFlag (pairSnd (pairSnd z)) (pairFst z)) (pair - (pair (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) - (orBit (Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock z))) - (Cobham.eqFlag (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) - ((Cobham.sndBlock (Cobham.sndBlock z)).take (Cobham.fstBlock z).length)))) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop (Cobham.fstBlock z).length)) - (Cobham.sndBlock z)) + (pair (pairFst (pairFst (pairSnd z))) + (orBit (pairSnd (pairFst (pairSnd z))) + (Cobham.eqFlag (pairFst (pairFst (pairSnd z))) + ((pairSnd (pairSnd z)).take (pairFst z).length)))) + ((pairSnd (pairSnd z)).drop (pairFst z).length)) + (pairSnd z)) /-- **The packed step is the unpacked step.** -/ theorem memStep_pack (R u f rest : List Bool) : memStep (memPack R u f rest) = memPack R u (scanStep R u (f, rest)).1 (scanStep R u (f, rest)).2 := by rw [memStep, memPack] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] by_cases hle : R.length ≤ rest.length · rw [scanStep, anyStepPair_pos R (eqFlag u) (f, rest) hle, Cobham.selectHead, if_pos (by rw [(Cobham.lenLeFlag_eq_true_iff rest R).mpr hle]; rfl)] @@ -235,7 +235,7 @@ theorem memStep_iterate (R u : List Bool) (s : List Bool × List Bool) (n : ℕ) /-- Does the block `u` occur in the block-aligned string `V`? -/ def memFlag (R u V : List Bool) : List Bool := - Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock (memStep^[V.length] + pairSnd (pairFst (pairSnd (memStep^[V.length] (memPack R u [false] V)))) theorem memFlag_flag (R u V : List Bool) : @@ -243,7 +243,7 @@ theorem memFlag_flag (R u V : List Bool) : rw [memFlag, show V = ((([false] : List Bool), V)).2 from rfl, show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, memStep_iterate, memPack] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] exact scanStep_flag R u (Or.inr rfl) _ /-- **The scan decides membership.** -/ @@ -253,7 +253,7 @@ theorem memFlag_eq_true_iff (R u V : List Bool) (hR : 0 < R.length) : rw [memFlag, show V = ((([false] : List Bool), V)).2 from rfl, show ([false] : List Bool) = ((([false] : List Bool), V)).1 from rfl, memStep_iterate, memPack] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] rw [scanStep_flag_eq_true_iff R u _ (Or.inr rfl)] constructor · rintro (h | ⟨i, -, hlen, hblk⟩) @@ -269,12 +269,12 @@ theorem memFlag_eq_true_iff (R u V : List Bool) (hR : 0 < R.length) : theorem memStep_mem_FP : memStep ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => Cobham.fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => Cobham.sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -283,15 +283,15 @@ theorem memStep_mem_FP : memStep ∈ FP := by have hrest := hsnd hw have hu := hfst (hfst hw) have hf := hsnd (hfst hw) - have htake : (fun z => (Cobham.sndBlock (Cobham.sndBlock z)).take - (Cobham.fstBlock z).length) ∈ FP := Cobham.takeLenFn_mem_FP hR hrest - have hdrop : (fun z => (Cobham.sndBlock (Cobham.sndBlock z)).drop - (Cobham.fstBlock z).length) ∈ FP := dropLenFn_mem_FP hR hrest - have hthen : (fun z => pair (pair (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) - (orBit (Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock z))) - (Cobham.eqFlag (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock z))) - ((Cobham.sndBlock (Cobham.sndBlock z)).take (Cobham.fstBlock z).length)))) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop (Cobham.fstBlock z).length)) ∈ FP := + have htake : (fun z => (pairSnd (pairSnd z)).take + (pairFst z).length) ∈ FP := Cobham.takeLenFn_mem_FP hR hrest + have hdrop : (fun z => (pairSnd (pairSnd z)).drop + (pairFst z).length) ∈ FP := dropLenFn_mem_FP hR hrest + have hthen : (fun z => pair (pair (pairFst (pairFst (pairSnd z))) + (orBit (pairSnd (pairFst (pairSnd z))) + (Cobham.eqFlag (pairFst (pairFst (pairSnd z))) + ((pairSnd (pairSnd z)).take (pairFst z).length)))) + ((pairSnd (pairSnd z)).drop (pairFst z).length)) ∈ FP := Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hu (orBitFn_mem_FP hf (eqFlagFn_mem_FP hu htake))) hdrop exact Cobham.pairFn_mem_FP hR @@ -320,7 +320,7 @@ theorem memFlagFn_mem_FP {Rf uf Vf : List Bool → List Bool} ≤ (memPack (Rf z) (uf z) [false] (Vf z)).length := fun z n _ => memStep_iterate_length_le (Rf z) (uf z) ([false], Vf z) (Or.inr rfl) n have h := Cobham.iterate_mem_FP memStep_mem_FP hinit hV hinit hbound - have hcomp : (fun z => Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock + have hcomp : (fun z => pairSnd (pairFst (pairSnd (memStep^[(Vf z).length] (memPack (Rf z) (uf z) [false] (Vf z)))))) ∈ FP := by have h1 := mem_FP_comp h Cobham.sndBlock_mem_FP have h2 := mem_FP_comp h1 Cobham.fstBlock_mem_FP diff --git a/Complexitylib/Classes/Containments/Internal/BlockSearch.lean b/Complexitylib/Classes/Containments/Internal/BlockSearch.lean index 897b2b0b..a2a921de 100644 --- a/Complexitylib/Classes/Containments/Internal/BlockSearch.lean +++ b/Complexitylib/Classes/Containments/Internal/BlockSearch.lean @@ -171,20 +171,20 @@ def searchPack (R r V : List Bool) : List Bool := pair R (pair r V) /-- One step of the worklist search, on the packed state. -/ noncomputable def searchStep (tm : NTM k) (m : ℕ) (z : List Bool) : List Bool := - pair (fstBlock z) - (pair (false :: fstBlock (sndBlock z)) + pair (pairFst z) + (pair (false :: pairFst (pairSnd z)) (selectHead - (lenLeFlag (sndBlock (sndBlock z)) - (guardRuler m (fstBlock z) (fstBlock (sndBlock z)))) - (searchBody tm m (fstBlock z) (fstBlock (sndBlock z)) (sndBlock (sndBlock z))) - (sndBlock (sndBlock z)))) + (lenLeFlag (pairSnd (pairSnd z)) + (guardRuler m (pairFst z) (pairFst (pairSnd z)))) + (searchBody tm m (pairFst z) (pairFst (pairSnd z)) (pairSnd (pairSnd z))) + (pairSnd (pairSnd z)))) /-- **The packed step is the unpacked step.** -/ theorem searchStep_pack (tm : NTM k) (m : ℕ) (R r V : List Bool) : searchStep tm m (searchPack R r V) = searchPack R (searchStepPair tm m R (r, V)).1 (searchStepPair tm m R (r, V)).2 := by rw [searchStep, searchPack, searchStepPair] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] by_cases hle : (guardRuler m R r).length ≤ V.length · rw [if_pos hle, selectHead, if_pos (by rw [(Cobham.lenLeFlag_eq_true_iff V (guardRuler m R r)).mpr hle]; rfl)] @@ -212,12 +212,12 @@ theorem searchStep_iterate (tm : NTM k) (m : ℕ) (R : List Bool) theorem searchStep_mem_FP (tm : NTM k) (m : ℕ) : searchStep tm m ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -225,7 +225,7 @@ theorem searchStep_mem_FP (tm : NTM k) (m : ℕ) : searchStep tm m ∈ FP := by have hw := hsnd hid have hr := hfst hw have hV := hsnd hw - have hcons : (fun z => false :: fstBlock (sndBlock z)) ∈ FP := by + have hcons : (fun z => false :: pairFst (pairSnd z)) ∈ FP := by have := mem_FP_comp hr (Cobham.cons_mem_FP false) simpa [Function.comp] using this exact Cobham.pairFn_mem_FP hR (Cobham.pairFn_mem_FP hcons diff --git a/Complexitylib/Classes/Containments/Internal/CodeRewind.lean b/Complexitylib/Classes/Containments/Internal/CodeRewind.lean index dbc2a938..97f99648 100644 --- a/Complexitylib/Classes/Containments/Internal/CodeRewind.lean +++ b/Complexitylib/Classes/Containments/Internal/CodeRewind.lean @@ -77,11 +77,11 @@ theorem outPair_cfgCode {Q : Type} [Fintype Q] [DecidableEq Q] (W : ℕ) (c : Cf /-- One rewind step, on the packed state `pair R z`. -/ def rewindStepP (z : List Bool) : List Bool := - pair (fstBlock z) (rewindFn (fstBlock z) (sndBlock z)) + pair (pairFst z) (rewindFn (pairFst z) (pairSnd z)) theorem rewindStepP_pack (R z : List Bool) : rewindStepP (pair R z) = pair R (rewindFn R z) := by - rw [rewindStepP, fstBlock_pair, sndBlock_pair] + rw [rewindStepP, pairFst_pair, pairSnd_pair] theorem rewindStepP_iterate (R z : List Bool) (n : ℕ) : rewindStepP^[n] (pair R z) = pair R ((rewindFn R)^[n] z) := by @@ -92,11 +92,11 @@ theorem rewindStepP_iterate (R z : List Bool) (n : ℕ) : /-- A whole rewind: one step per bit of the ruler. -/ def rewindCode (R ruler z : List Bool) : List Bool := - sndBlock (rewindStepP^[ruler.length] (pair R z)) + pairSnd (rewindStepP^[ruler.length] (pair R z)) theorem rewindCode_eq (R ruler z : List Bool) : rewindCode R ruler z = (rewindFn R)^[ruler.length] z := by - rw [rewindCode, rewindStepP_iterate, sndBlock_pair] + rw [rewindCode, rewindStepP_iterate, pairSnd_pair] /-- **A long enough rewind parks the head at cell `0`.** -/ theorem rewindCode_pairCode (W : ℕ) (t : Tape) (hinv : t.StartInvariant) @@ -114,8 +114,8 @@ theorem rewindFnFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : theorem rewindStepP_mem_FP : rewindStepP ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) - have hfst : (fun z => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hsnd : (fun z => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hfst : (fun z => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP exact Cobham.pairFn_mem_FP hfst (rewindFnFn_mem_FP hfst hsnd) /-- **The rewind is polynomial-time.** -/ diff --git a/Complexitylib/Classes/Containments/Internal/FPBridge.lean b/Complexitylib/Classes/Containments/Internal/FPBridge.lean index 1f5ae2df..3ca771eb 100644 --- a/Complexitylib/Classes/Containments/Internal/FPBridge.lean +++ b/Complexitylib/Classes/Containments/Internal/FPBridge.lean @@ -44,12 +44,12 @@ namespace Cobham /-- The first pair decoder is in the algebra, being polynomial-time. -/ theorem fstBlockFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : - Cobham fun v : Fin n → List Bool => fstBlock (g v) := + Cobham fun v : Fin n → List Bool => pairFst (g v) := (Cobham.comp (FP_subset_CobhamFP fstBlock_mem_FP) fun _ : Fin 1 => hg).of_eq fun _ => rfl /-- The second pair decoder is in the algebra. -/ theorem sndBlockFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : - Cobham fun v : Fin n → List Bool => sndBlock (g v) := + Cobham fun v : Fin n → List Bool => pairSnd (g v) := (Cobham.comp (FP_subset_CobhamFP sndBlock_mem_FP) fun _ : Fin 1 => hg).of_eq fun _ => rfl end Cobham @@ -80,13 +80,13 @@ theorem binFn_mem_FP {g : List Bool → List Bool → List Bool} {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : (fun z => g (a z) (b z)) ∈ FP := by have hpacked : Cobham fun v : Fin 1 → List Bool => - g (Cobham.fstBlock (v 0)) (Cobham.sndBlock (v 0)) := + g (pairFst (v 0)) (pairSnd (v 0)) := (Cobham.comp₂ hg (Cobham.fstBlockFn (Cobham.proj 0)) (Cobham.sndBlockFn (Cobham.proj 0))).of_eq fun _ => rfl - have hfp : (fun w => g (Cobham.fstBlock w) (Cobham.sndBlock w)) ∈ FP := + have hfp : (fun w => g (pairFst w) (pairSnd w)) ∈ FP := CobhamFP_subset_FP hpacked have h := mem_FP_comp (Cobham.pairFn_mem_FP ha hb) hfp - have heq : ((fun w => g (Cobham.fstBlock w) (Cobham.sndBlock w)) ∘ fun z => pair (a z) (b z)) + have heq : ((fun w => g (pairFst w) (pairSnd w)) ∘ fun z => pair (a z) (b z)) = fun z => g (a z) (b z) := by funext z simp [Function.comp] diff --git a/Complexitylib/Classes/Containments/Internal/IPAssemble.lean b/Complexitylib/Classes/Containments/Internal/IPAssemble.lean index 0f814d4d..7e66d023 100644 --- a/Complexitylib/Classes/Containments/Internal/IPAssemble.lean +++ b/Complexitylib/Classes/Containments/Internal/IPAssemble.lean @@ -41,17 +41,17 @@ the input the second, so the very first call — on `pair [] x` — builds the i noncomputable def ipG (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Polynomial ℕ) (z : List Bool) : List Bool := pair - (selectHead (emptyFlag (fstBlock z)) - (IPM.ipInit (polyRuler cp (sndBlock z)) (polyRuler rp (sndBlock z))) - (IPM.ipStep (polyRuler mp (sndBlock z)) (polyRuler cp (sndBlock z)) - (okFn prot.vmsg vd (polyRuler rp (sndBlock z)) (sndBlock z)) (fstBlock z))) - (sndBlock z) + (selectHead (emptyFlag (pairFst z)) + (IPM.ipInit (polyRuler cp (pairSnd z)) (polyRuler rp (pairSnd z))) + (IPM.ipStep (polyRuler mp (pairSnd z)) (polyRuler cp (pairSnd z)) + (okFn prot.vmsg vd (polyRuler rp (pairSnd z)) (pairSnd z)) (pairFst z))) + (pairSnd z) theorem ipG_nil (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Polynomial ℕ) (x : List Bool) : ipG prot vd rp cp mp (pair [] x) = pair (IPM.ipInit (polyRuler cp x) (polyRuler rp x)) x := by - rw [ipG, fstBlock_pair, sndBlock_pair, emptyFlag_nil, selectHead_cons_true] + rw [ipG, pairFst_pair, pairSnd_pair, emptyFlag_nil, selectHead_cons_true] theorem ipG_step (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Polynomial ℕ) (st x : List Bool) (h : st ≠ []) : @@ -62,7 +62,7 @@ theorem ipG_step (prot : Protocol) (vd : List Bool → List Bool) (rp cp mp : Po cases st with | nil => exact absurd rfl h | cons b t => exact ⟨b, t, rfl⟩ - rw [ipG, fstBlock_pair, sndBlock_pair, emptyFlag_cons, selectHead_cons_false] + rw [ipG, pairFst_pair, pairSnd_pair, emptyFlag_cons, selectHead_cons_false] /-! ## The orbit -/ @@ -178,11 +178,11 @@ theorem ip_mem_PSPACE (prot : Protocol) {L : Language} (rp cp mp r w : Polynomia classical obtain ⟨vd, hvdFP, hvd⟩ := exists_verdictFlag prot have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) - have hfst : (fun z : List Bool => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP - have hcr : (fun z => polyRuler cp (sndBlock z)) ∈ FP := polyRulerFn_mem_FP cp hsnd - have hmr : (fun z => polyRuler mp (sndBlock z)) ∈ FP := polyRulerFn_mem_FP mp hsnd - have hrr : (fun z => polyRuler rp (sndBlock z)) ∈ FP := polyRulerFn_mem_FP rp hsnd + have hfst : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP + have hcr : (fun z => polyRuler cp (pairSnd z)) ∈ FP := polyRulerFn_mem_FP cp hsnd + have hmr : (fun z => polyRuler mp (pairSnd z)) ∈ FP := polyRulerFn_mem_FP mp hsnd + have hrr : (fun z => polyRuler rp (pairSnd z)) ∈ FP := polyRulerFn_mem_FP rp hsnd have hGfp : ipG prot vd rp cp mp ∈ FP := by refine Cobham.pairFn_mem_FP (Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hfst) (IPM.ipInitFn_mem_FP hcr hrr) ?_) hsnd diff --git a/Complexitylib/Classes/Containments/Internal/IPLeaf.lean b/Complexitylib/Classes/Containments/Internal/IPLeaf.lean index 284f1183..5754fa28 100644 --- a/Complexitylib/Classes/Containments/Internal/IPLeaf.lean +++ b/Complexitylib/Classes/Containments/Internal/IPLeaf.lean @@ -125,8 +125,8 @@ def chkStep (vf : List Bool → List Bool) : List Bool × List Bool × List Bool → List Bool × List Bool × List Bool := fun s => (s.1, - selectHead (emptyFlag s.2.2) s.2.1 (andBit s.2.1 (chkOneP vf s.1 (fstBlock s.2.2))), - selectHead (emptyFlag s.2.2) s.2.2 (sndBlock s.2.2)) + selectHead (emptyFlag s.2.2) s.2.1 (andBit s.2.1 (chkOneP vf s.1 (pairFst s.2.2))), + selectHead (emptyFlag s.2.2) s.2.2 (pairSnd s.2.2)) @[simp] theorem chkStep_nil (vf : List Bool → List Bool) (xu acc : List Bool) : chkStep vf (xu, acc, []) = (xu, acc, []) := by @@ -138,7 +138,7 @@ theorem chkStep_cons (vf : List Bool → List Bool) (xu acc : List Bool) (g : IP chkStep vf (xu, acc, IPM.encStk (g :: gs)) = (xu, andBit acc (chkOneP vf xu (IPM.encFrm g)), IPM.encStk gs) := by rw [chkStep, IPM.encStk_cons] - simp only [emptyFlag_pair, selectHead_cons_false, fstBlock_pair, sndBlock_pair] + simp only [emptyFlag_pair, selectHead_cons_false, pairFst_pair, pairSnd_pair] /-- The running flag after folding in a list of frames. -/ def chkFold (vf : List Bool → List Bool) (xu : List Bool) : @@ -178,12 +178,12 @@ theorem chkStep_iterate (vf : List Bool → List Bool) (xu : List Bool) : /-! ## The packed scan -/ -theorem sndBlock_length_le (z : List Bool) : (sndBlock z).length ≤ z.length := by +theorem sndBlock_length_le (z : List Bool) : (pairSnd z).length ≤ z.length := by rcases hu : unpair? z with _ | ⟨p, q⟩ - · rw [show sndBlock z = [] from by rw [sndBlock, hu]] + · rw [show pairSnd z = [] from by rw [pairSnd, hu]] simp · have hz : z = pair p q := unpair?_eq_some_iff.mp hu - rw [show sndBlock z = q from by rw [sndBlock, hu], hz, pair_length] + rw [show pairSnd z = q from by rw [pairSnd, hu], hz, pair_length] omega /-- The packed scan state: the verifier's fixed arguments, the running flag, and the chain of @@ -197,20 +197,20 @@ def chkPack (xu acc S : List Bool) : List Bool := pair xu (pair acc S) /-- One step of the packed scan. -/ def chkStepP (vf : List Bool → List Bool) (z : List Bool) : List Bool := - pair (fstBlock z) + pair (pairFst z) (pair - (selectHead (emptyFlag (sndBlock (sndBlock z))) (fstBlock (sndBlock z)) - (andBit (fstBlock (sndBlock z)) - (chkOneP vf (fstBlock z) (fstBlock (sndBlock (sndBlock z)))))) - (selectHead (emptyFlag (sndBlock (sndBlock z))) (sndBlock (sndBlock z)) - (sndBlock (sndBlock (sndBlock z))))) + (selectHead (emptyFlag (pairSnd (pairSnd z))) (pairFst (pairSnd z)) + (andBit (pairFst (pairSnd z)) + (chkOneP vf (pairFst z) (pairFst (pairSnd (pairSnd z)))))) + (selectHead (emptyFlag (pairSnd (pairSnd z))) (pairSnd (pairSnd z)) + (pairSnd (pairSnd (pairSnd z))))) theorem chkStepP_pack (vf : List Bool → List Bool) (xu acc S : List Bool) : chkStepP vf (chkPack xu acc S) = chkPack (chkStep vf (xu, acc, S)).1 (chkStep vf (xu, acc, S)).2.1 (chkStep vf (xu, acc, S)).2.2 := by rw [chkStepP, chkPack, chkStep, chkPack] - simp only [fstBlock_pair, sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] theorem chkStepP_iterate (vf : List Bool → List Bool) (s : List Bool × List Bool × List Bool) (n : ℕ) : @@ -237,7 +237,7 @@ theorem chkStep_iterate_length (vf : List Bool → List Bool) (xu acc S : List B | succ n ih => rw [Function.iterate_succ_apply] have hacc : (selectHead (emptyFlag S) acc - (andBit acc (chkOneP vf xu (fstBlock S)))).length ≤ max acc.length 1 := by + (andBit acc (chkOneP vf xu (pairFst S)))).length ≤ max acc.length 1 := by rw [selectHead] split · exact le_max_left _ _ @@ -245,7 +245,7 @@ theorem chkStep_iterate_length (vf : List Bool → List Bool) (xu acc S : List B · rw [andBit_length_eq] exact le_max_right _ _ · simp - have hS : (selectHead (emptyFlag S) S (sndBlock S)).length ≤ S.length := by + have hS : (selectHead (emptyFlag S) S (pairSnd S)).length ≤ S.length := by rw [selectHead] split · exact le_rfl @@ -253,8 +253,8 @@ theorem chkStep_iterate_length (vf : List Bool → List Bool) (xu acc S : List B · exact sndBlock_length_le S · simp obtain ⟨h1, h2, h3⟩ := ih (selectHead (emptyFlag S) acc - (andBit acc (chkOneP vf xu (fstBlock S)))) - (selectHead (emptyFlag S) S (sndBlock S)) + (andBit acc (chkOneP vf xu (pairFst S)))) + (selectHead (emptyFlag S) S (pairSnd S)) refine ⟨h1, le_trans h2 ?_, le_trans h3 hS⟩ have hchain := max_le_max_right (α := ℕ) 1 hacc omega @@ -263,19 +263,19 @@ theorem chkStep_iterate_length (vf : List Bool → List Bool) (xu acc S : List B /-- The consistency flag, computed by running the scan against a ruler. -/ def chkFlag (vf : List Bool → List Bool) (rr xu S : List Bool) : List Bool := - fstBlock (sndBlock ((chkStepP vf)^[rr.length] (chkPack xu [true] S))) + pairFst (pairSnd ((chkStepP vf)^[rr.length] (chkPack xu [true] S))) theorem chkFlag_eq (vf : List Bool → List Bool) (rr : List Bool) (x u : List Bool) (fs : List IPM.Frm) (h : fs.length ≤ rr.length) : chkFlag vf rr (pair x u) (IPM.encStk fs) = [stkCheckB vf x u fs] := by rw [chkFlag, chkStepP_iterate_args, chkStep_iterate vf _ fs [true] rr.length h, chkPack] - simp only [sndBlock_pair, fstBlock_pair] + simp only [pairSnd_pair, pairFst_pair] rw [chkFold_flag vf x u fs true, Bool.true_and] /-- **The leaf test on the tape**: the transcript replays, and the verifier accepts. -/ def okFn (vf vd : List Bool → List Bool) (rr x S u : List Bool) : List Bool := - andBit (chkFlag vf rr (pair x u) (sndBlock S)) - (vd (pair (pair x u) (false :: IPM.fBody (fstBlock S) ++ [true]))) + andBit (chkFlag vf rr (pair x u) (pairSnd S)) + (vd (pair (pair x u) (false :: IPM.fBody (pairFst S) ++ [true]))) open Classical in /-- **The leaf test computes what the walk asks for.** -/ @@ -286,7 +286,7 @@ theorem okFn_eq (prot : Protocol) (vd : List Bool → List Bool) okFn prot.vmsg vd rr x (IPM.encStk (f :: fs)) u = [(prot.walkParams x).ok (IPM.roundsOf fs) u] := by classical - rw [okFn, IPM.encStk_cons, sndBlock_pair, fstBlock_pair, + rw [okFn, IPM.encStk_cons, pairSnd_pair, pairFst_pair, chkFlag_eq prot.vmsg rr x u fs hlen, IPM.fBody_enc, hvd, andBit_cons, hb.1, ← replay_eq_stkCheckB prot x u fs hb.2] show _ = [decide (prot.replay x u (IPM.roundsOf fs) [] = true ∧ @@ -298,11 +298,11 @@ theorem okFn_eq (prot : Protocol) (vd : List Bool → List Bool) theorem chkOnePFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) {XU Y : List Bool → List Bool} (hxu : XU ∈ FP) (hy : Y ∈ FP) : (fun z => chkOneP vf (XU z) (Y z)) ∈ FP := by - have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this - have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -319,11 +319,11 @@ theorem chkOnePFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) theorem chkStepPFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) : chkStepP vf ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) - have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this - have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -362,23 +362,23 @@ theorem chkFlagFn_mem_FP {vf : List Bool → List Bool} (hvf : vf ∈ FP) theorem okFnFn_mem_FP {vf vd : List Bool → List Bool} (hvf : vf ∈ FP) (hvd : vd ∈ FP) {R X S U : List Bool → List Bool} (hR : R ∈ FP) (hX : X ∈ FP) (hS : S ∈ FP) (hU : U ∈ FP) : (fun z => okFn vf vd (R z) (X z) (S z) (U z)) ∈ FP := by - have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this - have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hxu : (fun z => pair (X z) (U z)) ∈ FP := Cobham.pairFn_mem_FP hX hU - have hBody : (fun z => IPM.fBody (fstBlock (S z))) ∈ FP := + have hBody : (fun z => IPM.fBody (pairFst (S z))) ∈ FP := hsnd (hsnd (hsnd (hsnd (hsnd (hfst hS))))) - have hcons : (fun z => false :: (IPM.fBody (fstBlock (S z)) ++ [true])) ∈ FP := by + have hcons : (fun z => false :: (IPM.fBody (pairFst (S z)) ++ [true])) ∈ FP := by have hcat := Cobham.appendFn_mem_FP hBody (constFn_mem_FP [true]) have := mem_FP_comp hcat (Cobham.cons_mem_FP false) simpa [Function.comp] using this have hverd : (fun z => vd (pair (pair (X z) (U z)) - (false :: (IPM.fBody (fstBlock (S z)) ++ [true])))) ∈ FP := by + (false :: (IPM.fBody (pairFst (S z)) ++ [true])))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hxu hcons) hvd simpa [Function.comp] using this exact andBitFn_mem_FP (chkFlagFn_mem_FP hvf hR hxu (hsnd hS)) hverd diff --git a/Complexitylib/Classes/Containments/Internal/IPStep.lean b/Complexitylib/Classes/Containments/Internal/IPStep.lean index 1b509ffb..2e0c48f3 100644 --- a/Complexitylib/Classes/Containments/Internal/IPStep.lean +++ b/Complexitylib/Classes/Containments/Internal/IPStep.lean @@ -53,76 +53,76 @@ def mkF (lvl v a sum best body : List Bool) : List Bool := @[simp] theorem mkF_eq (f : Frm) : mkF f.lvl f.v f.a f.sum f.best f.body = encFrm f := rfl /-- The done flag. -/ -def sDone (z : List Bool) : List Bool := fstBlock z +def sDone (z : List Bool) : List Bool := pairFst z /-- The answer bit. -/ -def sAns (z : List Bool) : List Bool := fstBlock (sndBlock z) +def sAns (z : List Bool) : List Bool := pairFst (pairSnd z) /-- The returning value. -/ -def sRet (z : List Bool) : List Bool := fstBlock (sndBlock (sndBlock z)) +def sRet (z : List Bool) : List Bool := pairFst (pairSnd (pairSnd z)) /-- The stack. -/ -def sStk (z : List Bool) : List Bool := sndBlock (sndBlock (sndBlock z)) +def sStk (z : List Bool) : List Bool := pairSnd (pairSnd (pairSnd z)) /-- A frame's level. -/ -def fLvl (y : List Bool) : List Bool := fstBlock y +def fLvl (y : List Bool) : List Bool := pairFst y /-- A frame's verifier counter. -/ -def fV (y : List Bool) : List Bool := fstBlock (sndBlock y) +def fV (y : List Bool) : List Bool := pairFst (pairSnd y) /-- A frame's prover counter, or its coin counter. -/ -def fA (y : List Bool) : List Bool := fstBlock (sndBlock (sndBlock y)) +def fA (y : List Bool) : List Bool := pairFst (pairSnd (pairSnd y)) /-- A frame's running sum. -/ -def fSum (y : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock y))) +def fSum (y : List Bool) : List Bool := pairFst (pairSnd (pairSnd (pairSnd y))) /-- A frame's running maximum. -/ -def fBest (y : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock (sndBlock y)))) +def fBest (y : List Bool) : List Bool := pairFst (pairSnd (pairSnd (pairSnd (pairSnd y)))) /-- The body of the encoding of the rounds below a frame. -/ -def fBody (y : List Bool) : List Bool := sndBlock (sndBlock (sndBlock (sndBlock (sndBlock y)))) +def fBody (y : List Bool) : List Bool := pairSnd (pairSnd (pairSnd (pairSnd (pairSnd y)))) /-- The frame on top of the stack. -/ -def sTop (S : List Bool) : List Bool := fstBlock S +def sTop (S : List Bool) : List Bool := pairFst S /-- The stack below the top frame. -/ -def sRest (S : List Bool) : List Bool := sndBlock S +def sRest (S : List Bool) : List Bool := pairSnd S @[simp] theorem sDone_enc (s : Sst) : sDone (encSst s) = [s.done] := by - rw [sDone, encSst, fstBlock_pair] + rw [sDone, encSst, pairFst_pair] @[simp] theorem sAns_enc (s : Sst) : sAns (encSst s) = [s.ansBit] := by - rw [sAns, encSst, sndBlock_pair, fstBlock_pair] + rw [sAns, encSst, pairSnd_pair, pairFst_pair] @[simp] theorem sRet_enc (s : Sst) : sRet (encSst s) = encRet s.ret := by - rw [sRet, encSst, sndBlock_pair, sndBlock_pair, fstBlock_pair] + rw [sRet, encSst, pairSnd_pair, pairSnd_pair, pairFst_pair] @[simp] theorem sStk_enc (s : Sst) : sStk (encSst s) = encStk s.stk := by - rw [sStk, encSst, sndBlock_pair, sndBlock_pair, sndBlock_pair] + rw [sStk, encSst, pairSnd_pair, pairSnd_pair, pairSnd_pair] @[simp] theorem fLvl_enc (f : Frm) : fLvl (encFrm f) = f.lvl := by - rw [fLvl, encFrm, fstBlock_pair] + rw [fLvl, encFrm, pairFst_pair] @[simp] theorem fV_enc (f : Frm) : fV (encFrm f) = f.v := by - rw [fV, encFrm, sndBlock_pair, fstBlock_pair] + rw [fV, encFrm, pairSnd_pair, pairFst_pair] @[simp] theorem fA_enc (f : Frm) : fA (encFrm f) = f.a := by - rw [fA, encFrm, sndBlock_pair, sndBlock_pair, fstBlock_pair] + rw [fA, encFrm, pairSnd_pair, pairSnd_pair, pairFst_pair] @[simp] theorem fSum_enc (f : Frm) : fSum (encFrm f) = f.sum := by - rw [fSum, encFrm, sndBlock_pair, sndBlock_pair, sndBlock_pair, fstBlock_pair] + rw [fSum, encFrm, pairSnd_pair, pairSnd_pair, pairSnd_pair, pairFst_pair] @[simp] theorem fBest_enc (f : Frm) : fBest (encFrm f) = f.best := by - rw [fBest, encFrm, sndBlock_pair, sndBlock_pair, sndBlock_pair, sndBlock_pair, fstBlock_pair] + rw [fBest, encFrm, pairSnd_pair, pairSnd_pair, pairSnd_pair, pairSnd_pair, pairFst_pair] @[simp] theorem fBody_enc (f : Frm) : fBody (encFrm f) = f.body := by - rw [fBody, encFrm, sndBlock_pair, sndBlock_pair, sndBlock_pair, sndBlock_pair, sndBlock_pair] + rw [fBody, encFrm, pairSnd_pair, pairSnd_pair, pairSnd_pair, pairSnd_pair, pairSnd_pair] @[simp] theorem sTop_pair (y S : List Bool) : sTop (pair y S) = y := by - rw [sTop, fstBlock_pair] + rw [sTop, pairFst_pair] @[simp] theorem sRest_pair (y S : List Bool) : sRest (pair y S) = S := by - rw [sRest, sndBlock_pair] + rw [sRest, pairSnd_pair] theorem sTop_cons (f : Frm) (fs : List Frm) : sTop (encStk (f :: fs)) = encFrm f := by rw [encStk_cons, sTop_pair] @@ -377,11 +377,11 @@ theorem ipStepFn_mem_FP {A B C : List Bool → List Bool} (hok : ∀ {u v : List Bool → List Bool}, u ∈ FP → v ∈ FP → (fun z => OK z (u z) (v z)) ∈ FP) : (fun z => ipStep (A z) (B z) (OK z) (C z)) ∈ FP := by - have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => fstBlock (a z)) ∈ FP := by + have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this - have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => sndBlock (a z)) ∈ FP := by + have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this diff --git a/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean b/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean index dda47da7..646e417f 100644 --- a/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean +++ b/Complexitylib/Classes/Containments/Internal/NLSearchAssemble.lean @@ -207,11 +207,11 @@ theorem searchRun_eq (tm : NTM k) (R V₀ ruler : List Bool) : /-- The visited string a search leaves behind. -/ noncomputable def searchVisited (tm : NTM k) (R V₀ ruler : List Bool) : List Bool := - sndBlock (sndBlock (searchRun tm R V₀ ruler)) + pairSnd (pairSnd (searchRun tm R V₀ ruler)) theorem searchVisited_eq (tm : NTM k) (R V₀ ruler : List Bool) : searchVisited tm R V₀ ruler = (searchState tm R V₀ ruler.length).2 := by - rw [searchVisited, searchRun_eq, searchPack, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + rw [searchVisited, searchRun_eq, searchPack, pairSnd_pair, pairSnd_pair] /-- **The search is polynomial-time**, given a polynomial bound on its state. -/ theorem searchVisitedFn_mem_FP (tm : NTM k) diff --git a/Complexitylib/Classes/Containments/Internal/PVerdict.lean b/Complexitylib/Classes/Containments/Internal/PVerdict.lean index cfe74031..089cd817 100644 --- a/Complexitylib/Classes/Containments/Internal/PVerdict.lean +++ b/Complexitylib/Classes/Containments/Internal/PVerdict.lean @@ -151,11 +151,11 @@ end TM /-- The encoded step, carrying its ruler alongside the code. -/ noncomputable def codeStep (tm : TM k) (w : List Bool) : List Bool := - pair (fstBlock w) (stepFn tm (fstBlock w) (sndBlock w)) + pair (pairFst w) (stepFn tm (pairFst w) (pairSnd w)) theorem codeStep_pair (tm : TM k) (R z : List Bool) : codeStep tm (pair R z) = pair R (stepFn tm R z) := by - rw [codeStep, fstBlock_pair, sndBlock_pair] + rw [codeStep, pairFst_pair, pairSnd_pair] theorem codeStep_iterate (tm : TM k) (R z : List Bool) : ∀ n, (codeStep tm)^[n] (pair R z) = pair R ((stepFn tm R)^[n] z) := by @@ -166,9 +166,9 @@ theorem codeStep_iterate (tm : TM k) (R z : List Bool) : rw [Function.iterate_succ_apply, codeStep_pair, ih, Function.iterate_succ_apply] theorem codeStep_mem_FP (tm : TM k) : codeStep tm ∈ FP := by - have hfst : (fun z : List Bool => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP - have hstep : (fun w => stepFn tm (fstBlock w) (sndBlock w)) ∈ FP := + have hfst : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP + have hstep : (fun w => stepFn tm (pairFst w) (pairSnd w)) ∈ FP := binFn_mem_FP (g := stepFn tm) (Cobham.stepFn_mem tm (Cobham.proj 0) (Cobham.proj 1)) hfst hsnd exact Cobham.pairFn_mem_FP hfst hstep @@ -234,7 +234,7 @@ theorem acceptFlag_cfgCode_tm (tm : TM k) (W : ℕ) (c : Cfg k tm.Q) noncomputable def pVerdict (tm : TM k) (wp tp : Polynomial ℕ) (x : List Bool) : List Bool := acceptFlag (stateCode tm.qhalt) (polyRuler (2 * wp + 2) x) (wideRuler (codeBlocks k) (polyRuler (2 * wp + 2) x)) - (sndBlock ((codeStep tm)^[(polyRuler tp x).length] + (pairSnd ((codeStep tm)^[(polyRuler tp x).length] (pair (polyRuler (2 * wp + 2) x) (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x)))) @@ -261,10 +261,10 @@ theorem pVerdict_eq_true_iff (tm : TM k) {L : Language} (wp tp : Polynomial ℕ) obtain ⟨c, t, htT, hreach, hhalt, hone, hzero⟩ := hdec x have hrun : tm.runTo x (tp.eval x.length) = c := TM.runTo_of_halted tm x hreach hhalt (by simpa using htT) - have hcode : sndBlock ((codeStep tm)^[(polyRuler tp x).length] + have hcode : pairSnd ((codeStep tm)^[(polyRuler tp x).length] (pair (polyRuler (2 * wp + 2) x) (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x))) = Cobham.cfgCode W c := by - rw [codeStep_iterate, sndBlock_pair, polyRuler_length, hR, + rw [codeStep_iterate, pairSnd_pair, polyRuler_length, hR, runCode_eq tm W (hq x.length) x hxW _ (by omega), hrun] rw [pVerdict, hcode, hR, acceptFlag_cfgCode_tm tm W c (hq x.length) @@ -331,7 +331,7 @@ theorem pVerdict_mem_FP (tm : TM k) (wp tp : Polynomial ℕ) rw [hRlen x] at this omega have hiter := Cobham.iterate_mem_FP (codeStep_mem_FP tm) hinit hruler hwidth hbound - have hcode : (fun x => sndBlock ((codeStep tm)^[(polyRuler tp x).length] + have hcode : (fun x => pairSnd ((codeStep tm)^[(polyRuler tp x).length] (pair (polyRuler (2 * wp + 2) x) (Cobham.initFn tm (polyRuler (2 * wp + 2) x) x)))) ∈ FP := by have := mem_FP_comp hiter Cobham.sndBlock_mem_FP diff --git a/Complexitylib/Classes/Containments/Internal/SavitchBits.lean b/Complexitylib/Classes/Containments/Internal/SavitchBits.lean index 4d59e5d3..e3efa2a0 100644 --- a/Complexitylib/Classes/Containments/Internal/SavitchBits.lean +++ b/Complexitylib/Classes/Containments/Internal/SavitchBits.lean @@ -208,12 +208,12 @@ def bumpPack (c acc rest : List Bool) : List Bool := pair c (pair acc rest) /-- One step of the packed scan. -/ def bumpStepP (z : List Bool) : List Bool := - selectHead (lenLeFlag (sndBlock (sndBlock z)) [false]) - (pair (andBit (fstBlock z) ((sndBlock (sndBlock z)).take 1)) - (pair (fstBlock (sndBlock z) ++ - selectHead (fstBlock z) (notBit ((sndBlock (sndBlock z)).take 1)) - ((sndBlock (sndBlock z)).take 1)) - ((sndBlock (sndBlock z)).drop 1))) + selectHead (lenLeFlag (pairSnd (pairSnd z)) [false]) + (pair (andBit (pairFst z) ((pairSnd (pairSnd z)).take 1)) + (pair (pairFst (pairSnd z) ++ + selectHead (pairFst z) (notBit ((pairSnd (pairSnd z)).take 1)) + ((pairSnd (pairSnd z)).take 1)) + ((pairSnd (pairSnd z)).drop 1))) z /-- **The packed step is the unpacked step.** -/ @@ -222,7 +222,7 @@ theorem bumpStepP_pack (c acc rest : List Bool) : = bumpPack (bumpStep (c, acc, rest)).1 (bumpStep (c, acc, rest)).2.1 (bumpStep (c, acc, rest)).2.2 := by rw [bumpStepP, bumpPack] - simp only [fstBlock_pair, sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] cases rest with | nil => rw [selectHead] @@ -260,10 +260,10 @@ theorem bumpStepP_iterate_args (c acc rest : List Bool) (n : ℕ) : def bumpRun (w : List Bool) : List Bool := bumpStepP^[w.length] (bumpPack [true] [] w) /-- The increment of `w`, computed by the scan. -/ -def bumpCode (w : List Bool) : List Bool := fstBlock (sndBlock (bumpRun w)) +def bumpCode (w : List Bool) : List Bool := pairFst (pairSnd (bumpRun w)) /-- The carry out of the increment, as a flag. -/ -def bumpFlag (w : List Bool) : List Bool := fstBlock (bumpRun w) +def bumpFlag (w : List Bool) : List Bool := pairFst (bumpRun w) theorem bumpRun_eq (w : List Bool) : bumpRun w = bumpPack [bumpOver w] (bumpBits w) [] := by @@ -283,12 +283,12 @@ theorem bumpRun_eq (w : List Bool) : theorem bumpStepP_mem_FP : bumpStepP ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this have hsnd : ∀ {a : List Bool → List Bool}, a ∈ FP → - (fun z => sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by intro a ha have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this @@ -297,14 +297,14 @@ theorem bumpStepP_mem_FP : bumpStepP ∈ FP := by have hrest := hsnd hw have hacc := hfst hw have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] - have htake : (fun z => (sndBlock (sndBlock z)).take 1) ∈ FP := by + have htake : (fun z => (pairSnd (pairSnd z)).take 1) ∈ FP := by have := Cobham.takeLenFn_mem_FP hone hrest simpa using this - have hdrop : (fun z => (sndBlock (sndBlock z)).drop 1) ∈ FP := by + have hdrop : (fun z => (pairSnd (pairSnd z)).drop 1) ∈ FP := by have := dropLenFn_mem_FP hone hrest simpa using this - have hbit : (fun z => selectHead (fstBlock z) - (notBit ((sndBlock (sndBlock z)).take 1)) ((sndBlock (sndBlock z)).take 1)) ∈ FP := + have hbit : (fun z => selectHead (pairFst z) + (notBit ((pairSnd (pairSnd z)).take 1)) ((pairSnd (pairSnd z)).take 1)) ∈ FP := Cobham.selectHeadFn_mem_FP hc (notBitFn_mem_FP htake) htake exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hrest hone) (Cobham.pairFn_mem_FP (andBitFn_mem_FP hc htake) diff --git a/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean b/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean index 7b976488..f2714c32 100644 --- a/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean +++ b/Complexitylib/Classes/Containments/Internal/SavitchFrame.lean @@ -59,24 +59,24 @@ def mkFrame (kind ph lvl u v m : List Bool) : List Bool := pair kind (pair ph (pair lvl (pair u (pair v m)))) /-- Which subproblem the frame is working on. -/ -def frKind (f : List Bool) : List Bool := fstBlock f +def frKind (f : List Bool) : List Bool := pairFst f /-- Which half of the interval the frame is trying. -/ -def frPh (f : List Bool) : List Bool := fstBlock (sndBlock f) +def frPh (f : List Bool) : List Bool := pairFst (pairSnd f) /-- The frame's level, in unary. -/ -def frLvl (f : List Bool) : List Bool := fstBlock (sndBlock (sndBlock f)) +def frLvl (f : List Bool) : List Bool := pairFst (pairSnd (pairSnd f)) /-- The frame's source endpoint. -/ -def frU (f : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock f))) +def frU (f : List Bool) : List Bool := pairFst (pairSnd (pairSnd (pairSnd f))) /-- The frame's target endpoint. -/ def frV (f : List Bool) : List Bool := - fstBlock (sndBlock (sndBlock (sndBlock (sndBlock f)))) + pairFst (pairSnd (pairSnd (pairSnd (pairSnd f)))) /-- The midpoint the frame is trying. -/ def frM (f : List Bool) : List Bool := - sndBlock (sndBlock (sndBlock (sndBlock (sndBlock f)))) + pairSnd (pairSnd (pairSnd (pairSnd (pairSnd f)))) @[simp] theorem frKind_mk (kind ph lvl u v m : List Bool) : frKind (mkFrame kind ph lvl u v m) = kind := by simp [frKind, mkFrame] @@ -116,10 +116,10 @@ def encStack : List (List Bool) → List Bool encStack (f :: fs) = pair f (encStack fs) := rfl /-- The frame on top of the stack. -/ -def stkTop (S : List Bool) : List Bool := fstBlock S +def stkTop (S : List Bool) : List Bool := pairFst S /-- The stack below the top frame. -/ -def stkRest (S : List Bool) : List Bool := sndBlock S +def stkRest (S : List Bool) : List Bool := pairSnd S @[simp] theorem stkTop_pair (f g : List Bool) : stkTop (pair f g) = f := by simp [stkTop] @@ -157,19 +157,19 @@ def mkSt (d a R ret stk : List Bool) : List Bool := pair d (pair a (pair R (pair ret stk))) /-- The done flag — the bit the iteration watches. -/ -def stDone (s : List Bool) : List Bool := fstBlock s +def stDone (s : List Bool) : List Bool := pairFst s /-- The answer, once the recursion has produced one. -/ -def stAns (s : List Bool) : List Bool := fstBlock (sndBlock s) +def stAns (s : List Bool) : List Bool := pairFst (pairSnd s) /-- The block ruler the configuration codes are written against. -/ -def stR (s : List Bool) : List Bool := fstBlock (sndBlock (sndBlock s)) +def stR (s : List Bool) : List Bool := pairFst (pairSnd (pairSnd s)) /-- The value a finished subcall is returning; `[]` while descending. -/ -def stRet (s : List Bool) : List Bool := fstBlock (sndBlock (sndBlock (sndBlock s))) +def stRet (s : List Bool) : List Bool := pairFst (pairSnd (pairSnd (pairSnd s))) /-- The stack. -/ -def stStk (s : List Bool) : List Bool := sndBlock (sndBlock (sndBlock (sndBlock s))) +def stStk (s : List Bool) : List Bool := pairSnd (pairSnd (pairSnd (pairSnd s))) @[simp] theorem stDone_mk (d a R ret stk : List Bool) : stDone (mkSt d a R ret stk) = d := by simp [stDone, mkSt] @@ -208,12 +208,12 @@ theorem mkSt_ne_nil (d a R ret stk : List Bool) : mkSt d a R ret stk ≠ [] := b /-! ## The readers and the constructors are polynomial-time -/ theorem fstBlockOf_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : - (fun z => fstBlock (a z)) ∈ FP := by + (fun z => pairFst (a z)) ∈ FP := by have := mem_FP_comp ha Cobham.fstBlock_mem_FP simpa [Function.comp] using this theorem sndBlockOf_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : - (fun z => sndBlock (a z)) ∈ FP := by + (fun z => pairSnd (a z)) ∈ FP := by have := mem_FP_comp ha Cobham.sndBlock_mem_FP simpa [Function.comp] using this diff --git a/Complexitylib/Classes/Containments/Internal/SavitchStep.lean b/Complexitylib/Classes/Containments/Internal/SavitchStep.lean index 80bd7c7a..31721e1e 100644 --- a/Complexitylib/Classes/Containments/Internal/SavitchStep.lean +++ b/Complexitylib/Classes/Containments/Internal/SavitchStep.lean @@ -171,13 +171,13 @@ noncomputable def savInit (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) first component and the input the second, so the very first call — on `pair [] x` — is the one that builds the initial state. -/ noncomputable def savG (tm : NTM k) (qp lp : Polynomial ℕ) (z : List Bool) : List Bool := - pair (selectHead (emptyFlag (fstBlock z)) - (savInit tm qp lp (sndBlock z)) (savStep tm (fstBlock z))) (sndBlock z) + pair (selectHead (emptyFlag (pairFst z)) + (savInit tm qp lp (pairSnd z)) (savStep tm (pairFst z))) (pairSnd z) @[simp] theorem savG_pair (tm : NTM k) (qp lp : Polynomial ℕ) (s x : List Bool) : savG tm qp lp (pair s x) = pair (selectHead (emptyFlag s) (savInit tm qp lp x) (savStep tm s)) x := by - rw [savG, fstBlock_pair, sndBlock_pair] + rw [savG, pairFst_pair, pairSnd_pair] theorem savG_nil (tm : NTM k) (qp lp : Polynomial ℕ) (x : List Bool) : savG tm qp lp (pair [] x) = pair (savInit tm qp lp x) x := by @@ -289,7 +289,7 @@ theorem savG_mem_FP (tm : NTM k) (qp lp : Polynomial ℕ) : savG tm qp lp ∈ FP have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) have hfst := fstBlockOf_mem_FP hid have hsnd := sndBlockOf_mem_FP hid - have hstep : (fun z => savStep tm (fstBlock z)) ∈ FP := by + have hstep : (fun z => savStep tm (pairFst z)) ∈ FP := by have := mem_FP_comp hfst (savStep_mem_FP tm) simpa [Function.comp] using this exact Cobham.pairFn_mem_FP diff --git a/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean b/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean index fb9c9212..fd2cf703 100644 --- a/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean +++ b/Complexitylib/Classes/Containments/Internal/TranscriptEnc.lean @@ -149,17 +149,17 @@ def encPack (acc rest : List Bool) : List Bool := pair acc rest /-- One step of the packed scan. -/ def encStepP (z : List Bool) : List Bool := - selectHead (lenLeFlag (sndBlock z) [false]) - (encPack (fstBlock z ++ - selectHead (bit1 (sndBlock z)) [false, false, true, true] [false, true]) - ((sndBlock z).drop 1)) + selectHead (lenLeFlag (pairSnd z) [false]) + (encPack (pairFst z ++ + selectHead (bit1 (pairSnd z)) [false, false, true, true] [false, true]) + ((pairSnd z).drop 1)) z theorem encStepP_pack (acc rest : List Bool) : encStepP (encPack acc rest) = encPack (encStep (acc, rest)).1 (encStep (acc, rest)).2 := by rw [encStepP, encPack] - simp only [fstBlock_pair, sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] cases rest with | nil => have hflag : lenLeFlag ([] : List Bool) [false] = [false] := rfl @@ -187,7 +187,7 @@ theorem encStepP_iterate_args (acc rest : List Bool) (n : ℕ) : encStepP_iterate (acc, rest) n /-- The flattened per-bit encodings, computed by the scan. -/ -def encFlat (v : List Bool) : List Bool := fstBlock (encStepP^[v.length] (encPack [] v)) +def encFlat (v : List Bool) : List Bool := pairFst (encStepP^[v.length] (encPack [] v)) theorem encFlat_eq (v : List Bool) : encFlat v = (v.map encBit).flatten := by rw [encFlat, encStepP_iterate_args, encStep_iterate_run, encPack] @@ -198,13 +198,13 @@ theorem encMsg_eq_encFlat (v : List Bool) : encMsg v = false :: (encFlat v ++ [t theorem encStepP_mem_FP : encStepP ∈ FP := by have hid : (fun z : List Bool => z) ∈ FP := CobhamFP_subset_FP (Cobham.proj 0) - have hfst : (fun z : List Bool => fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hfst : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hsnd : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP have hone : (fun _ : List Bool => ([false] : List Bool)) ∈ FP := constFn_mem_FP [false] - have hbit : (fun z => bit1 (sndBlock z)) ∈ FP := by + have hbit : (fun z => bit1 (pairSnd z)) ∈ FP := by have := Cobham.takeLenFn_mem_FP hone (Cobham.appendFn_mem_FP hsnd hone) simpa [bit1] using this - have hdrop : (fun z => (sndBlock z).drop 1) ∈ FP := by + have hdrop : (fun z => (pairSnd z).drop 1) ∈ FP := by have := dropLenFn_mem_FP hone hsnd simpa using this exact Cobham.selectHeadFn_mem_FP (lenLeFlagFn_mem_FP hsnd hone) diff --git a/Complexitylib/Classes/Interactive.lean b/Complexitylib/Classes/Interactive.lean index 420908ea..f31a4381 100644 --- a/Complexitylib/Classes/Interactive.lean +++ b/Complexitylib/Classes/Interactive.lean @@ -209,25 +209,25 @@ def IP : Set Language := /-- The verifier that ignores the proof and the coins and decides `L` on the input it can recover from the encoded view. -/ private theorem inputVerifier_mem_P {L : Language} (hL : L ∈ P) : - (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L ∈ P := by + (fun z => pairFst (pairFst z)) ⁻¹' L ∈ P := by refine mem_P_preimage ?_ hL exact mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP /-- **`P ⊆ MA`.** Merlin sends nothing and Arthur ignores his coins. -/ theorem P_subset_MA : P ⊆ MA := by intro L hL - refine ⟨0, (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L, + refine ⟨0, (fun z => pairFst (pairFst z)) ⁻¹' L, inputVerifier_mem_P hL, ?_, ?_⟩ · intro x hx refine ⟨[], by simp, ?_⟩ - have hev : merlinEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + have hev : merlinEvent ((fun z => pairFst (pairFst z)) ⁻¹' L) (Polynomial.eval x.length 0) x [] = Finset.univ := by ext r simp [merlinEvent, Set.mem_preimage, hx] rw [hev, eventProb_univ] norm_num · intro x hx w _ - have hev : merlinEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + have hev : merlinEvent ((fun z => pairFst (pairFst z)) ⁻¹' L) (Polynomial.eval x.length 0) x w = ∅ := by ext r simp [merlinEvent, Set.mem_preimage, hx] @@ -237,10 +237,10 @@ theorem P_subset_MA : P ⊆ MA := by /-- **`P ⊆ AM`.** Arthur's coins are irrelevant and Merlin's answer is empty. -/ theorem P_subset_AM : P ⊆ AM := by intro L hL - refine ⟨0, (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L, + refine ⟨0, (fun z => pairFst (pairFst z)) ⁻¹' L, inputVerifier_mem_P hL, ?_, ?_⟩ · intro x hx - have hev : arthurEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + have hev : arthurEvent ((fun z => pairFst (pairFst z)) ⁻¹' L) (Polynomial.eval x.length 0) (Polynomial.eval x.length 0) x = Finset.univ := by ext r simp only [arthurEvent, Finset.mem_filter, Finset.mem_univ, true_and, iff_true] @@ -248,7 +248,7 @@ theorem P_subset_AM : P ⊆ AM := by rw [hev, eventProb_univ] norm_num · intro x hx - have hev : arthurEvent ((fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L) + have hev : arthurEvent ((fun z => pairFst (pairFst z)) ⁻¹' L) (Polynomial.eval x.length 0) (Polynomial.eval x.length 0) x = ∅ := by ext r simp only [arthurEvent, Finset.mem_filter, Finset.mem_univ, true_and, diff --git a/Complexitylib/Classes/PCP.lean b/Complexitylib/Classes/PCP.lean index ecbb9f52..bb255baa 100644 --- a/Complexitylib/Classes/PCP.lean +++ b/Complexitylib/Classes/PCP.lean @@ -5,8 +5,7 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.PCP.Defs -public import Complexitylib.Classes.PCP.Internal.AlgPCP -public import Complexitylib.Classes.PCP.Internal.SubsetNPFinal +public import Complexitylib.Classes.PCP.Internal /-! # The PCP theorem diff --git a/Complexitylib/Classes/PCP/Defs.lean b/Complexitylib/Classes/PCP/Defs.lean index d31e42a5..61b02783 100644 --- a/Complexitylib/Classes/PCP/Defs.lean +++ b/Complexitylib/Classes/PCP/Defs.lean @@ -139,7 +139,7 @@ private noncomputable def inputVerifier (L : Language) (hL : L ∈ P) : PCPVerif positions_mem := ⟨fun _ => DataEncode.bitstringEncode ([] : List ℕ), constFn_mem_FP _, fun _ _ => rfl⟩ - verdict := (fun z => Cobham.fstBlock (Cobham.fstBlock z)) ⁻¹' L + verdict := (fun z => pairFst (pairFst z)) ⁻¹' L verdict_mem := by refine mem_P_preimage ?_ hL exact mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP diff --git a/Complexitylib/Classes/PCP/Internal.lean b/Complexitylib/Classes/PCP/Internal.lean index 765a4b86..b0b18ed6 100644 --- a/Complexitylib/Classes/PCP/Internal.lean +++ b/Complexitylib/Classes/PCP/Internal.lean @@ -5,6 +5,30 @@ Authors: Bolton Bailey -/ module public import Complexitylib.Classes.PCP.Internal.AlgCSPModel +public import Complexitylib.Classes.PCP.Internal.AlgCompose +public import Complexitylib.Classes.PCP.Internal.AlgEdge +public import Complexitylib.Classes.PCP.Internal.AlgFamily +public import Complexitylib.Classes.PCP.Internal.AlgFormula +public import Complexitylib.Classes.PCP.Internal.AlgGap +public import Complexitylib.Classes.PCP.Internal.AlgGapAll +public import Complexitylib.Classes.PCP.Internal.AlgGapCSP +public import Complexitylib.Classes.PCP.Internal.AlgGraph +public import Complexitylib.Classes.PCP.Internal.AlgInit +public import Complexitylib.Classes.PCP.Internal.AlgIter +public import Complexitylib.Classes.PCP.Internal.AlgKey +public import Complexitylib.Classes.PCP.Internal.AlgKeyFn +public import Complexitylib.Classes.PCP.Internal.AlgKilled +public import Complexitylib.Classes.PCP.Internal.AlgLevel +public import Complexitylib.Classes.PCP.Internal.AlgLog +public import Complexitylib.Classes.PCP.Internal.AlgPCP +public import Complexitylib.Classes.PCP.Internal.AlgPosNum +public import Complexitylib.Classes.PCP.Internal.AlgPreRel +public import Complexitylib.Classes.PCP.Internal.AlgPreRot +public import Complexitylib.Classes.PCP.Internal.AlgPreprocess +public import Complexitylib.Classes.PCP.Internal.AlgRound +public import Complexitylib.Classes.PCP.Internal.AlgStep +public import Complexitylib.Classes.PCP.Internal.AlgUniform +public import Complexitylib.Classes.PCP.Internal.AlgWalk public import Complexitylib.Classes.PCP.Internal.AlphabetLift public import Complexitylib.Classes.PCP.Internal.Amplification public import Complexitylib.Classes.PCP.Internal.Arithmetize @@ -20,6 +44,7 @@ public import Complexitylib.Classes.PCP.Internal.CNFTokens public import Complexitylib.Classes.PCP.Internal.CSPVerifier public import Complexitylib.Classes.PCP.Internal.Cheeger public import Complexitylib.Classes.PCP.Internal.Clique +public import Complexitylib.Classes.PCP.Internal.CloudCount public import Complexitylib.Classes.PCP.Internal.CloudDisagreement public import Complexitylib.Classes.PCP.Internal.CoinEnum public import Complexitylib.Classes.PCP.Internal.Compose @@ -40,6 +65,7 @@ public import Complexitylib.Classes.PCP.Internal.ExpanderMerge public import Complexitylib.Classes.PCP.Internal.ExpanderPad public import Complexitylib.Classes.PCP.Internal.ExpanderRandom public import Complexitylib.Classes.PCP.Internal.ExpanderizeCSP +public import Complexitylib.Classes.PCP.Internal.FamilyFin public import Complexitylib.Classes.PCP.Internal.FiniteKey public import Complexitylib.Classes.PCP.Internal.FinsetPlurality public import Complexitylib.Classes.PCP.Internal.GapReduction @@ -54,12 +80,17 @@ public import Complexitylib.Classes.PCP.Internal.KilledWalk public import Complexitylib.Classes.PCP.Internal.LengthMod public import Complexitylib.Classes.PCP.Internal.ListEncode public import Complexitylib.Classes.PCP.Internal.LocalTest +public import Complexitylib.Classes.PCP.Internal.Margulis +public import Complexitylib.Classes.PCP.Internal.Materialize public import Complexitylib.Classes.PCP.Internal.MaxLoop public import Complexitylib.Classes.PCP.Internal.MergeGen public import Complexitylib.Classes.PCP.Internal.Mixing public import Complexitylib.Classes.PCP.Internal.NatEncode +public import Complexitylib.Classes.PCP.Internal.NumEnc +public import Complexitylib.Classes.PCP.Internal.NumEncPi public import Complexitylib.Classes.PCP.Internal.PCPtoSAT public import Complexitylib.Classes.PCP.Internal.Pad +public import Complexitylib.Classes.PCP.Internal.PadGraph public import Complexitylib.Classes.PCP.Internal.PermArith public import Complexitylib.Classes.PCP.Internal.PermCount public import Complexitylib.Classes.PCP.Internal.PermGraph @@ -68,6 +99,7 @@ public import Complexitylib.Classes.PCP.Internal.PositionsFP public import Complexitylib.Classes.PCP.Internal.Power public import Complexitylib.Classes.PCP.Internal.PoweringBound public import Complexitylib.Classes.PCP.Internal.Preprocess +public import Complexitylib.Classes.PCP.Internal.RankCount public import Complexitylib.Classes.PCP.Internal.RegCSP public import Complexitylib.Classes.PCP.Internal.RegularGraph public import Complexitylib.Classes.PCP.Internal.SecondMoment @@ -81,8 +113,11 @@ public import Complexitylib.Classes.PCP.Internal.TesterChecks public import Complexitylib.Classes.PCP.Internal.TesterCore public import Complexitylib.Classes.PCP.Internal.TesterInput public import Complexitylib.Classes.PCP.Internal.ThreeSATReduction +public import Complexitylib.Classes.PCP.Internal.TowerFin +public import Complexitylib.Classes.PCP.Internal.TowerTable public import Complexitylib.Classes.PCP.Internal.UnaryDivMod public import Complexitylib.Classes.PCP.Internal.UnaryExp +public import Complexitylib.Classes.PCP.Internal.UnaryList public import Complexitylib.Classes.PCP.Internal.Union public import Complexitylib.Classes.PCP.Internal.VerifierLang public import Complexitylib.Classes.PCP.Internal.Walk @@ -90,6 +125,7 @@ public import Complexitylib.Classes.PCP.Internal.WalkDart public import Complexitylib.Classes.PCP.Internal.WalkPath public import Complexitylib.Classes.PCP.Internal.WalkSplit public import Complexitylib.Classes.PCP.Internal.ZigZag +public import Complexitylib.Classes.PCP.Internal.ZigZagBaseExists public import Complexitylib.Classes.PCP.Internal.ZigZagTower /-! diff --git a/Complexitylib/Classes/PCP/Internal/AlgEdge.lean b/Complexitylib/Classes/PCP/Internal/AlgEdge.lean index 9ed49812..3cb4e72b 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgEdge.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgEdge.lean @@ -93,7 +93,7 @@ variable {α : Type} [Fintype α] [DecidableEq α] /-- An edge's first endpoint: the test vertex it belongs to, after all the positions. -/ noncomputable def tailBlk (posF : ℕ) (r : Round) (w : List Bool) : List Bool := - marks (mulC posF (posCount (Cobham.sndBlock (Cobham.fstBlock w)))) + marks (mulC posF (posCount (pairSnd (pairFst w)))) ++ (marks (mulC r.cZ (testFn r w)) ++ randFn r w) theorem tailBlk_mem_FP (posF : ℕ) (r : Round) : tailBlk posF r ∈ FP := @@ -105,10 +105,10 @@ theorem tailBlk_mem_FP (posF : ℕ) (r : Round) : tailBlk posF r ∈ FP := /-- **The first endpoint's algorithm computes it.** -/ theorem tailBlk_eq (posF : ℕ) (r : Round) (G : ConstraintGraph α) {w : List Bool} {t zN : ℕ} - (hg : Cobham.fstBlock w = encGraph G) (ht : testFn r w = List.replicate t true) + (hg : pairFst w = encGraph G) (ht : testFn r w = List.replicate t true) (hz : randFn r w = List.replicate zN true) : tailBlk posF r w = List.replicate (G.numEdges * posF + (t * r.cZ + zN)) true := by - have hcnt : (posCount (Cobham.sndBlock (encGraph G))).length = G.numEdges := by + have hcnt : (posCount (pairSnd (encGraph G))).length = G.numEdges := by have h := gEdges_encGraph G rwa [gEdges] at h rw [tailBlk, hg, ht, hz, marks_eq, marks_eq, length_mulC, length_mulC, hcnt, @@ -140,13 +140,13 @@ noncomputable def blockBlk (F : FinBase) (pol : Polynomial ℕ) (r : Round) (w : List Bool := ifEqLen (readFn w) (List.replicate (NumEnc.enc ReadIdx.i5r) true) (vertFn r w) (ifEqLen (readFn w) (List.replicate (NumEnc.enc ReadIdx.i6r) true) - (Cobham.fstBlock (killedRotFn F pol r.deg r.P r.T r.q (killArg r w))) + (pairFst (killedRotFn F pol r.deg r.P r.T r.q (killArg r w))) (testFn r w)) theorem blockBlk_mem_FP (F : FinBase) (pol : Polynomial ℕ) (r : Round) : blockBlk F pol r ∈ FP := by have hrot : (fun w : List Bool => - Cobham.fstBlock (killedRotFn F pol r.deg r.P r.T r.q (killArg r w))) ∈ FP := + pairFst (killedRotFn F pol r.deg r.P r.T r.q (killArg r w))) ∈ FP := mem_FP_of_eq (mem_FP_comp (killArg_mem_FP r) (mem_FP_comp (killedRotFn_mem_FP F pol r.deg r.P r.T r.q) Cobham.fstBlock_mem_FP)) fun _ => rfl @@ -160,7 +160,7 @@ theorem blockBlk_eq {β : Type} [Fintype β] [DecidableEq β] [Nonempty β] {R : (hread : readFn w = List.replicate (NumEnc.enc i) true) (hv : vertFn r w = List.replicate (NumEnc.enc p.1) true) (ht : testFn r w = List.replicate (NumEnc.enc p) true) - (hrot : Cobham.fstBlock (killedRotFn F pol r.deg r.P r.T r.q (killArg r w)) + (hrot : pairFst (killedRotFn F pol r.deg r.P r.T r.q (killArg r w)) = List.replicate (NumEnc.enc (R.graph.rot p).1) true) : blockBlk F pol r w = List.replicate (R.blockNum p i) true := by have hne : ∀ j k : ReadIdx, j ≠ k → NumEnc.enc j ≠ NumEnc.enc k := @@ -179,16 +179,16 @@ theorem blockBlk_eq {β : Type} [Fintype β] [DecidableEq β] [Nonempty β] {R : /-- How many vertices the powered graph has: twice the input's edge count. -/ noncomputable def vertCount (w : List Bool) : List Bool := - marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock w)))) + marks (mulC 2 (posCount (pairSnd (pairFst w)))) theorem vertCount_mem_FP : vertCount ∈ FP := marks_mem_FP (mulC_mem_FP (posCount_mem_FP (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP)) 2) theorem vertCount_eq (G : ConstraintGraph α) {w : List Bool} - (hg : Cobham.fstBlock w = encGraph G) : + (hg : pairFst w = encGraph G) : vertCount w = List.replicate (2 * G.numEdges) true := by - have hcnt : (posCount (Cobham.sndBlock (encGraph G))).length = G.numEdges := by + have hcnt : (posCount (pairSnd (encGraph G))).length = G.numEdges := by have h := gEdges_encGraph G rwa [gEdges] at h rw [vertCount, hg, marks_eq, length_mulC, hcnt, Nat.mul_comm] @@ -316,15 +316,15 @@ noncomputable def stepFn (F : FinBase) (pol : Polynomial ℕ) (r : Round) (vertF edgeF posF cardB cardN cardNN : ℕ) {E : ExpanderFamily} {B : ℕ} (dflt : StepKey E r.T r.q B (Fintype.card (α → α → Bool))) (encβ : (PreWalk E r.T → α) → Cube B) : List Bool → List Bool := - buildGraph (fun z => marks (mulC vertF (posCount (Cobham.sndBlock z)))) - (fun z => marks (mulC edgeF (posCount (Cobham.sndBlock z)))) + buildGraph (fun z => marks (mulC vertF (posCount (pairSnd z)))) + (fun z => marks (mulC edgeF (posCount (pairSnd z)))) (edgeRule F pol r posF cardB cardN cardNN dflt encβ) /-- **A count block is a constant multiple of the input's edge count.** -/ theorem countBlk_eq (G : ConstraintGraph α) (c : ℕ) : - marks (mulC c (posCount (Cobham.sndBlock (encGraph G)))) + marks (mulC c (posCount (pairSnd (encGraph G)))) = List.replicate (c * G.numEdges) true := by - have hcnt : (posCount (Cobham.sndBlock (encGraph G))).length = G.numEdges := by + have hcnt : (posCount (pairSnd (encGraph G))).length = G.numEdges := by have h := gEdges_encGraph G rwa [gEdges] at h rw [marks_eq, length_mulC, hcnt, Nat.mul_comm] @@ -398,7 +398,7 @@ theorem stepFn_eq (F : FinBase) (pol : Polynomial ℕ) (hd : 1 < F.deg) obtain ⟨htest, hvert, hdart, hrand, hread⟩ := blocks_eq r hDpos (by omega) (encGraph G) (NumEnc.enc p.1) (NumEnc.enc p.2) (NumEnc.enc z) (NumEnc.enc i) hblt hclt hilt - rw [edgeRule, tailBlk_eq posF r G (Cobham.fstBlock_pair _ _) htest hrand, + rw [edgeRule, tailBlk_eq posF r G (pairFst_pair _ _) htest hrand, RegCSP.tailNum_split' (cZ := r.cZ) _ _ _ _ _ _ hrZ hclt hilt, hposF] rw [codeFn_eq' (B := Dinur.bits (F.toFamily hd) r.T) r hd G hq hdeg hP hC (by omega) p z i (by rw [hrZ, NumEnc.card_eq_fintype_card, card_cube]) hpc hpe dflt @@ -426,8 +426,8 @@ theorem stepFn_eq (F : FinBase) (pol : Polynomial ℕ) (hd : 1 < F.deg) have hd2 : NumEnc.enc p.2 = NumEnc.enc p.2.1 * r.q ^ r.T + NumEnc.enc p.2.2 := rfl have hkr := killedRotFn_eq hd G r.T r.q (NumEnc.enc p.1) (NumEnc.enc p.2.1) (NumEnc.enc p.2.2) hq hv2 hc2 hpc hpe - rw [killArg_eq r (Cobham.fstBlock_pair _ _) hvert hdart, hdeg, hP, hd2, hkr, - Cobham.fstBlock_pair] + rw [killArg_eq r (pairFst_pair _ _) hvert hdart, hdeg, hP, hd2, hkr, + pairFst_pair] have hrn := G.killedRotNum_eq (F.toFamily hd) hq (G.preDeg_pos _) p.1 p.2 (w := (((G.preprocess (F.toFamily hd)).graph.killedPower r.q r.T hq).rot (p.1, p.2)).1) @@ -435,7 +435,7 @@ theorem stepFn_eq (F : FinBase) (pol : Polynomial ℕ) (hd : 1 < F.deg) (p.1, p.2)).2) rfl exact congrArg (fun n => List.replicate n true) (congrArg Prod.fst hrn) rw [headBlk_eq F pol r cardB cardN cardNN dflt (Dinur.enc (F.toFamily hd) G r.T) - (vertCount_eq G (Cobham.fstBlock_pair _ _)) (kindBlk_eq hread) hblock hcube] + (vertCount_eq G (pairFst_pair _ _)) (kindBlk_eq hread) hblock hcube] rw [hV', ← hrD, ← hcardB, ← hcardN, ← hcardNN] rfl diff --git a/Complexitylib/Classes/PCP/Internal/AlgFamily.lean b/Complexitylib/Classes/PCP/Internal/AlgFamily.lean index 9dc5b343..824bf827 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgFamily.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgFamily.lean @@ -125,9 +125,9 @@ split the dart into a slot and a step, lift the vertex into the tower member, look the step up in that member's table, and fold the answer back onto `n` vertices. Darts past the fold's degree are self-loops. -/ noncomputable def famRotFn (z : List Bool) : List Bool := - let n := Cobham.fstBlock z - let v := Cobham.fstBlock (Cobham.sndBlock z) - let i := Cobham.sndBlock (Cobham.sndBlock z) + let n := pairFst z + let v := pairFst (pairSnd z) + let i := pairSnd (pairSnd z) let N := sizeFn (F.deg ^ 4) p n let T := F.famTableFn p n let m := divFn2 (pair n N) ++ [true] @@ -144,14 +144,14 @@ noncomputable def famRotFn (z : List Bool) : List Bool := (pair (marks v) (marks i)) theorem famRotFn_mem_FP : F.famRotFn p ∈ FP := by - have hn : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hv : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := + have hn : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hv : (fun z : List Bool => pairFst (pairSnd z)) ∈ FP := mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP) fun _ => rfl - have hi : (fun z : List Bool => Cobham.sndBlock (Cobham.sndBlock z)) ∈ FP := + have hi : (fun z : List Bool => pairSnd (pairSnd z)) ∈ FP := mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP) fun _ => rfl - have hN : (fun z : List Bool => sizeFn (F.deg ^ 4) p (Cobham.fstBlock z)) ∈ FP := + have hN : (fun z : List Bool => sizeFn (F.deg ^ 4) p (pairFst z)) ∈ FP := mem_FP_of_eq (mem_FP_comp hn (sizeFn_mem_FP _ p)) fun _ => rfl - have hT : (fun z : List Bool => F.famTableFn p (Cobham.fstBlock z)) ∈ FP := + have hT : (fun z : List Bool => F.famTableFn p (pairFst z)) ∈ FP := mem_FP_of_eq (mem_FP_comp hn (F.famTableFn_mem_FP p)) fun _ => rfl have hm := Cobham.appendFn_mem_FP (mem_FP_of_eq (mem_FP_comp (Cobham.pairFn_mem_FP hn hN) divFn2_mem_FP) fun _ => rfl) @@ -202,7 +202,7 @@ theorem famRotFn_eq (hd : 1 < F.deg) (n v i : ℕ) (hn : 0 < n) rw [List.length_append, List.length_replicate, length_mulLen, hs, hrep, List.length_replicate] rw [famRotFn, famRotVal] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] by_cases h1 : i < F.wid hd n * F.fitD · rw [if_pos h1, ifLtLen_pos (by rw [List.length_replicate, length_mulLen, hm, List.length_replicate] diff --git a/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean b/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean index c415b21a..732a27c6 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgGapCSP.lean @@ -43,7 +43,7 @@ variable (F : FinBase) (hd : 1 < F.deg) (E padU : List Bool → List Bool) /-- The graph string a verifier argument names. -/ noncomputable def gapStr (z : List Bool) : List Bool := - gapAll F hd E padU (Cobham.fstBlock (Cobham.fstBlock z)) + gapAll F hd E padU (pairFst (pairFst z)) theorem gapStr_mem_FP (hgap : gapAll F hd E padU ∈ FP) : gapStr F hd E padU ∈ FP := mem_FP_of_eq (mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP) hgap) @@ -52,12 +52,12 @@ theorem gapStr_mem_FP (hgap : gapAll F hd E padU ∈ FP) : gapStr F hd E padU /-- The code of the constraint the argument names, clamped to the number of constraints there are. -/ noncomputable def gapCodeBlk (z : List Bool) : List Bool := - (recThd (Cobham.sndBlock (gapStr F hd E padU z)) - (Cobham.sndBlock (Cobham.fstBlock z)).length).take cRel + (recThd (pairSnd (gapStr F hd E padU z)) + (pairSnd (pairFst z)).length).take cRel theorem gapCodeBlk_mem_FP (hgap : gapAll F hd E padU ∈ FP) : gapCodeBlk F hd E padU ∈ FP := by - have hidx : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have hidx : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) fun _ => rfl have hrec := gCodeFn_mem_FP hidx (gapStr_mem_FP F hd E padU hgap) refine mem_FP_of_eq (Cobham.takeLenFn_mem_FP @@ -66,7 +66,7 @@ theorem gapCodeBlk_mem_FP (hgap : gapAll F hd E padU ∈ FP) : /-- Everything the constraint depends on: the code and the two symbol blocks. -/ noncomputable def gapOkKey (z : List Bool) : List Bool := - pair (gapCodeBlk F hd E padU z) ((Cobham.sndBlock z).take 46) + pair (gapCodeBlk F hd E padU z) ((pairSnd z).take 46) theorem gapOkKey_mem_FP (hgap : gapAll F hd E padU ∈ FP) : gapOkKey F hd E padU ∈ FP := Cobham.pairFn_mem_FP (gapCodeBlk_mem_FP F hd E padU hgap) @@ -79,7 +79,7 @@ theorem gapOkKey_length_le (z : List Bool) : have h1 : (gapCodeBlk F hd E padU z).length ≤ cRel := by rw [gapCodeBlk, List.length_take] omega - have h2 : ((Cobham.sndBlock z).take 46).length ≤ 46 := by + have h2 : ((pairSnd z).take 46).length ≤ 46 := by rw [List.length_take] omega rw [gapOkKey, pair_length] @@ -87,9 +87,9 @@ theorem gapOkKey_length_le (z : List Bool) : /-- What the constraint says, of the key alone. -/ def gapOkPred (k : List Bool) : Prop := - relOfCode DinurAlpha (Cobham.fstBlock k).length - (symDec DinurAlpha ((Cobham.sndBlock k).take 23)) - (symDec DinurAlpha ((Cobham.sndBlock k).drop 23)) = true + relOfCode DinurAlpha (pairFst k).length + (symDec DinurAlpha ((pairSnd k).take 23)) + (symDec DinurAlpha ((pairSnd k).drop 23)) = true /-- The constraint, as a language on the verifier's verdict argument. -/ noncomputable def gapOk : Language := @@ -113,7 +113,7 @@ noncomputable def gapAlg (hgap : gapAll F hd E padU ∈ FP) : AlgCSP where cond b (gHead (gapAll F hd E padU x) e) (gTail (gapAll F hd E padU x) e) vert_mem := by intro b - have hg : (fun w : List Bool => gapAll F hd E padU (Cobham.fstBlock w)) ∈ FP := + have hg : (fun w : List Bool => gapAll F hd E padU (pairFst w)) ∈ FP := mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP hgap) fun _ => rfl cases b · refine mem_FP_of_eq (marks_mem_FP (gTailFn_mem_FP Cobham.sndBlock_mem_FP hg)) @@ -154,14 +154,14 @@ theorem gapCodeBlk_length (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3 (he : e < (gapAllG F hd padU (Φ := Φ) x).numEdges) (a : List Bool) : (gapCodeBlk F hd E padU (pair (pair x (List.replicate e true)) a)).length = codeOfRel ((gapAllG F hd padU (Φ := Φ) x).rel ⟨e, he⟩) := by - have hcode : (recThd (Cobham.sndBlock (gapAll F hd E padU x)) e).length + have hcode : (recThd (pairSnd (gapAll F hd E padU x)) e).length = codeOfRel ((gapAllG F hd padU (Φ := Φ) x).rel ⟨e, he⟩) := by rw [length_recThd_sndBlock, gapAll_eq F hd E padU hE h3 hmark hle x, gCode_encGraph] have hlt : codeOfRel ((gapAllG F hd padU (Φ := Φ) x).rel ⟨e, he⟩) < cRel := by rw [cRel_eq] exact codeOfRel_lt _ - rw [gapCodeBlk, gapStr, Cobham.fstBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, List.length_replicate, List.length_take, hcode] + rw [gapCodeBlk, gapStr, pairFst_pair, pairFst_pair, + pairSnd_pair, List.length_replicate, List.length_take, hcode] omega /-- **The algorithm models the gap graph.** -/ @@ -190,7 +190,7 @@ theorem gapAlg_models (hgap : gapAll F hd E padU ∈ FP) have hcode := gapCodeBlk_length F hd E padU hE h3 hmark hle x e he (u ++ v) have htake46 : (u ++ v).take 46 = u ++ v := List.take_of_length_le (by omega) show gapOkPred (gapOkKey F hd E padU (pair (pair x (List.replicate e true)) (u ++ v))) ↔ _ - rw [gapOkPred, gapOkKey, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hcode, - Cobham.sndBlock_pair, htake46, htake, hdrop, relOfCode_codeOfRel] + rw [gapOkPred, gapOkKey, pairFst_pair, pairSnd_pair, hcode, + pairSnd_pair, htake46, htake, hdrop, relOfCode_codeOfRel] end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgGraph.lean b/Complexitylib/Classes/PCP/Internal/AlgGraph.lean index 762d6690..e35d0011 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgGraph.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgGraph.lean @@ -81,27 +81,27 @@ noncomputable def encGraph (G : ConstraintGraph α) : List Bool := /-! ### Reading it back -/ /-- How many vertices an encoded graph has. -/ -def gVerts (z : List Bool) : ℕ := (Cobham.fstBlock z).length +def gVerts (z : List Bool) : ℕ := (pairFst z).length /-- How many edges. -/ -noncomputable def gEdges (z : List Bool) : ℕ := (posCount (Cobham.sndBlock z)).length +noncomputable def gEdges (z : List Bool) : ℕ := (posCount (pairSnd z)).length /-- The first endpoint of an edge. -/ -noncomputable def gTail (z : List Bool) (e : ℕ) : ℕ := (recFst (Cobham.sndBlock z) e).length +noncomputable def gTail (z : List Bool) (e : ℕ) : ℕ := (recFst (pairSnd z) e).length /-- The second endpoint. -/ -noncomputable def gHead (z : List Bool) (e : ℕ) : ℕ := (recSnd (Cobham.sndBlock z) e).length +noncomputable def gHead (z : List Bool) (e : ℕ) : ℕ := (recSnd (pairSnd z) e).length /-- The code of the constraint. -/ -noncomputable def gCode (z : List Bool) (e : ℕ) : ℕ := (recThd (Cobham.sndBlock z) e).length +noncomputable def gCode (z : List Bool) (e : ℕ) : ℕ := (recThd (pairSnd z) e).length variable (G : ConstraintGraph α) @[simp] theorem gVerts_encGraph : gVerts (encGraph G) = G.numVerts := by - rw [gVerts, encGraph, Cobham.fstBlock_pair, List.length_replicate] + rw [gVerts, encGraph, pairFst_pair, List.length_replicate] @[simp] theorem gEdges_encGraph : gEdges (encGraph G) = G.numEdges := by - rw [gEdges, encGraph, Cobham.sndBlock_pair, posCount_eq, List.length_replicate, + rw [gEdges, encGraph, pairSnd_pair, posCount_eq, List.length_replicate, length_edgeRecs] theorem getElem_edgeRecs (e : ℕ) (he : e < G.numEdges) : @@ -114,19 +114,19 @@ theorem getElem_edgeRecs (e : ℕ) (he : e < G.numEdges) : @[simp] theorem gTail_encGraph (e : ℕ) (he : e < G.numEdges) : gTail (encGraph G) e = (G.tail ⟨e, he⟩).val := by - rw [gTail, encGraph, Cobham.sndBlock_pair, + rw [gTail, encGraph, pairSnd_pair, recFst_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact he) (getElem_edgeRecs G e he), List.length_replicate] @[simp] theorem gHead_encGraph (e : ℕ) (he : e < G.numEdges) : gHead (encGraph G) e = (G.head ⟨e, he⟩).val := by - rw [gHead, encGraph, Cobham.sndBlock_pair, + rw [gHead, encGraph, pairSnd_pair, recSnd_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact he) (getElem_edgeRecs G e he), List.length_replicate] theorem gCode_encGraph (e : ℕ) (he : e < G.numEdges) : gCode (encGraph G) e = codeOfRel (G.rel ⟨e, he⟩) := by - rw [gCode, encGraph, Cobham.sndBlock_pair, + rw [gCode, encGraph, pairSnd_pair, recThd_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact he) (getElem_edgeRecs G e he), List.length_replicate] @@ -186,39 +186,39 @@ theorem buildGraph_eq {nv cnt E : List Bool → List Bool} {z : List Bool} /-! ### Reading one, in polynomial time -/ theorem gVertsFn_mem_FP {g : List Bool → List Bool} (hg : g ∈ FP) : - (fun z => marks (Cobham.fstBlock (g z))) ∈ FP := + (fun z => marks (pairFst (g z))) ∈ FP := marks_mem_FP (mem_FP_comp hg Cobham.fstBlock_mem_FP) theorem gEdgesFn_mem_FP {g : List Bool → List Bool} (hg : g ∈ FP) : - (fun z => posCount (Cobham.sndBlock (g z))) ∈ FP := + (fun z => posCount (pairSnd (g z))) ∈ FP := posCount_mem_FP (mem_FP_comp hg Cobham.sndBlock_mem_FP) theorem gTailFn_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : - (fun z => recFst (Cobham.sndBlock (g z)) (f z).length) ∈ FP := + (fun z => recFst (pairSnd (g z)) (f z).length) ∈ FP := recFst_mem_FP hf (mem_FP_comp hg Cobham.sndBlock_mem_FP) theorem gHeadFn_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : - (fun z => recSnd (Cobham.sndBlock (g z)) (f z).length) ∈ FP := + (fun z => recSnd (pairSnd (g z)) (f z).length) ∈ FP := recSnd_mem_FP hf (mem_FP_comp hg Cobham.sndBlock_mem_FP) theorem gCodeFn_mem_FP {f g : List Bool → List Bool} (hf : f ∈ FP) (hg : g ∈ FP) : - (fun z => recThd (Cobham.sndBlock (g z)) (f z).length) ∈ FP := + (fun z => recThd (pairSnd (g z)) (f z).length) ∈ FP := recThd_mem_FP hf (mem_FP_comp hg Cobham.sndBlock_mem_FP) theorem length_marks_fstBlock (z : List Bool) : - (marks (Cobham.fstBlock z)).length = gVerts z := by + (marks (pairFst z)).length = gVerts z := by rw [marks_eq, List.length_replicate, gVerts] theorem length_posCount_sndBlock (z : List Bool) : - (posCount (Cobham.sndBlock z)).length = gEdges z := rfl + (posCount (pairSnd z)).length = gEdges z := rfl theorem length_recFst_sndBlock (z : List Bool) (e : ℕ) : - (recFst (Cobham.sndBlock z) e).length = gTail z e := rfl + (recFst (pairSnd z) e).length = gTail z e := rfl theorem length_recSnd_sndBlock (z : List Bool) (e : ℕ) : - (recSnd (Cobham.sndBlock z) e).length = gHead z e := rfl + (recSnd (pairSnd z) e).length = gHead z e := rfl theorem length_recThd_sndBlock (z : List Bool) (e : ℕ) : - (recThd (Cobham.sndBlock z) e).length = gCode z e := rfl + (recThd (pairSnd z) e).length = gCode z e := rfl end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/AlgInit.lean b/Complexitylib/Classes/PCP/Internal/AlgInit.lean index 48a3a562..29d24ba2 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgInit.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgInit.lean @@ -77,7 +77,7 @@ theorem rel_baseCSP (φ : CNF) (e : ℕ) (he : e < (baseCSP φ).numEdges) : which of them the edge reads. -/ noncomputable def baseCodeKey (w : List Bool) : List Bool := pair (baseSigns E (pair w [])) - (modFn [false, false, false] (Cobham.sndBlock w)) + (modFn [false, false, false] (pairSnd w)) theorem baseCodeKey_mem_FP (hE : E ∈ FP) : baseCodeKey E ∈ FP := by have harg : (fun w : List Bool => pair w []) ∈ FP := @@ -85,7 +85,7 @@ theorem baseCodeKey_mem_FP (hE : E ∈ FP) : baseCodeKey E ∈ FP := by have hsigns : (fun w : List Bool => baseSigns E (pair w [])) ∈ FP := by refine mem_FP_of_eq (mem_FP_comp harg (baseSigns_mem_FP E hE)) fun w => ?_ rw [Function.comp_apply] - have hmod : (fun w : List Bool => modFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + have hmod : (fun w : List Bool => modFn [false, false, false] (pairSnd w)) ∈ FP := by refine mem_FP_of_eq (mem_FP_comp Cobham.sndBlock_mem_FP (modFn_mem_FP [false, false, false])) fun w => ?_ rw [Function.comp_apply] @@ -93,9 +93,9 @@ theorem baseCodeKey_mem_FP (hE : E ∈ FP) : baseCodeKey E ∈ FP := by theorem baseCodeKey_length_le (w : List Bool) : (baseCodeKey E w).length ≤ 12 := by have hs : (baseSigns E (pair w [])).length ≤ 3 := length_baseSigns_le E _ - have hm : (modFn [false, false, false] (Cobham.sndBlock w)).length ≤ 2 := by + have hm : (modFn [false, false, false] (pairSnd w)).length ≤ 2 := by rw [modFn_eq (by simp), List.length_replicate] - have : (Cobham.sndBlock w).length % [false, false, false].length < 3 := by + have : (pairSnd w).length % [false, false, false].length < 3 := by simpa using Nat.mod_lt _ (by omega) omega rw [baseCodeKey, pair_length] @@ -108,7 +108,7 @@ theorem baseCodeKey_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3C baseCodeKey E (pair x (List.replicate e true)) = pair [(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, (litOf (Φ x) (e / 3) 2).sign] (List.replicate (e % 3) true) := by - rw [baseCodeKey, baseSigns_pair E hE h3 x he [], Cobham.sndBlock_pair, + rw [baseCodeKey, baseSigns_pair E hE h3 x he [], pairSnd_pair, modFn_eq (by simp) (List.replicate e true), List.length_replicate, show ([false, false, false] : List Bool).length = 3 from rfl] @@ -116,8 +116,8 @@ theorem baseCodeKey_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3C /-- The constraint an edge's key stands for. -/ noncomputable def baseRelOfKey (k : List Bool) : GapAlpha → GapAlpha → Bool := - relOfSigns (fun q => (Cobham.fstBlock k).getD q.val false) - ⟨(Cobham.sndBlock k).length % 3, Nat.mod_lt _ (by omega)⟩ + relOfSigns (fun q => (pairFst k).getD q.val false) + ⟨(pairSnd k).length % 3, Nat.mod_lt _ (by omega)⟩ /-- The constraint's code, in unary, from the key. -/ noncomputable def baseCodeFn (k : List Bool) : List Bool := @@ -139,10 +139,10 @@ theorem baseCodeFn_codeKey (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is ⟨e % 3, Nat.mod_lt _ (by omega)⟩ := by rw [baseRelOfKey] refine relOfSigns_congr _ _ ?_ ?_ - · rw [baseCodeKey_pair E hE h3 x he', Cobham.fstBlock_pair] + · rw [baseCodeKey_pair E hE h3 x he', pairFst_pair] funext q fin_cases q <;> rfl - · rw [baseCodeKey_pair E hE h3 x he', Cobham.sndBlock_pair, List.length_replicate] + · rw [baseCodeKey_pair E hE h3 x he', pairSnd_pair, List.length_replicate] omega rw [baseCodeFn, hrel, rel_baseCSP] @@ -234,7 +234,7 @@ noncomputable def trivCode : List Bool := can be made to depend on the input's length alone. -/ noncomputable def basePadFn (padU g : List Bool → List Bool) : List Bool → List Bool := buildGraph (baseVertsU E) padU - (fun w => ifLtLen (Cobham.sndBlock w) (baseEdgesU E (Cobham.fstBlock w)) + (fun w => ifLtLen (pairSnd w) (baseEdgesU E (pairFst w)) (encTriple (marks (baseTailU E w)) (marks (baseHeadU E w)) (g (baseCodeKey E w))) (encTriple [] [] trivCode)) @@ -261,17 +261,17 @@ theorem basePadFn_eq (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF ( · rw [ConstraintGraph.numEdges_padGraph, hmax] exact hPmark · rw [ConstraintGraph.numEdges_padGraph, hmax] at he - have hcnt : (baseEdgesU E (Cobham.fstBlock (pair x (List.replicate e true)))).length + have hcnt : (baseEdgesU E (pairFst (pair x (List.replicate e true)))).length = 3 * (Φ x).length := by - rw [Cobham.fstBlock_pair, baseEdgesU_eq E hE, List.length_replicate] + rw [pairFst_pair, baseEdgesU_eq E hE, List.length_replicate] by_cases hlt : e < (baseCSP (Φ x)).numEdges · have hlt' : e < 3 * (Φ x).length := by rwa [numEdges_baseCSP] at hlt - rw [ifLtLen_pos (by rw [Cobham.sndBlock_pair, List.length_replicate, hcnt]; exact hlt')] + rw [ifLtLen_pos (by rw [pairSnd_pair, List.length_replicate, hcnt]; exact hlt')] rw [ConstraintGraph.tail_padGraph_of_lt _ hlt, ConstraintGraph.head_padGraph_of_lt _ hlt, ConstraintGraph.rel_padGraph_of_lt _ hlt] rw [marks_eq, marks_eq, baseTailU_val E hE h3 x e hlt, baseHeadU_val E hE h3 x e hlt, baseCodeFn_codeKey E hE h3 x e hlt] - · rw [ifLtLen_neg (by rw [Cobham.sndBlock_pair, List.length_replicate, hcnt, + · rw [ifLtLen_neg (by rw [pairSnd_pair, List.length_replicate, hcnt, numEdges_baseCSP] at *; omega)] rw [ConstraintGraph.tail_padGraph_of_ge _ hlt, ConstraintGraph.head_padGraph_of_ge _ hlt, ConstraintGraph.rel_padGraph_of_ge _ hlt, trivCode] diff --git a/Complexitylib/Classes/PCP/Internal/AlgKey.lean b/Complexitylib/Classes/PCP/Internal/AlgKey.lean index 936fb2c5..eeb9e81f 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgKey.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgKey.lean @@ -125,23 +125,23 @@ noncomputable def packKey (k : StepKey E T q B C) : List Bool := /-- The data read back from a string, falling back on a default. -/ noncomputable def keyOfString (dflt : StepKey E T q B C) (s : List Bool) : StepKey E T q B C := - ((decOr dflt.dart (Cobham.fstBlock (Cobham.fstBlock s)).length, - decOr dflt.coins (Cobham.sndBlock (Cobham.fstBlock s)).length), + ((decOr dflt.dart (pairFst (pairFst s)).length, + decOr dflt.coins (pairSnd (pairFst s)).length), ((decOr dflt.par - (Cobham.fstBlock (Cobham.fstBlock (Cobham.sndBlock s))).length, + (pairFst (pairFst (pairSnd s))).length, decOr dflt.code - (Cobham.sndBlock (Cobham.fstBlock (Cobham.sndBlock s))).length), - (decOr dflt.rev (Cobham.fstBlock (Cobham.sndBlock (Cobham.sndBlock s))).length, - (decOr dflt.rand (Cobham.fstBlock (Cobham.sndBlock - (Cobham.sndBlock (Cobham.sndBlock s)))).length, - decOr dflt.read (Cobham.sndBlock (Cobham.sndBlock - (Cobham.sndBlock (Cobham.sndBlock s)))).length)))) + (pairSnd (pairFst (pairSnd s))).length), + (decOr dflt.rev (pairFst (pairSnd (pairSnd s))).length, + (decOr dflt.rand (pairFst (pairSnd + (pairSnd (pairSnd s)))).length, + decOr dflt.read (pairSnd (pairSnd + (pairSnd (pairSnd s)))).length)))) /-- **The reading inverts the writing.** -/ theorem keyOfString_packKey (dflt k : StepKey E T q B C) : keyOfString dflt (packKey k) = k := by rw [keyOfString, packKey] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, decOr_enc] + simp only [pairFst_pair, pairSnd_pair, List.length_replicate, decOr_enc] rfl /-- **A digit sum is a tuple's number**, when the digits are the entries'. -/ diff --git a/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean b/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean index e42d86a7..8db5abdc 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgKeyFn.lean @@ -72,14 +72,14 @@ variable (F : FinBase) (pol : Polynomial ℕ) (r : Round) /-- The test an edge belongs to. -/ noncomputable def testFn (w : List Bool) : List Bool := - divC (r.cZ * 22) (Cobham.sndBlock w) + divC (r.cZ * 22) (pairSnd w) /-- The random string it runs on. -/ noncomputable def randFn (w : List Bool) : List Bool := - divC 22 (modC (r.cZ * 22) (Cobham.sndBlock w)) + divC 22 (modC (r.cZ * 22) (pairSnd w)) /-- The read it asks for. -/ -noncomputable def readFn (w : List Bool) : List Bool := modC 22 (Cobham.sndBlock w) +noncomputable def readFn (w : List Bool) : List Bool := modC 22 (pairSnd w) /-- The killed dart the test is. -/ noncomputable def dartFn (w : List Bool) : List Bool := modC r.cD (testFn r w) @@ -95,11 +95,11 @@ noncomputable def coinFn (w : List Bool) : List Bool := modC r.cQ (dartFn r w) /-- The input the walk algorithm reads. -/ noncomputable def walkArg (w : List Bool) : List Bool := - pair (Cobham.fstBlock w) (pair (vertFn r w) (stepsFn r w)) + pair (pairFst w) (pair (vertFn r w) (stepsFn r w)) /-- The input the killed-walk algorithms read. -/ noncomputable def killArg (w : List Bool) : List Bool := - pair (Cobham.fstBlock w) (pair (vertFn r w) (dartFn r w)) + pair (pairFst w) (pair (vertFn r w) (dartFn r w)) theorem testFn_mem_FP : testFn r ∈ FP := divC_mem_FP Cobham.sndBlock_mem_FP _ @@ -148,14 +148,14 @@ theorem parDigit_mem_FP (i : ℕ) : parDigit F pol r i ∈ FP := /-- The code of the constraint the `i`-th step meets, and `0` past the end. -/ noncomputable def codeDigit (i : ℕ) (w : List Bool) : List Bool := ifLtLen (List.replicate i true) (stopBlk r w) - ((recThd (Cobham.sndBlock (Cobham.fstBlock w)) + ((recThd (pairSnd (pairFst w)) (divC 2 (walkFn F pol r.deg r.P i (walkArg r w))).length).take r.C) [] theorem codeDigit_mem_FP (i : ℕ) : codeDigit F pol r i ∈ FP := by have hwalk : (fun w : List Bool => walkFn F pol r.deg r.P i (walkArg r w)) ∈ FP := mem_FP_of_eq (mem_FP_comp (walkArg_mem_FP r) (walkFn_mem_FP F pol r.deg r.P i)) fun _ => rfl - have hcode : (fun w : List Bool => recThd (Cobham.sndBlock (Cobham.fstBlock w)) + have hcode : (fun w : List Bool => recThd (pairSnd (pairFst w)) (divC 2 (walkFn F pol r.deg r.P i (walkArg r w))).length) ∈ FP := gCodeFn_mem_FP (divC_mem_FP hwalk 2) Cobham.fstBlock_mem_FP refine ifLtLen_mem_FP (constFn_mem_FP _) (stopBlk_mem_FP r) ?_ (constFn_mem_FP []) @@ -207,15 +207,15 @@ theorem blocks_eq (hD : 0 < r.cD) (hZ : 0 < r.cZ) (g : List Bool) (a b c d : ℕ rw [← hre] at h1 h2 h3 have htest : testFn r (pair g (List.replicate (((a * r.cD + b) * r.cZ + c) * 22 + d) true)) = List.replicate (a * r.cD + b) true := by - rw [testFn, Cobham.sndBlock_pair, divC_eq (by positivity), List.length_replicate, h1] + rw [testFn, pairSnd_pair, divC_eq (by positivity), List.length_replicate, h1] refine ⟨htest, ?_, ?_, ?_, ?_⟩ · rw [vertFn, htest, divC_eq hD, List.length_replicate, Nat.add_comm, Nat.add_mul_div_right _ _ hD, Nat.div_eq_of_lt hb, Nat.zero_add] · rw [dartFn, htest, modC_eq hD, List.length_replicate, Nat.add_comm, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hb] - · rw [randFn, Cobham.sndBlock_pair, modC_eq (by positivity), List.length_replicate, + · rw [randFn, pairSnd_pair, modC_eq (by positivity), List.length_replicate, divC_eq (by omega), List.length_replicate, h2] - · rw [readFn, Cobham.sndBlock_pair, modC_eq (by omega), List.length_replicate, h3] + · rw [readFn, pairSnd_pair, modC_eq (by omega), List.length_replicate, h3] /-- **The dart block splits into steps and coins.** -/ theorem steps_coin_eq (hQ : 0 < r.cQ) (w : List Bool) (s t : ℕ) (ht : t < r.cQ) @@ -228,14 +228,14 @@ theorem steps_coin_eq (hQ : 0 < r.cQ) (w : List Bool) (s t : ℕ) (ht : t < r.cQ Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt ht] /-- **The walk's input**, once the blocks are known. -/ -theorem walkArg_eq {w g : List Bool} {a s : ℕ} (hg : Cobham.fstBlock w = g) +theorem walkArg_eq {w g : List Bool} {a s : ℕ} (hg : pairFst w = g) (hv : vertFn r w = List.replicate a true) (hs : stepsFn r w = List.replicate s true) : walkArg r w = pair g (pair (List.replicate a true) (List.replicate s true)) := by rw [walkArg, hg, hv, hs] /-- **The killed walk's input**, likewise. -/ -theorem killArg_eq {w g : List Bool} {a b : ℕ} (hg : Cobham.fstBlock w = g) +theorem killArg_eq {w g : List Bool} {a b : ℕ} (hg : pairFst w = g) (hv : vertFn r w = List.replicate a true) (hb : dartFn r w = List.replicate b true) : killArg r w = pair g (pair (List.replicate a true) (List.replicate b true)) := by @@ -285,14 +285,14 @@ variable {F pol} in theorem stopBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) (v : (G.preprocess (F.toFamily hd)).graph.V) (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) - {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + {w : List Bool} (hg : pairFst w = encGraph G) (hv : vertFn r w = List.replicate (NumEnc.enc v) true) (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) : stopBlk r w = List.replicate ((G.preprocess (F.toFamily hd)).graph.kLen x) true := by have hlt : NumEnc.enc x.2 < r.q ^ r.T := NumEnc.enc_lt x.2 have hxenc : NumEnc.enc x = NumEnc.enc x.1 * r.q ^ r.T + NumEnc.enc x.2 := rfl have hco : coinsOf r.q r.T (killArg r w) = List.replicate (NumEnc.enc x.2) true := by - rw [killArg_eq r hg hv hdart, coinsOf, Cobham.sndBlock_pair, Cobham.sndBlock_pair, + rw [killArg_eq r hg hv hdart, coinsOf, pairSnd_pair, pairSnd_pair, modC_eq (Nat.pow_pos hq), List.length_replicate, hxenc, Nat.add_comm, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hlt] rw [stopBlk, stopFn_eq hq hco r.T 0, ← stopAtNum_eq_stopFromNum, stopAtNum_eq hq x.2] @@ -304,7 +304,7 @@ theorem parBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) (v : (G.preprocess (F.toFamily hd)).graph.V) (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) - {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + {w : List Bool} (hg : pairFst w = encGraph G) (hv : vertFn r w = List.replicate (NumEnc.enc v) true) (hs : stepsFn r w = List.replicate (NumEnc.enc x.1) true) (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) @@ -355,7 +355,7 @@ theorem codeBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) (hC : r.C = Fintype.card (α → α → Bool)) (v : (G.preprocess (F.toFamily hd)).graph.V) (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) - {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + {w : List Bool} (hg : pairFst w = encGraph G) (hv : vertFn r w = List.replicate (NumEnc.enc v) true) (hs : stepsFn r w = List.replicate (NumEnc.enc x.1) true) (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) @@ -425,7 +425,7 @@ theorem revBlk_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) (hdeg : r.deg = (F.toFamily hd).degree) (hP : r.P = G.preDeg (F.toFamily hd)) (v : (G.preprocess (F.toFamily hd)).graph.V) (x : (Fin r.T → (G.preprocess (F.toFamily hd)).graph.D) × (Fin r.T → Fin r.q)) - {w : List Bool} (hg : Cobham.fstBlock w = encGraph G) + {w : List Bool} (hg : pairFst w = encGraph G) (hv : vertFn r w = List.replicate (NumEnc.enc v) true) (hdart : dartFn r w = List.replicate (NumEnc.enc x) true) (hpc : ∀ u : Fin G.numVerts, @@ -496,9 +496,9 @@ theorem keyFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (hq : 0 < r.q) have hxenc : NumEnc.enc x = NumEnc.enc x.1 * r.cQ + NumEnc.enc x.2 := rfl obtain ⟨hs, hc⟩ := steps_coin_eq r (Nat.pow_pos hq) _ (NumEnc.enc x.1) (NumEnc.enc x.2) hclt (by rw [hdart, hxenc]) - have hg : Cobham.fstBlock (pair (encGraph G) (List.replicate + have hg : pairFst (pair (encGraph G) (List.replicate (((NumEnc.enc v * r.cD + NumEnc.enc x) * r.cZ + NumEnc.enc z) * 22 + NumEnc.enc i) true)) - = encGraph G := Cobham.fstBlock_pair _ _ + = encGraph G := pairFst_pair _ _ rw [keyFn, hs, hc, hrand, hread, parBlk_eq r hd G hq hdeg hP v x hg hv hs hdart hpc hpe B z i, codeBlk_eq r hd G hq hdeg hP hC v x hg hv hs hdart hpc hpe B z i, @@ -526,7 +526,7 @@ theorem keyFn_length_le (hQ : 0 < r.cQ) (hD : 0 < r.cD) (hZ : 0 < r.cZ) (hC : 0 have hrand : (randFn r w).length ≤ r.cZ := by rw [randFn, divC_eq (by omega), List.length_replicate, modC_eq (by positivity), List.length_replicate] - have hlt : (Cobham.sndBlock w).length % (r.cZ * 22) < r.cZ * 22 := + have hlt : (pairSnd w).length % (r.cZ * 22) < r.cZ * 22 := Nat.mod_lt _ (by positivity) exact Nat.div_le_of_le_mul (by omega) have hread : (readFn w).length ≤ 22 := by diff --git a/Complexitylib/Classes/PCP/Internal/AlgKilled.lean b/Complexitylib/Classes/PCP/Internal/AlgKilled.lean index 77dabf14..4e8db05d 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgKilled.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgKilled.lean @@ -143,12 +143,12 @@ variable (F : FinBase) (pol : Polynomial ℕ) /-- The vertex a walk reaches after `k` steps, on `pair (graph) (pair (unary vertex) (unary steps))`. -/ noncomputable def walkFn (deg P : ℕ) : ℕ → List Bool → List Bool - | 0, w => Cobham.fstBlock (Cobham.sndBlock w) + | 0, w => pairFst (pairSnd w) | k + 1, w => - Cobham.fstBlock (preRotFn F pol deg - (pair (Cobham.fstBlock w) + pairFst (preRotFn F pol deg + (pair (pairFst w) (pair (walkFn deg P k w) - (modC P (divC (P ^ k) (Cobham.sndBlock (Cobham.sndBlock w))))))) + (modC P (divC (P ^ k) (pairSnd (pairSnd w))))))) theorem walkFn_mem_FP (deg P : ℕ) : ∀ k, walkFn F pol deg P k ∈ FP := by intro k @@ -158,7 +158,7 @@ theorem walkFn_mem_FP (deg P : ℕ) : ∀ k, walkFn F pol deg P k ∈ FP := by fun w => ?_ rw [Function.comp_apply, walkFn] | succ k ih => - have hs : (fun w : List Bool => Cobham.sndBlock (Cobham.sndBlock w)) ∈ FP := + have hs : (fun w : List Bool => pairSnd (pairSnd w)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP have h := mem_FP_comp (Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP (Cobham.pairFn_mem_FP ih (modC_mem_FP (divC_mem_FP hs (P ^ k)) P))) @@ -180,7 +180,7 @@ theorem walkFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (v s : ℕ) intro k induction k with | zero => - rw [walkFn, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + rw [walkFn, pairSnd_pair, pairFst_pair] rfl | succ k ih => have hdig : modC (G.preDeg (F.toFamily hd)) @@ -193,9 +193,9 @@ theorem walkFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (v s : ℕ) < 2 + 2 * (F.toFamily hd).degree := by rw [← G.preDeg_eq (F.toFamily hd)] exact Nat.mod_lt _ hPpos - rw [walkFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.sndBlock_pair, ih, hdig, + rw [walkFn, pairFst_pair, pairSnd_pair, pairSnd_pair, ih, hdig, preRotFn_eq G F pol hd _ _ (G.walkNum_lt _ hv s k) hdlt hpc hpe, - Cobham.fstBlock_pair, ConstraintGraph.walkNum] + pairFst_pair, ConstraintGraph.walkNum] /-! ### Where the walk stops -/ @@ -281,13 +281,13 @@ theorem stopFn_eq {q : ℕ} (hq : 0 < q) {co : List Bool → List Bool} {z : Lis /-- The label the walk's `i`-th step points back along. -/ noncomputable def backFn (deg P i : ℕ) (w : List Bool) : List Bool := - Cobham.sndBlock (preRotFn F pol deg - (pair (Cobham.fstBlock w) + pairSnd (preRotFn F pol deg + (pair (pairFst w) (pair (walkFn F pol deg P i w) - (modC P (divC (P ^ i) (Cobham.sndBlock (Cobham.sndBlock w))))))) + (modC P (divC (P ^ i) (pairSnd (pairSnd w))))))) theorem backFn_mem_FP (deg P i : ℕ) : backFn F pol deg P i ∈ FP := by - have hs : (fun w : List Bool => Cobham.sndBlock (Cobham.sndBlock w)) ∈ FP := + have hs : (fun w : List Bool => pairSnd (pairSnd w)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP have h := mem_FP_comp (Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP (Cobham.pairFn_mem_FP (walkFn_mem_FP F pol deg P i) @@ -319,9 +319,9 @@ theorem backFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (v s i : ℕ) < 2 + 2 * (F.toFamily hd).degree := by rw [← G.preDeg_eq (F.toFamily hd)] exact Nat.mod_lt _ hPpos - rw [backFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.sndBlock_pair, + rw [backFn, pairFst_pair, pairSnd_pair, pairSnd_pair, walkFn_eq F pol hd G v s hv hpc hpe, hdig, - preRotFn_eq G F pol hd _ _ (G.walkNum_lt _ hv s i) hdlt hpc hpe, Cobham.sndBlock_pair] + preRotFn_eq G F pol hd _ _ (G.walkNum_lt _ hv s i) hdlt hpc hpe, pairSnd_pair] /-- The reversed dart's digits, for a fixed stopping index `k`, over the first `n` places. -/ @@ -330,18 +330,18 @@ noncomputable def revSum (deg P k : ℕ) : ℕ → List Bool → List Bool | n + 1, w => revSum deg P k n w ++ mulC (P ^ n) (if n < k then backFn F pol deg P (k - 1 - n) w - else modC P (divC (P ^ n) (Cobham.sndBlock (Cobham.sndBlock w)))) + else modC P (divC (P ^ n) (pairSnd (pairSnd w)))) theorem revSum_mem_FP (deg P k : ℕ) : ∀ n, revSum F pol deg P k n ∈ FP := by intro n induction n with | zero => exact mem_FP_of_eq (constFn_mem_FP []) fun w => by rw [revSum] | succ n ih => - have hs : (fun w : List Bool => Cobham.sndBlock (Cobham.sndBlock w)) ∈ FP := + have hs : (fun w : List Bool => pairSnd (pairSnd w)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP have hterm : (fun w : List Bool => if n < k then backFn F pol deg P (k - 1 - n) w - else modC P (divC (P ^ n) (Cobham.sndBlock (Cobham.sndBlock w)))) ∈ FP := by + else modC P (divC (P ^ n) (pairSnd (pairSnd w)))) ∈ FP := by by_cases h : n < k · simpa [h] using backFn_mem_FP F pol deg P (k - 1 - n) · simpa [h] using modC_mem_FP (divC_mem_FP hs (P ^ n)) P @@ -375,7 +375,7 @@ theorem length_revSum (hd : 1 < F.deg) (G : ConstraintGraph α) (v s k : ℕ) by_cases h : n < k · rw [if_pos h, if_pos h, backFn_eq hd G v s (k - 1 - n) hv hpc hpe, List.length_replicate] - · rw [if_neg h, if_neg h, Cobham.sndBlock_pair, Cobham.sndBlock_pair, + · rw [if_neg h, if_neg h, pairSnd_pair, pairSnd_pair, divC_eq (Nat.pow_pos hPpos), List.length_replicate, modC_eq hPpos] simp @@ -400,13 +400,13 @@ end ConstraintGraph /-- The coins of a killed dart. -/ noncomputable def coinsOf (q T : ℕ) (z : List Bool) : List Bool := - modC (q ^ T) (Cobham.sndBlock (Cobham.sndBlock z)) + modC (q ^ T) (pairSnd (pairSnd z)) /-- A killed dart's steps, in the walk's input format. -/ noncomputable def toWalk (q T : ℕ) (z : List Bool) : List Bool := - pair (Cobham.fstBlock z) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - (divC (q ^ T) (Cobham.sndBlock (Cobham.sndBlock z)))) + pair (pairFst z) + (pair (pairFst (pairSnd z)) + (divC (q ^ T) (pairSnd (pairSnd z)))) theorem coinsOf_mem_FP (q T : ℕ) : coinsOf q T ∈ FP := modC_mem_FP (mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP) _ @@ -482,13 +482,13 @@ theorem revNumFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (T q v s c : ℕ) rw [Nat.add_comm, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hc] have hco : coinsOf q T (pair (encGraph G) (pair (List.replicate v true) (List.replicate (s * q ^ T + c) true))) = List.replicate c true := by - rw [coinsOf, Cobham.sndBlock_pair, Cobham.sndBlock_pair, modC_eq hqT, + rw [coinsOf, pairSnd_pair, pairSnd_pair, modC_eq hqT, List.length_replicate, hmod] have htw : toWalk q T (pair (encGraph G) (pair (List.replicate v true) (List.replicate (s * q ^ T + c) true))) = pair (encGraph G) (pair (List.replicate v true) (List.replicate s true)) := by - rw [toWalk, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, divC_eq hqT, List.length_replicate, hdiv] + rw [toWalk, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair, divC_eq hqT, List.length_replicate, hdiv] have hstop : stopFn q (coinsOf q T) 0 T (pair (encGraph G) (pair (List.replicate v true) (List.replicate (s * q ^ T + c) true))) = List.replicate (stopAtNum T q c) true := by rw [stopFn_eq hq hco T 0, ← stopAtNum_eq_stopFromNum] @@ -518,13 +518,13 @@ theorem killedRotFn_eq (hd : 1 < F.deg) (G : ConstraintGraph α) (T q v s c : rw [Nat.add_comm, Nat.add_mul_mod_self_right, Nat.mod_eq_of_lt hc] have hco : coinsOf q T (pair (encGraph G) (pair (List.replicate v true) (List.replicate (s * q ^ T + c) true))) = List.replicate c true := by - rw [coinsOf, Cobham.sndBlock_pair, Cobham.sndBlock_pair, modC_eq hqT, + rw [coinsOf, pairSnd_pair, pairSnd_pair, modC_eq hqT, List.length_replicate, hmod] have htw : toWalk q T (pair (encGraph G) (pair (List.replicate v true) (List.replicate (s * q ^ T + c) true))) = pair (encGraph G) (pair (List.replicate v true) (List.replicate s true)) := by - rw [toWalk, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, divC_eq hqT, List.length_replicate, hdiv] + rw [toWalk, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair, divC_eq hqT, List.length_replicate, hdiv] have hstop : stopFn q (coinsOf q T) 0 T (pair (encGraph G) (pair (List.replicate v true) (List.replicate (s * q ^ T + c) true))) = List.replicate (stopAtNum T q c) true := by rw [stopFn_eq hq hco T 0, ← stopAtNum_eq_stopFromNum] diff --git a/Complexitylib/Classes/PCP/Internal/AlgLevel.lean b/Complexitylib/Classes/PCP/Internal/AlgLevel.lean index 4378b7e1..22b2be52 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgLevel.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgLevel.lean @@ -49,28 +49,28 @@ def levelAfter (d n : ℕ) : ℕ → ℕ × ℕ → ℕ × ℕ /-- One tick: if the size so far is below twice the request, take another level. The state is `pair (pair (level so far) (size so far)) (the request)`. -/ noncomputable def levelStep (d : ℕ) (st : List Bool) : List Bool := - ifLtLen (Cobham.sndBlock (Cobham.fstBlock st)) - (Cobham.sndBlock st ++ Cobham.sndBlock st) - (pair (pair (Cobham.fstBlock (Cobham.fstBlock st) ++ [true]) - ((marks (mulC d (Cobham.sndBlock (Cobham.fstBlock st)))).take - (List.replicate d true ++ mulC (2 * d) (Cobham.sndBlock st)).length)) - (Cobham.sndBlock st)) + ifLtLen (pairSnd (pairFst st)) + (pairSnd st ++ pairSnd st) + (pair (pair (pairFst (pairFst st) ++ [true]) + ((marks (mulC d (pairSnd (pairFst st)))).take + (List.replicate d true ++ mulC (2 * d) (pairSnd st)).length)) + (pairSnd st)) st theorem levelStep_mem_FP (d : ℕ) : levelStep d ∈ FP := by - have hk : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + have hk : (fun st : List Bool => pairFst (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hs : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + have hs : (fun st : List Bool => pairSnd (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have hn : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hn : (fun st : List Bool => pairSnd st) ∈ FP := Cobham.sndBlock_mem_FP have hbound : (fun st : List Bool => - List.replicate d true ++ mulC (2 * d) (Cobham.sndBlock st)) ∈ FP := + List.replicate d true ++ mulC (2 * d) (pairSnd st)) ∈ FP := Cobham.appendFn_mem_FP (constFn_mem_FP (List.replicate d true)) (mulC_mem_FP hn (2 * d)) have hadv : (fun st : List Bool => - pair (pair (Cobham.fstBlock (Cobham.fstBlock st) ++ [true]) - ((marks (mulC d (Cobham.sndBlock (Cobham.fstBlock st)))).take - (List.replicate d true ++ mulC (2 * d) (Cobham.sndBlock st)).length)) - (Cobham.sndBlock st)) ∈ FP := + pair (pair (pairFst (pairFst st) ++ [true]) + ((marks (mulC d (pairSnd (pairFst st)))).take + (List.replicate d true ++ mulC (2 * d) (pairSnd st)).length)) + (pairSnd st)) ∈ FP := Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hk (constFn_mem_FP [true])) (Cobham.takeLenFn_mem_FP hbound (marks_mem_FP (mulC_mem_FP hs d)))) hn @@ -82,8 +82,8 @@ theorem levelStep_apply (d k s : ℕ) (Z : List Bool) : pair (pair (List.replicate (k + 1) true) (List.replicate (s * d) true)) Z else pair (pair (List.replicate k true) (List.replicate s true)) Z := by set n := Z.length with hn - rw [levelStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair] + rw [levelStep, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair] have hlen : (Z ++ Z).length = 2 * n := by simp only [List.length_append] omega @@ -195,8 +195,8 @@ theorem levelStep_iterate_shape (d : ℕ) (z : List Bool) : omega | succ j ih => obtain ⟨K, S, hst, hK, hS⟩ := ih - rw [Function.iterate_succ_apply', hst, levelStep, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [Function.iterate_succ_apply', hst, levelStep, pairFst_pair, + pairSnd_pair, pairFst_pair, pairSnd_pair] by_cases h : S.length < (z ++ z).length · refine ⟨K ++ [true], (marks (mulC d S)).take (List.replicate d true ++ mulC (2 * d) z).length, ?_, ?_, ?_⟩ @@ -223,7 +223,7 @@ noncomputable def levelWidth (d : ℕ) (p : Polynomial ℕ) : Polynomial ℕ := /-- **The tower level for a requested count**, as one function: run the search for polynomially many ticks and read off the level. -/ noncomputable def levelFn (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : List Bool := - Cobham.fstBlock (Cobham.fstBlock + pairFst (pairFst ((levelStep d)^[(polyRuler p z).length] (pair (pair [] (List.replicate d true)) z))) theorem levelFn_mem_FP (d : ℕ) (p : Polynomial ℕ) : levelFn d p ∈ FP := by @@ -250,7 +250,7 @@ theorem levelFn_mem_FP (d : ℕ) (p : Polynomial ℕ) : levelFn d p ∈ FP := by /-- The size at the level the search reports. -/ noncomputable def sizeFn (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : List Bool := - Cobham.sndBlock (Cobham.fstBlock + pairSnd (pairFst ((levelStep d)^[(polyRuler p z).length] (pair (pair [] (List.replicate d true)) z))) theorem sizeFn_mem_FP (d : ℕ) (p : Polynomial ℕ) : sizeFn d p ∈ FP := by @@ -280,8 +280,8 @@ theorem sizeFn_length (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : (sizeFn d p z).length = d ^ ((levelFn d p z).length + 1) := by have hinit : (pair ([] : List Bool) (List.replicate d true)) = pair (List.replicate 0 true) (List.replicate d true) := rfl - rw [sizeFn, levelFn, hinit, levelStep_iterate d z _ 0 d, Cobham.fstBlock_pair, - Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, List.length_replicate] + rw [sizeFn, levelFn, hinit, levelStep_iterate d z _ 0 d, pairFst_pair, + pairFst_pair, pairSnd_pair, List.length_replicate, List.length_replicate] exact levelAfter_pow d z.length _ /-- **The search finds the first level that is large enough.** -/ @@ -297,7 +297,7 @@ theorem levelFn_length (d : ℕ) (p : Polynomial ℕ) (z : List Bool) (L : ℕ) rw [levelAfter_stable d z.length (0, d) L (by rw [hL']; exact hL) i, hL'] obtain ⟨i, hi⟩ : ∃ i, p.eval z.length = L + i := ⟨p.eval z.length - L, by omega⟩ rw [levelFn, hinit, polyRuler_length, hi, levelStep_iterate d z (L + i) 0 d, hstable i, - Cobham.fstBlock_pair, Cobham.fstBlock_pair, List.length_replicate] + pairFst_pair, pairFst_pair, List.length_replicate] /-- **Whatever level the search reports, its size is bounded** — which is what lets the table at that level be written down. -/ @@ -307,8 +307,8 @@ theorem pow_levelFn_le (d : ℕ) (p : Polynomial ℕ) (z : List Bool) : = pair (List.replicate 0 true) (List.replicate d true) := rfl have hlen : (levelFn d p z).length = (levelAfter d z.length (polyRuler p z).length (0, d)).1 := by - rw [levelFn, hinit, levelStep_iterate d z _ 0 d, Cobham.fstBlock_pair, - Cobham.fstBlock_pair, List.length_replicate] + rw [levelFn, hinit, levelStep_iterate d z _ 0 d, pairFst_pair, + pairFst_pair, List.length_replicate] rw [hlen] exact pow_levelAfter_le d z.length _ diff --git a/Complexitylib/Classes/PCP/Internal/AlgLog.lean b/Complexitylib/Classes/PCP/Internal/AlgLog.lean index dbe56f51..e1407307 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgLog.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgLog.lean @@ -42,21 +42,21 @@ def rulerLen : ℕ → ℕ /-- One step of the ruler fold, on `pair (pair W acc) t` where `acc` is `pair ruler threshold`: on reaching the threshold, add a mark and double. -/ noncomputable def logStep (z : List Bool) : List Bool := - ifLtLen (Cobham.sndBlock z) (dropOne (Cobham.sndBlock (Cobham.sndBlock - (Cobham.fstBlock z)))) - (Cobham.sndBlock (Cobham.fstBlock z)) - (pair (Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock z)) ++ [true]) - (Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock z)) - ++ Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock z)))) + ifLtLen (pairSnd z) (dropOne (pairSnd (pairSnd + (pairFst z)))) + (pairSnd (pairFst z)) + (pair (pairFst (pairSnd (pairFst z)) ++ [true]) + (pairSnd (pairSnd (pairFst z)) + ++ pairSnd (pairSnd (pairFst z)))) theorem logStep_mem_FP : logStep ∈ FP := by - have hacc : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have hacc : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP have hr : (fun z : List Bool => - Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := + pairFst (pairSnd (pairFst z))) ∈ FP := mem_FP_comp hacc Cobham.fstBlock_mem_FP have hth : (fun z : List Bool => - Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := + pairSnd (pairSnd (pairFst z))) ∈ FP := mem_FP_comp hacc Cobham.sndBlock_mem_FP exact ifLtLen_mem_FP Cobham.sndBlock_mem_FP (dropOneFn_mem_FP hth) hacc (Cobham.pairFn_mem_FP (Cobham.appendFn_mem_FP hr (constFn_mem_FP [true])) @@ -178,7 +178,7 @@ theorem logFold_eq (bound : ℕ) : ∀ z : List Bool, 4 * z.length + 4 ≤ bound rw [Cobham.recFoldClamp] simp only [Bool.cond_self] rw [ih hbt, logStep] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, dropOne] + simp only [pairFst_pair, pairSnd_pair, dropOne] have hb' : 4 * t.length + 8 ≤ bound := by simp at hb; omega by_cases h : t.length < 2 ^ rulerLen t.length - 1 · rw [ifLtLen_pos (by simpa using h), List.length_cons, @@ -207,7 +207,7 @@ theorem logFold_eq (bound : ℕ) : ∀ z : List Bool, 4 * z.length + 4 ≤ bound /-- The fold itself, on `pair W z`. -/ noncomputable def logRulerRaw (w : List Bool) : List Bool := Cobham.recFoldClamp logStep logStep (4 * w.length + 4) (pair [] [true]) - (Cobham.fstBlock w) (Cobham.sndBlock w) + (pairFst w) (pairSnd w) theorem logRulerRaw_mem_FP : logRulerRaw ∈ FP := by refine mem_FP_of_eq (Cobham.recFoldClamp_mem_FP logStep_mem_FP logStep_mem_FP @@ -217,7 +217,7 @@ theorem logRulerRaw_mem_FP : logRulerRaw ∈ FP := by /-- **A ruler of logarithmic length.** -/ noncomputable def logRuler (z : List Bool) : List Bool := - Cobham.fstBlock (logRulerRaw (pair [] z)) + pairFst (logRulerRaw (pair [] z)) theorem logRuler_mem_FP : logRuler ∈ FP := mem_FP_of_eq (mem_FP_comp (Cobham.pairFn_mem_FP (constFn_mem_FP []) id_mem_FP) @@ -226,8 +226,8 @@ theorem logRuler_mem_FP : logRuler ∈ FP := /-- **The ruler is as long as the fold says.** -/ theorem logRuler_eq (z : List Bool) : logRuler z = List.replicate (rulerLen z.length) true := by - rw [logRuler, logRulerRaw, Cobham.fstBlock_pair, Cobham.sndBlock_pair, - logFold_eq _ z (by rw [pair_length]; simp), Cobham.fstBlock_pair] + rw [logRuler, logRulerRaw, pairFst_pair, pairSnd_pair, + logFold_eq _ z (by rw [pair_length]; simp), pairFst_pair] @[simp] theorem length_logRuler (z : List Bool) : (logRuler z).length = rulerLen z.length := by diff --git a/Complexitylib/Classes/PCP/Internal/AlgPCP.lean b/Complexitylib/Classes/PCP/Internal/AlgPCP.lean index 53b71df5..835fcd95 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgPCP.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgPCP.lean @@ -147,7 +147,7 @@ theorem exists_pcp_of_mem_NP {L : Language} (hL : L ∈ NP) : fun x => numEdges_gapAlg_eq hgap hEeq h3 hmark hle hq x have ht : (fun x : List Bool => List.replicate (gapCoins q x.length) true) ∈ FP := by have hfp : (fun x : List Bool => - logRuler (posCount (Cobham.sndBlock (gapAll algF algHd E padU x)))) ∈ FP := + logRuler (posCount (pairSnd (gapAll algF algHd E padU x)))) ∈ FP := mem_FP_of_eq (mem_FP_comp (gEdgesFn_mem_FP hgap) logRuler_mem_FP) fun _ => rfl refine mem_FP_of_eq hfp fun x => ?_ have h : gEdges (gapAll algF algHd E padU x) = gapNumEdges q x.length := by diff --git a/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean b/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean index a8f82720..ff222c30 100644 --- a/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean +++ b/Complexitylib/Classes/PCP/Internal/AlgPreRot.lean @@ -45,13 +45,13 @@ namespace Complexity /-- The vertex a half-edge hangs from, on `pair (encoded graph) (unary p)`. -/ noncomputable def ownerFn (z : List Bool) : List Bool := - ifEqLen (modC 2 (Cobham.sndBlock z)) [] - (recSnd (Cobham.sndBlock (Cobham.fstBlock z)) (divC 2 (Cobham.sndBlock z)).length) - (recFst (Cobham.sndBlock (Cobham.fstBlock z)) (divC 2 (Cobham.sndBlock z)).length) + ifEqLen (modC 2 (pairSnd z)) [] + (recSnd (pairSnd (pairFst z)) (divC 2 (pairSnd z)).length) + (recFst (pairSnd (pairFst z)) (divC 2 (pairSnd z)).length) theorem ownerFn_mem_FP : ownerFn ∈ FP := by - have hp : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP - have hG : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have hp : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP + have hG : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_of_eq (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) fun _ => rfl have he := divC_mem_FP hp 2 have hb := modC_mem_FP hp 2 @@ -62,17 +62,17 @@ theorem ownerFn_mem_FP : ownerFn ∈ FP := by /-- One mark when the half-edge `j` hangs from the vertex asked for. The argument is `pair (pair (encoded graph) (unary u)) (unary j)`. -/ noncomputable def cloudMark (w : List Bool) : List Bool := - ifEqLen (ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) - (Cobham.sndBlock (Cobham.fstBlock w)) [true] [] + ifEqLen (ownerFn (pair (pairFst (pairFst w)) (pairSnd w))) + (pairSnd (pairFst w)) [true] [] theorem cloudMark_mem_FP : cloudMark ∈ FP := by - have hG : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + have hG : (fun w : List Bool => pairFst (pairFst w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hu : (fun w : List Bool => Cobham.sndBlock (Cobham.fstBlock w)) ∈ FP := + have hu : (fun w : List Bool => pairSnd (pairFst w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have hj : (fun w : List Bool => Cobham.sndBlock w) ∈ FP := Cobham.sndBlock_mem_FP + have hj : (fun w : List Bool => pairSnd w) ∈ FP := Cobham.sndBlock_mem_FP have hown : (fun w : List Bool => - ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) ∈ FP := by + ownerFn (pair (pairFst (pairFst w)) (pairSnd w))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hj) ownerFn_mem_FP refine mem_FP_of_eq h fun w => ?_ rw [Function.comp_apply] @@ -81,8 +81,8 @@ theorem cloudMark_mem_FP : cloudMark ∈ FP := by theorem length_cloudMark (Gz u j : List Bool) : (cloudMark (pair (pair Gz u) j)).length = if (ownerFn (pair Gz j)).length = u.length then 1 else 0 := by - rw [cloudMark, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair] + rw [cloudMark, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair] by_cases h : (ownerFn (pair Gz j)).length = u.length · rw [ifEqLen_pos h, if_pos h] rfl @@ -93,12 +93,12 @@ theorem length_cloudMark (Gz u j : List Bool) : `pair (encoded graph) (unary u)`. -/ noncomputable def cloudSizeFn (z : List Bool) : List Bool := countOver cloudMark - (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) z) + (pair (marks (mulC 2 (posCount (pairSnd (pairFst z))))) z) theorem cloudSizeFn_mem_FP : cloudSizeFn ∈ FP := by have hcnt : (fun z : List Bool => - marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) ∈ FP := by - have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + marks (mulC 2 (posCount (pairSnd (pairFst z))))) ∈ FP := by + have h1 : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact marks_mem_FP (mulC_mem_FP (posCount_mem_FP h1) 2) have harg := Cobham.pairFn_mem_FP hcnt id_mem_FP @@ -109,13 +109,13 @@ theorem cloudSizeFn_mem_FP : cloudSizeFn ∈ FP := by /-- **The count is the number of half-edges the rule accepts.** -/ theorem length_cloudSizeFn (Gz u : List Bool) (m : ℕ) - (hm : (mulC 2 (posCount (Cobham.sndBlock Gz))).length = m) : + (hm : (mulC 2 (posCount (pairSnd Gz))).length = m) : (cloudSizeFn (pair Gz u)).length = ∑ j ∈ Finset.range m, (if (ownerFn (pair Gz (List.replicate j true))).length = u.length then 1 else 0) := by - have hmarks : marks (mulC 2 (posCount (Cobham.sndBlock Gz))) = List.replicate m true := by + have hmarks : marks (mulC 2 (posCount (pairSnd Gz))) = List.replicate m true := by rw [marks_eq, hm] - rw [cloudSizeFn, Cobham.fstBlock_pair, hmarks, length_countOver] + rw [cloudSizeFn, pairFst_pair, hmarks, length_countOver] refine Finset.sum_congr rfl fun j _ => ?_ rw [length_cloudMark] @@ -123,7 +123,7 @@ theorem length_cloudSizeFn (Gz u : List Bool) (m : ℕ) `pair (encoded graph) (unary p)`. -/ noncomputable def cloudIdxFn (z : List Bool) : List Bool := countOver cloudMark - (pair (marks (Cobham.sndBlock z)) (pair (Cobham.fstBlock z) (ownerFn z))) + (pair (marks (pairSnd z)) (pair (pairFst z) (ownerFn z))) theorem cloudIdxFn_mem_FP : cloudIdxFn ∈ FP := by have hcnt := marks_mem_FP Cobham.sndBlock_mem_FP @@ -139,10 +139,10 @@ theorem length_cloudIdxFn (Gz : List Bool) (p : ℕ) : = ∑ j ∈ Finset.range p, (if (ownerFn (pair Gz (List.replicate j true))).length = (ownerFn (pair Gz (List.replicate p true))).length then 1 else 0) := by - have hmarks : marks (Cobham.sndBlock (pair Gz (List.replicate p true))) + have hmarks : marks (pairSnd (pair Gz (List.replicate p true))) = List.replicate p true := by - rw [Cobham.sndBlock_pair, marks_eq, List.length_replicate] - rw [cloudIdxFn, hmarks, Cobham.fstBlock_pair, length_countOver] + rw [pairSnd_pair, marks_eq, List.length_replicate] + rw [cloudIdxFn, hmarks, pairFst_pair, length_countOver] refine Finset.sum_congr rfl fun j _ => ?_ rw [length_cloudMark] @@ -153,32 +153,32 @@ theorem length_cloudIdxFn (Gz : List Bool) (p : ℕ) : /-- One mark when the half-edge `c` is the `k`-th of the cloud of `u`. The argument is `pair (pair (encoded graph) (pair (unary u) (unary k))) (unary c)`. -/ noncomputable def eltMark (w : List Bool) : List Bool := - ifEqLen (ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) - (Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock w))) - (ifEqLen (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) - (Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock w))) [true] []) + ifEqLen (ownerFn (pair (pairFst (pairFst w)) (pairSnd w))) + (pairFst (pairSnd (pairFst w))) + (ifEqLen (cloudIdxFn (pair (pairFst (pairFst w)) (pairSnd w))) + (pairSnd (pairSnd (pairFst w))) [true] []) [] theorem eltMark_mem_FP : eltMark ∈ FP := by - have hG : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + have hG : (fun w : List Bool => pairFst (pairFst w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hc : (fun w : List Bool => Cobham.sndBlock w) ∈ FP := Cobham.sndBlock_mem_FP + have hc : (fun w : List Bool => pairSnd w) ∈ FP := Cobham.sndBlock_mem_FP have hu : (fun w : List Bool => - Cobham.fstBlock (Cobham.sndBlock (Cobham.fstBlock w))) ∈ FP := + pairFst (pairSnd (pairFst w))) ∈ FP := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) Cobham.fstBlock_mem_FP have hk : (fun w : List Bool => - Cobham.sndBlock (Cobham.sndBlock (Cobham.fstBlock w))) ∈ FP := + pairSnd (pairSnd (pairFst w))) ∈ FP := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) Cobham.sndBlock_mem_FP have harg := Cobham.pairFn_mem_FP hG hc have hown : (fun w : List Bool => - ownerFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) ∈ FP := by + ownerFn (pair (pairFst (pairFst w)) (pairSnd w))) ∈ FP := by have h := mem_FP_comp harg ownerFn_mem_FP refine mem_FP_of_eq h fun w => ?_ rw [Function.comp_apply] have hidx : (fun w : List Bool => - cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w))) ∈ FP := by + cloudIdxFn (pair (pairFst (pairFst w)) (pairSnd w))) ∈ FP := by have h := mem_FP_comp harg cloudIdxFn_mem_FP refine mem_FP_of_eq h fun w => ?_ rw [Function.comp_apply] @@ -191,8 +191,8 @@ theorem length_eltMark (Gz u k c : List Bool) : = if (ownerFn (pair Gz c)).length = u.length then (if (cloudIdxFn (pair Gz c)).length = k.length then 1 else 0) else 0 := by - rw [eltMark, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [eltMark, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair, pairFst_pair, pairSnd_pair] by_cases h1 : (ownerFn (pair Gz c)).length = u.length · rw [ifEqLen_pos h1, if_pos h1] by_cases h2 : (cloudIdxFn (pair Gz c)).length = k.length @@ -207,7 +207,7 @@ theorem length_eltMark (Gz u k c : List Bool) : `pair (encoded graph) (pair (unary u) (unary k))`. -/ noncomputable def cloudEltFn (z : List Bool) : List Bool := findFirst eltMark - (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) z) + (pair (marks (mulC 2 (posCount (pairSnd (pairFst z))))) z) theorem cloudEltFn_eq_replicate (z : List Bool) : cloudEltFn z = List.replicate (cloudEltFn z).length true := by @@ -215,7 +215,7 @@ theorem cloudEltFn_eq_replicate (z : List Bool) : rw [← cloudEltFn] theorem cloudEltFn_mem_FP : cloudEltFn ∈ FP := by - have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h1 : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP have hcnt := marks_mem_FP (mulC_mem_FP (posCount_mem_FP h1) 2) have h := mem_FP_comp (Cobham.pairFn_mem_FP hcnt id_mem_FP) @@ -234,17 +234,17 @@ theorem ownerFn_eq (G : ConstraintGraph α) (p : ℕ) (hp : p / 2 < G.numEdges) rw [divC_eq (by norm_num), List.length_replicate] have hmod : (modC 2 (List.replicate p true)) = List.replicate (p % 2) true := by rw [modC_eq (by norm_num), List.length_replicate] - rw [ownerFn, Cobham.sndBlock_pair, Cobham.fstBlock_pair, hdiv, hmod, + rw [ownerFn, pairSnd_pair, pairFst_pair, hdiv, hmod, List.length_replicate, ConstraintGraph.ownerNum, dif_pos hp] by_cases h : p % 2 = 0 · rw [if_pos h, ifEqLen_pos (by rw [h]; rfl)] - rw [encGraph, Cobham.sndBlock_pair, + rw [encGraph, pairSnd_pair, recSnd_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact hp) (getElem_edgeRecs G _ hp)] · rw [if_neg h, ifEqLen_neg (by rw [List.length_replicate, List.length_nil] exact h)] - rw [encGraph, Cobham.sndBlock_pair, + rw [encGraph, pairSnd_pair, recFst_eq (l3 := edgeRecs G) (by rw [length_edgeRecs]; exact hp) (getElem_edgeRecs G _ hp)] @@ -328,8 +328,8 @@ end ConstraintGraph variable (G : ConstraintGraph α) theorem length_count_encGraph : - (mulC 2 (posCount (Cobham.sndBlock (encGraph G)))).length = 2 * G.numEdges := by - rw [encGraph, Cobham.sndBlock_pair, posCount_eq, length_mulC, List.length_replicate, + (mulC 2 (posCount (pairSnd (encGraph G)))).length = 2 * G.numEdges := by + rw [encGraph, pairSnd_pair, posCount_eq, length_mulC, List.length_replicate, length_edgeRecs] ring @@ -385,10 +385,10 @@ theorem length_cloudEltFn_eq (v : Fin G.numVerts) (k : ℕ) have hcount : countBelow (G.cloudCodes v) (G.halfCode q) = k := by rw [← G.idxOf_cloudList howner, hidx] have hclt : G.halfCode q < 2 * G.numEdges := halfCode_lt G q - have hmarks : marks (mulC 2 (posCount (Cobham.sndBlock (encGraph G)))) + have hmarks : marks (mulC 2 (posCount (pairSnd (encGraph G)))) = List.replicate (2 * G.numEdges) true := by rw [marks_eq, length_count_encGraph] - rw [cloudEltFn, Cobham.fstBlock_pair, hmarks] + rw [cloudEltFn, pairFst_pair, hmarks] refine length_findFirst_eq hclt ?_ ?_ · have howner' : G.ownerNum (G.halfCode q) = v.val := by rw [← ConstraintGraph.enc_halfEdge, ConstraintGraph.ownerNum_enc, howner] @@ -444,58 +444,58 @@ variable (F : FinBase) (pol : Polynomial ℕ) half-edge the new index names. -/ noncomputable def cloudStepFn (z : List Bool) : List Bool := pair - (cloudEltFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (pair (Cobham.sndBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (F.famRotFn pol - (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)))) - (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (Cobham.sndBlock z)))) - (Cobham.sndBlock (Cobham.sndBlock z))))))))) - (Cobham.sndBlock (F.famRotFn pol - (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)))) - (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (Cobham.sndBlock z)))) - (Cobham.sndBlock (Cobham.sndBlock z)))))) + (cloudEltFn (pair (pairFst (pairFst z)) + (pair (pairSnd (pairFst z)) + (pairFst (F.famRotFn pol + (pair (cloudSizeFn (pair (pairFst (pairFst z)) + (pairSnd (pairFst z)))) + (pair (cloudIdxFn (pair (pairFst (pairFst z)) + (pairFst (pairSnd z)))) + (pairSnd (pairSnd z))))))))) + (pairSnd (F.famRotFn pol + (pair (cloudSizeFn (pair (pairFst (pairFst z)) + (pairSnd (pairFst z)))) + (pair (cloudIdxFn (pair (pairFst (pairFst z)) + (pairFst (pairSnd z)))) + (pairSnd (pairSnd z)))))) theorem cloudStepFn_mem_FP : cloudStepFn F pol ∈ FP := by - have hG : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := + have hG : (fun z : List Bool => pairFst (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hu : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have hu : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have hc : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := + have hc : (fun z : List Bool => pairFst (pairSnd z)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP - have hj : (fun z : List Bool => Cobham.sndBlock (Cobham.sndBlock z)) ∈ FP := + have hj : (fun z : List Bool => pairSnd (pairSnd z)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP - have hsize : (fun z : List Bool => cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)))) ∈ FP := by + have hsize : (fun z : List Bool => cloudSizeFn (pair (pairFst (pairFst z)) + (pairSnd (pairFst z)))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hu) cloudSizeFn_mem_FP refine mem_FP_of_eq h fun w => ?_ rw [Function.comp_apply] - have hidx : (fun z : List Bool => cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (Cobham.sndBlock z)))) ∈ FP := by + have hidx : (fun z : List Bool => cloudIdxFn (pair (pairFst (pairFst z)) + (pairFst (pairSnd z)))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hc) cloudIdxFn_mem_FP refine mem_FP_of_eq h fun w => ?_ rw [Function.comp_apply] have hy : (fun z : List Bool => F.famRotFn pol - (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)))) - (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (Cobham.sndBlock z)))) - (Cobham.sndBlock (Cobham.sndBlock z))))) ∈ FP := by + (pair (cloudSizeFn (pair (pairFst (pairFst z)) + (pairSnd (pairFst z)))) + (pair (cloudIdxFn (pair (pairFst (pairFst z)) + (pairFst (pairSnd z)))) + (pairSnd (pairSnd z))))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hsize (Cobham.pairFn_mem_FP hidx hj)) (F.famRotFn_mem_FP pol) refine mem_FP_of_eq h fun w => ?_ rw [Function.comp_apply] - have helt : (fun z : List Bool => cloudEltFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (pair (Cobham.sndBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (F.famRotFn pol - (pair (cloudSizeFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)))) - (pair (cloudIdxFn (pair (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.fstBlock (Cobham.sndBlock z)))) - (Cobham.sndBlock (Cobham.sndBlock z))))))))) ∈ FP := by + have helt : (fun z : List Bool => cloudEltFn (pair (pairFst (pairFst z)) + (pair (pairSnd (pairFst z)) + (pairFst (F.famRotFn pol + (pair (cloudSizeFn (pair (pairFst (pairFst z)) + (pairSnd (pairFst z)))) + (pair (cloudIdxFn (pair (pairFst (pairFst z)) + (pairFst (pairSnd z)))) + (pairSnd (pairSnd z))))))))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hG (Cobham.pairFn_mem_FP hu (mem_FP_comp hy Cobham.fstBlock_mem_FP))) cloudEltFn_mem_FP refine mem_FP_of_eq h fun w => ?_ @@ -508,11 +508,11 @@ theorem cloudStepFn_mem_FP : cloudStepFn F pol ∈ FP := by /-- The expander move, on `pair (graph) (pair (unary vertex) (unary dart))`. -/ noncomputable def expStepFn (z : List Bool) : List Bool := F.famRotFn pol - (pair (marks (mulC 2 (posCount (Cobham.sndBlock (Cobham.fstBlock z))))) - (Cobham.sndBlock z)) + (pair (marks (mulC 2 (posCount (pairSnd (pairFst z))))) + (pairSnd z)) theorem expStepFn_mem_FP : expStepFn F pol ∈ FP := by - have h1 : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h1 : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP have hcnt := marks_mem_FP (mulC_mem_FP (posCount_mem_FP h1) 2) have h := mem_FP_comp (Cobham.pairFn_mem_FP hcnt Cobham.sndBlock_mem_FP) @@ -584,9 +584,9 @@ theorem cloudStepFn_eq (hd : 1 < F.deg) (v : Fin G.numVerts) (c j : ℕ) conv_lhs => rw [cloudEltFn_eq_replicate] rw [length_cloudEltFn_eq G v _ (Fin.isLt _)] rw [cloudStepFn] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] rw [hsize, hidx, hrot] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] rw [helt, ConstraintGraph.cloudStepNum, dif_pos hidxlt] dsimp only rw [← G.halfCode_getElem_cloudList v _ (Fin.isLt _)] @@ -598,10 +598,10 @@ theorem expStepFn_eq (hd : 1 < F.deg) (v j : ℕ) (hn : 0 < 2 * G.numEdges) (pair (List.replicate v true) (List.replicate j true))) = pair (List.replicate (F.famRotVal hd (2 * G.numEdges) (v, j)).1 true) (List.replicate (F.famRotVal hd (2 * G.numEdges) (v, j)).2 true) := by - have hmarks : marks (mulC 2 (posCount (Cobham.sndBlock (encGraph G)))) + have hmarks : marks (mulC 2 (posCount (pairSnd (encGraph G)))) = List.replicate (2 * G.numEdges) true := by rw [marks_eq, length_count_encGraph] - rw [expStepFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hmarks] + rw [expStepFn, pairFst_pair, pairSnd_pair, hmarks] exact F.famRotFn_eq pol hd _ v j hn hp /-! ### The whole rotation map -/ @@ -631,66 +631,66 @@ theorem flipFn_eq (v : ℕ) : dart `1` crosses the edge, the next `deg` are the cloud's, and the rest are the superposed expander's. -/ noncomputable def preRotFn (deg : ℕ) (z : List Bool) : List Bool := - ifEqLen (Cobham.sndBlock (Cobham.sndBlock z)) [] - (pair (Cobham.fstBlock (Cobham.sndBlock z)) []) - (ifEqLen (Cobham.sndBlock (Cobham.sndBlock z)) [true] - (pair (flipFn (Cobham.fstBlock (Cobham.sndBlock z))) [true]) - (ifLtLen (Cobham.sndBlock (Cobham.sndBlock z)) (List.replicate (2 + deg) true) + ifEqLen (pairSnd (pairSnd z)) [] + (pair (pairFst (pairSnd z)) []) + (ifEqLen (pairSnd (pairSnd z)) [true] + (pair (flipFn (pairFst (pairSnd z))) [true]) + (ifLtLen (pairSnd (pairSnd z)) (List.replicate (2 + deg) true) (pair - (Cobham.fstBlock (cloudStepFn F pol - (pair (pair (Cobham.fstBlock z) - (ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z))))) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop 2))))) - (Cobham.sndBlock (cloudStepFn F pol - (pair (pair (Cobham.fstBlock z) - (ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z))))) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop 2)))) ++ [true, true])) + (pairFst (cloudStepFn F pol + (pair (pair (pairFst z) + (ownerFn (pair (pairFst z) (pairFst (pairSnd z))))) + (pair (pairFst (pairSnd z)) + ((pairSnd (pairSnd z)).drop 2))))) + (pairSnd (cloudStepFn F pol + (pair (pair (pairFst z) + (ownerFn (pair (pairFst z) (pairFst (pairSnd z))))) + (pair (pairFst (pairSnd z)) + ((pairSnd (pairSnd z)).drop 2)))) ++ [true, true])) (pair - (Cobham.fstBlock (expStepFn F pol - (pair (Cobham.fstBlock z) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg)))))) - (Cobham.sndBlock (expStepFn F pol - (pair (Cobham.fstBlock z) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg))))) + (pairFst (expStepFn F pol + (pair (pairFst z) + (pair (pairFst (pairSnd z)) + ((pairSnd (pairSnd z)).drop (2 + deg)))))) + (pairSnd (expStepFn F pol + (pair (pairFst z) + (pair (pairFst (pairSnd z)) + ((pairSnd (pairSnd z)).drop (2 + deg))))) ++ List.replicate (2 + deg) true)))) theorem preRotFn_mem_FP (deg : ℕ) : preRotFn F pol deg ∈ FP := by - have hG : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hv : (fun z : List Bool => Cobham.fstBlock (Cobham.sndBlock z)) ∈ FP := + have hG : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hv : (fun z : List Bool => pairFst (pairSnd z)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.fstBlock_mem_FP - have hd : (fun z : List Bool => Cobham.sndBlock (Cobham.sndBlock z)) ∈ FP := + have hd : (fun z : List Bool => pairSnd (pairSnd z)) ∈ FP := mem_FP_comp Cobham.sndBlock_mem_FP Cobham.sndBlock_mem_FP - have hd2 : (fun z : List Bool => (Cobham.sndBlock (Cobham.sndBlock z)).drop 2) ∈ FP := by + have hd2 : (fun z : List Bool => (pairSnd (pairSnd z)).drop 2) ∈ FP := by have := dropLenFn_mem_FP (constFn_mem_FP (List.replicate 2 true)) hd refine mem_FP_of_eq this fun w => ?_ rw [List.length_replicate] have hdk : (fun z : List Bool => - (Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg)) ∈ FP := by + (pairSnd (pairSnd z)).drop (2 + deg)) ∈ FP := by have := dropLenFn_mem_FP (constFn_mem_FP (List.replicate (2 + deg) true)) hd refine mem_FP_of_eq this fun w => ?_ rw [List.length_replicate] have hown : (fun z : List Bool => - ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z)))) ∈ FP := by + ownerFn (pair (pairFst z) (pairFst (pairSnd z)))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hG hv) ownerFn_mem_FP refine mem_FP_of_eq h fun w => ?_ simp only [Function.comp_apply] have hcs : (fun z : List Bool => cloudStepFn F pol - (pair (pair (Cobham.fstBlock z) - (ownerFn (pair (Cobham.fstBlock z) (Cobham.fstBlock (Cobham.sndBlock z))))) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop 2)))) ∈ FP := by + (pair (pair (pairFst z) + (ownerFn (pair (pairFst z) (pairFst (pairSnd z))))) + (pair (pairFst (pairSnd z)) + ((pairSnd (pairSnd z)).drop 2)))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hG hown) (Cobham.pairFn_mem_FP hv hd2)) (cloudStepFn_mem_FP F pol) refine mem_FP_of_eq h fun w => ?_ simp only [Function.comp_apply] have hes : (fun z : List Bool => expStepFn F pol - (pair (Cobham.fstBlock z) - (pair (Cobham.fstBlock (Cobham.sndBlock z)) - ((Cobham.sndBlock (Cobham.sndBlock z)).drop (2 + deg))))) ∈ FP := by + (pair (pairFst z) + (pair (pairFst (pairSnd z)) + ((pairSnd (pairSnd z)).drop (2 + deg))))) ∈ FP := by have h := mem_FP_comp (Cobham.pairFn_mem_FP hG (Cobham.pairFn_mem_FP hv hdk)) (expStepFn_mem_FP F pol) refine mem_FP_of_eq h fun w => ?_ @@ -727,7 +727,7 @@ theorem preRotFn_eq (hd : 1 < F.deg) (v d : ℕ) (hv : v < 2 * G.numEdges) rw [ConstraintGraph.ownerNum, dif_pos hvd] split <;> exact Fin.isLt _ rw [preRotFn] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] rw [ConstraintGraph.preRotNum] by_cases h0 : d = 0 · subst h0 @@ -748,7 +748,7 @@ theorem preRotFn_eq (hd : 1 < F.deg) (v d : ℕ) (hv : v < 2 * G.numEdges) cloudStepFn_eq G F pol hd ⟨G.ownerNum v, hulr⟩ v (d - 2) hv rfl hjlt (hpc ⟨G.ownerNum v, hulr⟩)] rw [ConstraintGraph.cloudStepN, dif_pos hulr, dif_pos hjlt] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] have happ : ∀ n : ℕ, List.replicate n true ++ [true, true] = List.replicate (n + 2) true := by intro n @@ -774,7 +774,7 @@ theorem preRotFn_eq (hd : 1 < F.deg) (v d : ℕ) (hv : v < 2 * G.numEdges) rw [ifLtLen_neg (by simpa using h2), if_neg h2, hdropk, expStepFn_eq G F pol hd v (d - (2 + (F.toFamily hd).degree)) hne hpe] rw [ConstraintGraph.expStepN, dif_pos hvlt, dif_pos hjlt] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] have hk := key _ horder hvlt hjlt have hk1 := congrArg Prod.fst hk have hk2 := congrArg Prod.snd hk diff --git a/Complexitylib/Classes/PCP/Internal/BaseAlg.lean b/Complexitylib/Classes/PCP/Internal/BaseAlg.lean index 55a26c38..d0625313 100644 --- a/Complexitylib/Classes/PCP/Internal/BaseAlg.lean +++ b/Complexitylib/Classes/PCP/Internal/BaseAlg.lean @@ -86,21 +86,21 @@ theorem baseMaxU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) /-- The unary form of the first endpoint: the clause vertex. -/ noncomputable def baseTailU (w : List Bool) : List Bool := - baseMaxU E (Cobham.fstBlock w) ++ [true] - ++ List.replicate (divFn [false, false, false] (Cobham.sndBlock w)).length true + baseMaxU E (pairFst w) ++ [true] + ++ List.replicate (divFn [false, false, false] (pairSnd w)).length true /-- The unary form of the second endpoint: the variable vertex. -/ noncomputable def baseHeadU (w : List Bool) : List Bool := - slotVar (pair (E (Cobham.fstBlock w)) (Cobham.sndBlock w)) + slotVar (pair (E (pairFst w)) (pairSnd w)) theorem baseTailU_mem_FP (hE : E ∈ FP) : baseTailU E ∈ FP := by - have hm : (fun w => baseMaxU E (Cobham.fstBlock w)) ∈ FP := by + have hm : (fun w => baseMaxU E (pairFst w)) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (baseMaxU_mem_FP E hE) refine mem_FP_of_eq this fun w => ?_ rw [Function.comp_apply] have hd : (fun w : List Bool => - List.replicate (divFn [false, false, false] (Cobham.sndBlock w)).length true) ∈ FP := by - have h1 : (fun w : List Bool => divFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + List.replicate (divFn [false, false, false] (pairSnd w)).length true) ∈ FP := by + have h1 : (fun w : List Bool => divFn [false, false, false] (pairSnd w)) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP (divFn_mem_FP [false, false, false]) refine mem_FP_of_eq this fun w => ?_ rw [Function.comp_apply] @@ -110,7 +110,7 @@ theorem baseTailU_mem_FP (hE : E ∈ FP) : baseTailU E ∈ FP := by exact Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP hm (constFn_mem_FP [true])) hd theorem baseHeadU_mem_FP (hE : E ∈ FP) : baseHeadU E ∈ FP := by - have hp : (fun w => pair (E (Cobham.fstBlock w)) (Cobham.sndBlock w)) ∈ FP := by + have hp : (fun w => pair (E (pairFst w)) (pairSnd w)) ∈ FP := by refine Cobham.pairFn_mem_FP ?_ Cobham.sndBlock_mem_FP have := mem_FP_comp Cobham.fstBlock_mem_FP hE refine mem_FP_of_eq this fun w => ?_ @@ -125,7 +125,7 @@ theorem baseTailU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF (Φ x)) (x : List Bool) (e : ℕ) : (baseTailU E (pair x (List.replicate e true))).length = ((Φ x).maxVar + 1) + e / 3 := by - rw [baseTailU, Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_append, + rw [baseTailU, pairFst_pair, pairSnd_pair, List.length_append, List.length_append, List.length_replicate, List.length_singleton, divFn_eq (by simp) (List.replicate e true), List.length_replicate, List.length_replicate, baseMaxU_eq E hE h3] @@ -139,7 +139,7 @@ theorem baseHeadU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) have hp : e % 3 < ((Φ x)[e / 3]'hj).length := by rw [h3 x _ (List.getElem_mem hj)] omega - rw [baseHeadU, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hE, + rw [baseHeadU, pairFst_pair, pairSnd_pair, hE, slotVar_eq (Φ x) hj hp rfl rfl] congr 1 rw [litOf, List.getElem?_eq_getElem hj] @@ -151,8 +151,8 @@ theorem baseHeadU_eq {Φ : List Bool → CNF} (hE : ∀ x, E x = (Φ x).encode) /-- The three literal signs of the clause an edge belongs to. -/ noncomputable def baseSigns (z : List Bool) : List Bool := - let j := divFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z)) - let x := Cobham.fstBlock (Cobham.fstBlock z) + let j := divFn [false, false, false] (pairSnd (pairFst z)) + let x := pairFst (pairFst z) litSignFn (pair (pair j []) (E x)) ++ litSignFn (pair (pair j [true]) (E x)) ++ litSignFn (pair (pair j [true, true]) (E x)) @@ -161,24 +161,24 @@ noncomputable def baseSigns (z : List Bool) : List Bool := inside the clause, and the two symbol blocks. -/ noncomputable def baseKey (w : ℕ) (z : List Bool) : List Bool := pair (pair (baseSigns E z) - (modFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z)))) - ((Cobham.sndBlock z).take (2 * w)) + (modFn [false, false, false] (pairSnd (pairFst z)))) + ((pairSnd z).take (2 * w)) theorem baseSigns_mem_FP (hE : E ∈ FP) : baseSigns E ∈ FP := by - have hx : (fun z : List Bool => E (Cobham.fstBlock (Cobham.fstBlock z))) ∈ FP := by + have hx : (fun z : List Bool => E (pairFst (pairFst z))) ∈ FP := by have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP) hE refine mem_FP_of_eq this fun z => ?_ rw [Function.comp_apply, Function.comp_apply] have hj : (fun z : List Bool => - divFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := by + divFn [false, false, false] (pairSnd (pairFst z))) ∈ FP := by have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) (divFn_mem_FP [false, false, false]) refine mem_FP_of_eq this fun z => ?_ rw [Function.comp_apply, Function.comp_apply] have hsign : ∀ c : List Bool, (fun z : List Bool => litSignFn (pair (pair (divFn [false, false, false] - (Cobham.sndBlock (Cobham.fstBlock z))) c) - (E (Cobham.fstBlock (Cobham.fstBlock z))))) ∈ FP := by + (pairSnd (pairFst z))) c) + (E (pairFst (pairFst z))))) ∈ FP := by intro c have := mem_FP_comp (Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hj (constFn_mem_FP c)) hx) litSignFn_mem_FP @@ -189,12 +189,12 @@ theorem baseSigns_mem_FP (hE : E ∈ FP) : baseSigns E ∈ FP := by theorem baseKey_mem_FP (hE : E ∈ FP) (w : ℕ) : baseKey E w ∈ FP := by have hm : (fun z : List Bool => - modFn [false, false, false] (Cobham.sndBlock (Cobham.fstBlock z))) ∈ FP := by + modFn [false, false, false] (pairSnd (pairFst z))) ∈ FP := by have := mem_FP_comp (mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP) (modFn_mem_FP [false, false, false]) refine mem_FP_of_eq this fun z => ?_ rw [Function.comp_apply, Function.comp_apply] - have ht : (fun z : List Bool => (Cobham.sndBlock z).take (2 * w)) ∈ FP := by + have ht : (fun z : List Bool => (pairSnd z).take (2 * w)) ∈ FP := by have := Cobham.takeLenFn_mem_FP (constFn_mem_FP (List.replicate (2 * w) false)) Cobham.sndBlock_mem_FP refine mem_FP_of_eq this fun z => ?_ @@ -210,24 +210,24 @@ theorem length_baseSigns_le (z : List Bool) : (baseSigns E z).length ≤ 3 := by · split <;> simp rw [baseSigns, List.length_append, List.length_append] have h1 := hs (pair (pair (divFn [false, false, false] - (Cobham.sndBlock (Cobham.fstBlock z))) []) (E (Cobham.fstBlock (Cobham.fstBlock z)))) + (pairSnd (pairFst z))) []) (E (pairFst (pairFst z)))) have h2 := hs (pair (pair (divFn [false, false, false] - (Cobham.sndBlock (Cobham.fstBlock z))) [true]) (E (Cobham.fstBlock (Cobham.fstBlock z)))) + (pairSnd (pairFst z))) [true]) (E (pairFst (pairFst z)))) have h3 := hs (pair (pair (divFn [false, false, false] - (Cobham.sndBlock (Cobham.fstBlock z))) [true, true]) - (E (Cobham.fstBlock (Cobham.fstBlock z)))) + (pairSnd (pairFst z))) [true, true]) + (E (pairFst (pairFst z)))) omega theorem length_baseKey_le (w : ℕ) (z : List Bool) : (baseKey E w z).length ≤ 2 * w + 22 := by have hs := length_baseSigns_le E z have hm : (modFn [false, false, false] - (Cobham.sndBlock (Cobham.fstBlock z))).length ≤ 2 := by + (pairSnd (pairFst z))).length ≤ 2 := by rw [modFn_eq (by simp)] simp only [List.length_replicate, show ([false, false, false] : List Bool).length = 3 from rfl] omega - have ht : ((Cobham.sndBlock z).take (2 * w)).length ≤ 2 * w := by + have ht : ((pairSnd z).take (2 * w)).length ≤ 2 * w := by rw [List.length_take] omega rw [baseKey, pair_length, pair_length] @@ -241,10 +241,10 @@ name symbols in the image of the alphabet embedding whose preimages satisfy the clause and agree on the checked position. -/ noncomputable def baseOkKey (w : ℕ) (k : List Bool) : Prop := ∃ a₁ a₂ : Fin 3 → Bool, - alphaEmb a₁ = symDec GapAlpha ((Cobham.sndBlock k).take w) ∧ - alphaEmb a₂ = symDec GapAlpha ((Cobham.sndBlock k).drop w) ∧ - (∃ q : Fin 3, a₁ q = (Cobham.fstBlock (Cobham.fstBlock k)).getD q.val false) ∧ - a₁ ⟨(Cobham.sndBlock (Cobham.fstBlock k)).length % 3, + alphaEmb a₁ = symDec GapAlpha ((pairSnd k).take w) ∧ + alphaEmb a₂ = symDec GapAlpha ((pairSnd k).drop w) ∧ + (∃ q : Fin 3, a₁ q = (pairFst (pairFst k)).getD q.val false) ∧ + a₁ ⟨(pairSnd (pairFst k)).length % 3, Nat.mod_lt _ (by omega)⟩ = a₂ 0 /-- The constraint, as a language on the verifier's verdict argument. -/ @@ -270,12 +270,12 @@ noncomputable def baseAlg (hE : E ∈ FP) : AlgCSP where (baseTailU E (pair x (List.replicate e true))).length vert_mem := by intro b - have hu : (fun w : List Bool => List.replicate (Cobham.sndBlock w).length true) ∈ FP := by + have hu : (fun w : List Bool => List.replicate (pairSnd w).length true) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP refine mem_FP_of_eq this fun w => ?_ rw [Function.comp_apply] have harg : (fun w : List Bool => - pair (Cobham.fstBlock w) (List.replicate (Cobham.sndBlock w).length true)) ∈ FP := + pair (pairFst w) (List.replicate (pairSnd w).length true)) ∈ FP := Cobham.pairFn_mem_FP Cobham.fstBlock_mem_FP hu cases b · have := mem_FP_comp (mem_FP_comp harg (baseTailU_mem_FP E hE)) unaryLength_mem_FP @@ -401,7 +401,7 @@ theorem baseSigns_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF rw [hlen] exact q.isLt rw [hE, litSignFn_encode (Φ x) hj hq, litOf_eq (Φ x) hj q hq] - rw [baseSigns, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + rw [baseSigns, pairFst_pair, pairSnd_pair, pairFst_pair, divFn_eq (by simp) (List.replicate e true), List.length_replicate, show ([false, false, false] : List Bool).length = 3 from rfl] have h0 : litSignFn (pair (pair (List.replicate (e / 3) true) []) (E x)) @@ -419,8 +419,8 @@ theorem baseKey_pair (hE : ∀ x, E x = (Φ x).encode) (h3 : ∀ x, CNF.Is3CNF ( baseKey E 23 (pair (pair x (List.replicate e true)) a) = pair (pair [(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, (litOf (Φ x) (e / 3) 2).sign] (List.replicate (e % 3) true)) a := by - rw [baseKey, baseSigns_pair E hE h3 x he a, Cobham.fstBlock_pair, Cobham.sndBlock_pair, - Cobham.sndBlock_pair, modFn_eq (by simp) (List.replicate e true), + rw [baseKey, baseSigns_pair E hE h3 x he a, pairFst_pair, pairSnd_pair, + pairSnd_pair, modFn_eq (by simp) (List.replicate e true), List.length_replicate, show ([false, false, false] : List Bool).length = 3 from rfl, List.take_of_length_le (by omega)] @@ -447,7 +447,7 @@ theorem baseAlg_ok_iff (hE' : E ∈ FP) (hE : ∀ x, E x = (Φ x).encode) rw [baseKey_pair E hE h3 x he' ha] show _ ↔ (ConstraintGraph.lift (toGraph (Φ x)) alphaEmb).rel ⟨e, he⟩ _ _ = true rw [ConstraintGraph.rel_lift, decide_eq_true_iff] - simp only [baseOkKey, Cobham.sndBlock_pair, Cobham.fstBlock_pair, htake, hdrop, + simp only [baseOkKey, pairSnd_pair, pairFst_pair, htake, hdrop, List.length_replicate, hmod] have hsign : ∀ q : Fin 3, ([(litOf (Φ x) (e / 3) 0).sign, (litOf (Φ x) (e / 3) 1).sign, diff --git a/Complexitylib/Classes/PCP/Internal/BinToUnary.lean b/Complexitylib/Classes/PCP/Internal/BinToUnary.lean index fdd21801..bd77eaeb 100644 --- a/Complexitylib/Classes/PCP/Internal/BinToUnary.lean +++ b/Complexitylib/Classes/PCP/Internal/BinToUnary.lean @@ -35,26 +35,26 @@ namespace Complexity /-- Reading a zero: the value doubles. -/ def binDbl (z : List Bool) : List Bool := - Cobham.sndBlock (Cobham.fstBlock z) ++ Cobham.sndBlock (Cobham.fstBlock z) + pairSnd (pairFst z) ++ pairSnd (pairFst z) /-- Reading a one: the value doubles and gains one. -/ def binDblOne (z : List Bool) : List Bool := - Cobham.sndBlock (Cobham.fstBlock z) ++ Cobham.sndBlock (Cobham.fstBlock z) ++ [true] + pairSnd (pairFst z) ++ pairSnd (pairFst z) ++ [true] theorem binDbl_mem_FP : binDbl ∈ FP := by - have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact Cobham.appendFn_mem_FP h h theorem binDblOne_mem_FP : binDblOne ∈ FP := by - have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact Cobham.appendFn_mem_FP (Cobham.appendFn_mem_FP h h) (constFn_mem_FP [true]) /-- **The value of a bit string, in unary**, computed on `pair anything bits`. -/ def unaryVal (p : Polynomial ℕ) (z : List Bool) : List Bool := - Cobham.recFoldClamp binDbl binDblOne (p.eval z.length) [] (Cobham.fstBlock z) - (Cobham.sndBlock z) + Cobham.recFoldClamp binDbl binDblOne (p.eval z.length) [] (pairFst z) + (pairSnd z) theorem unaryVal_mem_FP (p : Polynomial ℕ) : unaryVal p ∈ FP := Cobham.recFoldClamp_mem_FP binDbl_mem_FP binDblOne_mem_FP (constFn_mem_FP []) p @@ -88,10 +88,10 @@ theorem recFoldClamp_binValLE (bound : ℕ) (W : List Bool) : have : (b :: l).length = l.length + 1 := by simp omega rw [Cobham.recFoldClamp, ih hb'] - have hstate : Cobham.sndBlock (Cobham.fstBlock + have hstate : pairSnd (pairFst (pair (pair W (List.replicate (binValLE l) true)) l)) = List.replicate (binValLE l) true := by - rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [pairFst_pair, pairSnd_pair] cases b with | false => show (binDbl _).take bound = _ @@ -112,8 +112,8 @@ theorem recFoldClamp_binValLE (bound : ℕ) (W : List Bool) : /-- **The conversion is exact** when the clamp is wide enough for the value. -/ theorem unaryVal_eq {p : Polynomial ℕ} {z : List Bool} - (h : 2 ^ (Cobham.sndBlock z).length ≤ p.eval z.length) : - unaryVal p z = List.replicate (binValLE (Cobham.sndBlock z)) true := + (h : 2 ^ (pairSnd z).length ≤ p.eval z.length) : + unaryVal p z = List.replicate (binValLE (pairSnd z)) true := recFoldClamp_binValLE _ _ _ h end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean b/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean index dc14b58c..623c8500 100644 --- a/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean +++ b/Complexitylib/Classes/PCP/Internal/BitwiseFP.lean @@ -51,17 +51,17 @@ open Cobham length and append the bit it returns. The state is `pair (output so far) input`. -/ def bitStep (G : List Bool → List Bool) (z : List Bool) : List Bool := - pair (fstBlock z ++ G (pair (sndBlock z) (List.replicate (fstBlock z).length true))) - (sndBlock z) + pair (pairFst z ++ G (pair (pairSnd z) (List.replicate (pairFst z).length true))) + (pairSnd z) theorem bitStep_mem_FP {G : List Bool → List Bool} (hG : G ∈ FP) : bitStep G ∈ FP := by - have hfst : (fun z : List Bool => fstBlock z) ∈ FP := fstBlock_mem_FP - have hsnd : (fun z : List Bool => sndBlock z) ∈ FP := sndBlock_mem_FP - have hcnt : (fun z : List Bool => List.replicate (fstBlock z).length true) ∈ FP := by + have hfst : (fun z : List Bool => pairFst z) ∈ FP := fstBlock_mem_FP + have hsnd : (fun z : List Bool => pairSnd z) ∈ FP := sndBlock_mem_FP + have hcnt : (fun z : List Bool => List.replicate (pairFst z).length true) ∈ FP := by have := mem_FP_comp hfst unaryLength_mem_FP simpa using this have hquery : (fun z : List Bool => - G (pair (sndBlock z) (List.replicate (fstBlock z).length true))) ∈ FP := by + G (pair (pairSnd z) (List.replicate (pairFst z).length true))) ∈ FP := by have := mem_FP_comp (pairFn_mem_FP hsnd hcnt) hG simpa using this exact pairFn_mem_FP (appendFn_mem_FP hfst hquery) hsnd @@ -74,7 +74,7 @@ theorem bitStep_iterate {G : List Bool → List Bool} {b : List Bool → ℕ → induction n with | zero => simp | succ n ih => - rw [Function.iterate_succ_apply', ih, bitStep, fstBlock_pair, sndBlock_pair, + rw [Function.iterate_succ_apply', ih, bitStep, pairFst_pair, pairSnd_pair, List.length_map, List.length_range, hGspec, List.range_succ, List.map_append] simp @@ -102,7 +102,7 @@ theorem bitwise_mem_FP {len : List Bool → ℕ} {b : List Bool → ℕ → Bool have := mem_FP_comp hiter fstBlock_mem_FP refine mem_FP_of_eq this ?_ intro x - rw [Function.comp_apply, List.length_replicate, bitStep_iterate hGspec, fstBlock_pair] + rw [Function.comp_apply, List.length_replicate, bitStep_iterate hGspec, pairFst_pair] /-- **The same, from a language in `P`.** The bit rule is usually established as a decision problem — "does position `i` of the output carry a one?" — and this diff --git a/Complexitylib/Classes/PCP/Internal/CNFCount.lean b/Complexitylib/Classes/PCP/Internal/CNFCount.lean index c7ef9f6f..1bce435b 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFCount.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFCount.lean @@ -53,31 +53,31 @@ theorem selectHead_cons (b : Bool) (t x y : List Bool) : is `pair count unread`. -/ def ccStep (z : List Bool) : List Bool := pair - (Cobham.selectHead (emptyFlag (Cobham.sndBlock z)) (Cobham.fstBlock z) - (Cobham.selectHead (Cobham.sndBlock z) - (Cobham.selectHead (dropOne (Cobham.sndBlock z)) (Cobham.fstBlock z) - (true :: Cobham.fstBlock z)) - (Cobham.fstBlock z))) - (dropOne (dropOne (Cobham.sndBlock z))) + (Cobham.selectHead (emptyFlag (pairSnd z)) (pairFst z) + (Cobham.selectHead (pairSnd z) + (Cobham.selectHead (dropOne (pairSnd z)) (pairFst z) + (true :: pairFst z)) + (pairFst z))) + (dropOne (dropOne (pairSnd z))) theorem ccStep_mem_FP : ccStep ∈ FP := by - have hc : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hs : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP - have hd : (fun z : List Bool => dropOne (Cobham.sndBlock z)) ∈ FP := dropOneFn_mem_FP hs + have hc : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hs : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP + have hd : (fun z : List Bool => dropOne (pairSnd z)) ∈ FP := dropOneFn_mem_FP hs refine Cobham.pairFn_mem_FP ?_ (dropOneFn_mem_FP hd) refine Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP hs) hc ?_ exact Cobham.selectHeadFn_mem_FP hs (Cobham.selectHeadFn_mem_FP hd hc (mem_FP_comp hc (Cobham.cons_mem_FP true))) hc @[simp] theorem ccStep_nil (c : List Bool) : ccStep (pair c []) = pair c [] := by - rw [ccStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair, emptyFlag_nil, + rw [ccStep, pairFst_pair, pairSnd_pair, emptyFlag_nil, selectHead_cons_true] rfl theorem ccStep_cons₂ (c : List Bool) (b0 b1 : Bool) (r : List Bool) : ccStep (pair c (b0 :: b1 :: r)) = pair (if b0 = true ∧ b1 = false then true :: c else c) r := by - rw [ccStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair, emptyFlag_cons, + rw [ccStep, pairFst_pair, pairSnd_pair, emptyFlag_cons, selectHead_cons_false] cases b0 · rw [selectHead_cons] @@ -134,7 +134,7 @@ theorem ccStep_iterate : ∀ (k : ℕ) (c s : List Bool), s.length ≤ 2 * k → theorem ccStep_one (c s : List Bool) : ∃ X Y, ccStep (pair c s) = pair X Y ∧ X.length ≤ c.length + 1 ∧ Y.length ≤ s.length := by - rw [ccStep, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [ccStep, pairFst_pair, pairSnd_pair] refine ⟨_, _, rfl, ?_, ?_⟩ · refine le_trans (length_selectHead_le _ _ _) ?_ simp only [max_le_iff] @@ -163,7 +163,7 @@ theorem ccStep_shape : ∀ (k : ℕ) (c s : List Bool), /-- **The clause count**, in unary. -/ noncomputable def clauseCountFn (z : List Bool) : List Bool := - Cobham.fstBlock (ccStep^[z.length] (pair [] z)) + pairFst (ccStep^[z.length] (pair [] z)) theorem clauseCountFn_mem_FP : clauseCountFn ∈ FP := by have hinit : (fun z : List Bool => pair [] z) ∈ FP := @@ -187,7 +187,7 @@ theorem clauseCountFn_mem_FP : clauseCountFn ∈ FP := by theorem clauseCountFn_eq {z : List Bool} (h : Even z.length) : clauseCountFn z = List.replicate (sepCount z) true := by - rw [clauseCountFn, ccStep_iterate z.length [] z (by omega) h, Cobham.fstBlock_pair] + rw [clauseCountFn, ccStep_iterate z.length [] z (by omega) h, pairFst_pair] simp end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean b/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean index 3107dbdc..6036db59 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFMaxVar.lean @@ -102,17 +102,17 @@ theorem exists_slot_eq_maxVar (φ : CNF) (h3 : CNF.Is3CNF φ) (h : 0 < φ.length /-- The variable index at a flat slot, read off the encoding. -/ noncomputable def slotVar (w : List Bool) : List Bool := - litVarFn (pair (pair (divFn [false, false, false] (Cobham.sndBlock w)) - (modFn [false, false, false] (Cobham.sndBlock w))) (Cobham.fstBlock w)) + litVarFn (pair (pair (divFn [false, false, false] (pairSnd w)) + (modFn [false, false, false] (pairSnd w))) (pairFst w)) theorem slotVar_mem_FP : slotVar ∈ FP := by - have hs : (fun w : List Bool => Cobham.sndBlock w) ∈ FP := Cobham.sndBlock_mem_FP - have hf : (fun w : List Bool => Cobham.fstBlock w) ∈ FP := Cobham.fstBlock_mem_FP - have hd : (fun w : List Bool => divFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + have hs : (fun w : List Bool => pairSnd w) ∈ FP := Cobham.sndBlock_mem_FP + have hf : (fun w : List Bool => pairFst w) ∈ FP := Cobham.fstBlock_mem_FP + have hd : (fun w : List Bool => divFn [false, false, false] (pairSnd w)) ∈ FP := by have := mem_FP_comp hs (divFn_mem_FP [false, false, false]) refine mem_FP_of_eq this fun w => ?_ rw [Function.comp_apply] - have hm : (fun w : List Bool => modFn [false, false, false] (Cobham.sndBlock w)) ∈ FP := by + have hm : (fun w : List Bool => modFn [false, false, false] (pairSnd w)) ∈ FP := by have := mem_FP_comp hs (modFn_mem_FP [false, false, false]) refine mem_FP_of_eq this fun w => ?_ rw [Function.comp_apply] @@ -123,7 +123,7 @@ theorem slotVar_mem_FP : slotVar ∈ FP := by theorem slotVar_eq (φ : CNF) {i j p : ℕ} (hj : j < φ.length) (hp : p < (φ[j]'hj).length) (hdj : i / 3 = j) (hdp : i % 3 = p) : (slotVar (pair φ.encode (List.replicate i true))).length = ((φ[j]'hj)[p]'hp).var := by - rw [slotVar, Cobham.sndBlock_pair, Cobham.fstBlock_pair, + rw [slotVar, pairSnd_pair, pairFst_pair, divFn_eq (by simp) (List.replicate i true), modFn_eq (by simp) (List.replicate i true)] simp only [List.length_replicate, show ([false, false, false] : List Bool).length = 3 from rfl, hdj, hdp] diff --git a/Complexitylib/Classes/PCP/Internal/CNFSegment.lean b/Complexitylib/Classes/PCP/Internal/CNFSegment.lean index cf834dbe..12f9383f 100644 --- a/Complexitylib/Classes/PCP/Internal/CNFSegment.lean +++ b/Complexitylib/Classes/PCP/Internal/CNFSegment.lean @@ -50,16 +50,16 @@ theorem segFrom_cons₂ (s0 s1 : Bool) (t c : ℕ) (b0 b1 : Bool) (r : List Bool else if c = t then b0 :: b1 :: segFrom s0 s1 t c r else segFrom s0 s1 t c r := rfl /-- The target index carried by the state. -/ -def segTgt (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock z) +def segTgt (z : List Bool) : List Bool := pairFst (pairFst z) /-- The number of separators already passed. -/ -def segCnt (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock z) +def segCnt (z : List Bool) : List Bool := pairSnd (pairFst z) /-- The tokens collected so far. -/ -def segColl (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.sndBlock z) +def segColl (z : List Bool) : List Bool := pairFst (pairSnd z) /-- The unread suffix. -/ -def segRest (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.sndBlock z) +def segRest (z : List Bool) : List Bool := pairSnd (pairSnd z) /-- Does the string begin with the bit `b`, as a flag? -/ def matchBit (b : Bool) (s : List Bool) : List Bool := @@ -136,7 +136,7 @@ variable (s0 s1 : Bool) @[simp] theorem segStep_nil (tgt cnt coll : List Bool) : segStep s0 s1 (pair (pair tgt cnt) (pair coll [])) = pair (pair tgt cnt) (pair coll []) := by have hr : segRest (pair (pair tgt cnt) (pair coll [])) = [] := by - rw [segRest, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + rw [segRest, pairSnd_pair, pairSnd_pair] rw [segStep, hr, emptyFlag_nil, selectHead_cons_true] theorem segStep_cons₂ (tgt cnt coll : List Bool) (b0 b1 : Bool) (r : List Bool) : @@ -146,13 +146,13 @@ theorem segStep_cons₂ (tgt cnt coll : List Bool) (b0 b1 : Bool) (r : List Bool else pair (pair tgt cnt) (pair (if cnt.length = tgt.length then coll ++ [b0, b1] else coll) r) := by have hr : segRest (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = b0 :: b1 :: r := by - rw [segRest, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + rw [segRest, pairSnd_pair, pairSnd_pair] have ht : segTgt (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = tgt := by - rw [segTgt, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + rw [segTgt, pairFst_pair, pairFst_pair] have hc : segCnt (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = cnt := by - rw [segCnt, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [segCnt, pairFst_pair, pairSnd_pair] have hl : segColl (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = coll := by - rw [segColl, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + rw [segColl, pairSnd_pair, pairFst_pair] have hsep : segIsSep s0 s1 (pair (pair tgt cnt) (pair coll (b0 :: b1 :: r))) = if b0 = s0 ∧ b1 = s1 then [true] else [false] := by rw [segIsSep, hr] @@ -192,7 +192,7 @@ theorem segStep_iterate : ∀ (k : ℕ) (tgt cnt coll s : List Bool), intro tgt cnt coll s hs _ have : s = [] := List.eq_nil_of_length_eq_zero (by omega) subst this - rw [Function.iterate_zero_apply, segColl, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + rw [Function.iterate_zero_apply, segColl, pairSnd_pair, pairFst_pair] simp | succ k ih => intro tgt cnt coll s hs hev @@ -262,13 +262,13 @@ theorem segStep_one (tgt cnt coll s : List Bool) : ∧ cnt'.length ≤ cnt.length + 1 ∧ coll'.length ≤ coll.length + 2 ∧ s'.length ≤ s.length := by have hr : segRest (pair (pair tgt cnt) (pair coll s)) = s := by - rw [segRest, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + rw [segRest, pairSnd_pair, pairSnd_pair] have ht : segTgt (pair (pair tgt cnt) (pair coll s)) = tgt := by - rw [segTgt, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + rw [segTgt, pairFst_pair, pairFst_pair] have hc : segCnt (pair (pair tgt cnt) (pair coll s)) = cnt := by - rw [segCnt, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [segCnt, pairFst_pair, pairSnd_pair] have hl : segColl (pair (pair tgt cnt) (pair coll s)) = coll := by - rw [segColl, Cobham.sndBlock_pair, Cobham.fstBlock_pair] + rw [segColl, pairSnd_pair, pairFst_pair] match s with | [] => exact ⟨cnt, coll, [], segStep_nil s0 s1 tgt cnt coll, by omega, by omega, le_refl _⟩ @@ -309,27 +309,27 @@ theorem segStep_shape : ∀ (k : ℕ) (tgt cnt coll s : List Bool), /-- **The packaged extraction**, on `pair (unary index) encoding`. -/ noncomputable def segAtFn (s0 s1 : Bool) (z : List Bool) : List Bool := - segColl ((segStep s0 s1)^[(Cobham.sndBlock z).length] - (pair (pair (Cobham.fstBlock z) []) (pair [] (Cobham.sndBlock z)))) + segColl ((segStep s0 s1)^[(pairSnd z).length] + (pair (pair (pairFst z) []) (pair [] (pairSnd z)))) theorem segAtFn_mem_FP : segAtFn s0 s1 ∈ FP := by - have hf : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hs : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have hf : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hs : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP have hinit : (fun z : List Bool => - pair (pair (Cobham.fstBlock z) []) (pair [] (Cobham.sndBlock z))) ∈ FP := + pair (pair (pairFst z) []) (pair [] (pairSnd z))) ∈ FP := Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hf (constFn_mem_FP [])) (Cobham.pairFn_mem_FP (constFn_mem_FP []) hs) have hwidth : (fun z : List Bool => polyRuler (Polynomial.C 11 * Polynomial.X + Polynomial.C 8) (id z)) ∈ FP := polyRulerFn_mem_FP _ id_mem_FP - have hbound : ∀ z : List Bool, ∀ k ≤ (Cobham.sndBlock z).length, + have hbound : ∀ z : List Bool, ∀ k ≤ (pairSnd z).length, ((segStep s0 s1)^[k] - (pair (pair (Cobham.fstBlock z) []) (pair [] (Cobham.sndBlock z)))).length + (pair (pair (pairFst z) []) (pair [] (pairSnd z)))).length ≤ (polyRuler (Polynomial.C 11 * Polynomial.X + Polynomial.C 8) (id z)).length := by intro z k hk obtain ⟨cnt', coll', s', h1, hc, hl, hss⟩ := - segStep_shape s0 s1 k (Cobham.fstBlock z) [] [] (Cobham.sndBlock z) - have hfz : (Cobham.fstBlock z).length ≤ z.length := fstBlock_length_le z - have hsz : (Cobham.sndBlock z).length ≤ z.length := sndBlock_length_le z + segStep_shape s0 s1 k (pairFst z) [] [] (pairSnd z) + have hfz : (pairFst z).length ≤ z.length := fstBlock_length_le z + have hsz : (pairSnd z).length ≤ z.length := sndBlock_length_le z rw [h1, pair_length, pair_length, pair_length, polyRuler_length] simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * @@ -340,7 +340,7 @@ theorem segAtFn_mem_FP : segAtFn s0 s1 ∈ FP := by theorem segAtFn_eq {j : ℕ} {e : List Bool} (h : Even e.length) : segAtFn s0 s1 (pair (List.replicate j true) e) = segFrom s0 s1 j 0 e := by - rw [segAtFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + rw [segAtFn, pairFst_pair, pairSnd_pair, segStep_iterate s0 s1 e.length _ _ _ e (by omega) h, List.length_replicate, List.length_nil] simp @@ -351,17 +351,17 @@ theorem segAtFn_eq {j : ℕ} {e : List Bool} (h : Even e.length) : `pair (pair (unary j) (unary p)) encoding`. -/ noncomputable def litSegFn (z : List Bool) : List Bool := segAtFn false true - (pair (Cobham.sndBlock (Cobham.fstBlock z)) - (segAtFn true false (pair (Cobham.fstBlock (Cobham.fstBlock z)) (Cobham.sndBlock z)))) + (pair (pairSnd (pairFst z)) + (segAtFn true false (pair (pairFst (pairFst z)) (pairSnd z)))) theorem litSegFn_mem_FP : litSegFn ∈ FP := by - have hj : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := + have hj : (fun z : List Bool => pairFst (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hp : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have hp : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have he : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP + have he : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP have hcl : (fun z : List Bool => segAtFn true false - (pair (Cobham.fstBlock (Cobham.fstBlock z)) (Cobham.sndBlock z))) ∈ FP := by + (pair (pairFst (pairFst z)) (pairSnd z))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hj he) (segAtFn_mem_FP true false) simpa only using this have := mem_FP_comp (Cobham.pairFn_mem_FP hp hcl) (segAtFn_mem_FP false true) @@ -370,8 +370,8 @@ theorem litSegFn_mem_FP : litSegFn ∈ FP := by theorem litSegFn_eq {j p : ℕ} {e : List Bool} (h : Even e.length) : litSegFn (pair (pair (List.replicate j true) (List.replicate p true)) e) = segFrom false true p 0 (segFrom true false j 0 e) := by - rw [litSegFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, segAtFn_eq true false h, + rw [litSegFn, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair, segAtFn_eq true false h, segAtFn_eq false true (even_length_segFrom true false j e.length e 0 (le_refl _) h)] /-- The variable a literal names, in unary. -/ diff --git a/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean b/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean index 867c0ab3..dbd2a9ec 100644 --- a/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean +++ b/Complexitylib/Classes/PCP/Internal/CSPVerifier.lean @@ -53,7 +53,7 @@ structure AlgCSP where vert : Bool → List Bool → ℕ → ℕ /-- The endpoints are polynomial-time computable in unary. -/ vert_mem : ∀ b, (fun w : List Bool => List.replicate - (vert b (Cobham.fstBlock w) (Cobham.sndBlock w).length) true) ∈ FP + (vert b (pairFst w) (pairSnd w).length) true) ∈ FP /-- The constraint, on `pair (pair x (unary e)) (the two symbol blocks)`. -/ ok : Language /-- The constraint is polynomial-time decidable. -/ @@ -64,7 +64,7 @@ namespace AlgCSP variable (A : AlgCSP) (p : Polynomial ℕ) /-- The edge a coin string names. -/ -def edgeIdx (z : List Bool) : ℕ := binValLE (Cobham.sndBlock z) +def edgeIdx (z : List Bool) : ℕ := binValLE (pairSnd z) /-- That index in unary, as far as the clamp allows. -/ noncomputable def edgeU (z : List Bool) : List Bool := unaryVal p z @@ -72,24 +72,24 @@ noncomputable def edgeU (z : List Bool) : List Bool := unaryVal p z theorem edgeU_mem_FP : edgeU p ∈ FP := unaryVal_mem_FP p theorem edgeU_eq {z : List Bool} - (h : 2 ^ (Cobham.sndBlock z).length ≤ p.eval z.length) : + (h : 2 ^ (pairSnd z).length ≤ p.eval z.length) : edgeU p z = List.replicate (edgeIdx z) true := unaryVal_eq h /-- Is the named edge a real one? -/ noncomputable def inRange (z : List Bool) : List Bool := - Cobham.lenLeFlag (List.replicate (A.numEdges (Cobham.fstBlock z)) true) + Cobham.lenLeFlag (List.replicate (A.numEdges (pairFst z)) true) (true :: edgeU p z) theorem inRange_mem_FP : A.inRange p ∈ FP := by have hn : (fun z : List Bool => - List.replicate (A.numEdges (Cobham.fstBlock z)) true) ∈ FP := by + List.replicate (A.numEdges (pairFst z)) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP A.numEdges_mem simpa using this exact lenLeFlagFn_mem_FP hn (mem_FP_comp (edgeU_mem_FP p) (Cobham.cons_mem_FP true)) theorem inRange_eq_true_iff {z : List Bool} - (h : 2 ^ (Cobham.sndBlock z).length ≤ p.eval z.length) : - A.inRange p z = [true] ↔ edgeIdx z < A.numEdges (Cobham.fstBlock z) := by + (h : 2 ^ (pairSnd z).length ≤ p.eval z.length) : + A.inRange p z = [true] ↔ edgeIdx z < A.numEdges (pairFst z) := by rw [inRange, edgeU_eq p h, Cobham.lenLeFlag_eq_true_iff, List.length_cons, List.length_replicate, List.length_replicate] @@ -109,34 +109,34 @@ theorem cntU_mem_FP : A.cntU p ∈ FP := /-- The endpoint a query index refers to: the first for the low half of the queries, the second for the high half. -/ noncomputable def vertU (b : Bool) (w : List Bool) : List Bool := - List.replicate (A.vert b (Cobham.fstBlock (Cobham.fstBlock w)) - (edgeU p (Cobham.fstBlock w)).length) true + List.replicate (A.vert b (pairFst (pairFst w)) + (edgeU p (pairFst w)).length) true theorem vertU_mem_FP (b : Bool) : A.vertU p b ∈ FP := by - have hx : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + have hx : (fun w : List Bool => pairFst (pairFst w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have he : (fun w : List Bool => edgeU p (Cobham.fstBlock w)) ∈ FP := + have he : (fun w : List Bool => edgeU p (pairFst w)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP (edgeU_mem_FP p) have := mem_FP_comp (Cobham.pairFn_mem_FP hx he) (A.vert_mem b) refine mem_FP_of_eq this fun w => ?_ - rw [vertU, Function.comp_apply, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [vertU, Function.comp_apply, pairFst_pair, pairSnd_pair] /-- Is this query in the low half? -/ def lowFlag (w : List Bool) : List Bool := - Cobham.lenLeFlag (List.replicate A.width true) (true :: Cobham.sndBlock w) + Cobham.lenLeFlag (List.replicate A.width true) (true :: pairSnd w) theorem lowFlag_mem_FP : A.lowFlag ∈ FP := lenLeFlagFn_mem_FP (constFn_mem_FP (List.replicate A.width true)) (mem_FP_comp Cobham.sndBlock_mem_FP (Cobham.cons_mem_FP true)) theorem lowFlag_eq_true_iff (w : List Bool) : - A.lowFlag w = [true] ↔ (Cobham.sndBlock w).length < A.width := by + A.lowFlag w = [true] ↔ (pairSnd w).length < A.width := by rw [lowFlag, Cobham.lenLeFlag_eq_true_iff, List.length_cons, List.length_replicate] omega /-- The offset inside the symbol block. -/ def offU (w : List Bool) : List Bool := - Cobham.selectHead (A.lowFlag w) (Cobham.sndBlock w) ((Cobham.sndBlock w).drop A.width) + Cobham.selectHead (A.lowFlag w) (pairSnd w) ((pairSnd w).drop A.width) theorem offU_mem_FP : A.offU ∈ FP := by refine Cobham.selectHeadFn_mem_FP A.lowFlag_mem_FP Cobham.sndBlock_mem_FP ?_ @@ -174,7 +174,7 @@ theorem posU_mem_FP : A.posU p ∈ FP := by theorem cntU_eq_replicate (z : List Bool) : A.cntU p z = List.replicate (A.cntU p z).length true := by rw [cntU] - rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges (Cobham.fstBlock z)) true) + rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges (pairFst z)) true) (true :: edgeU p z) with h | h <;> rw [inRange, h] · rw [selectHead_cons_true, List.length_replicate] · rw [selectHead_cons_false] @@ -196,48 +196,48 @@ noncomputable def pos (z : List Bool) (i : ℕ) : ℕ := /-- The argument the constraint is asked about. -/ noncomputable def okArg (z : List Bool) : List Bool := - pair (pair (Cobham.fstBlock (Cobham.fstBlock z)) (edgeU p (Cobham.fstBlock z))) - (Cobham.sndBlock z) + pair (pair (pairFst (pairFst z)) (edgeU p (pairFst z))) + (pairSnd z) theorem okArg_mem_FP : okArg p ∈ FP := by - have hx : (fun z : List Bool => Cobham.fstBlock (Cobham.fstBlock z)) ∈ FP := + have hx : (fun z : List Bool => pairFst (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have he : (fun z : List Bool => edgeU p (Cobham.fstBlock z)) ∈ FP := + have he : (fun z : List Bool => edgeU p (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP (edgeU_mem_FP p) exact Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP hx he) Cobham.sndBlock_mem_FP /-- The verdict: accept unless the coin string names a real edge whose constraint fails. -/ noncomputable def verdictLang : Language := - {z | A.inRange p (Cobham.fstBlock z) = [true] → okArg p z ∈ A.ok} + {z | A.inRange p (pairFst z) = [true] → okArg p z ∈ A.ok} theorem verdictLang_mem_P : A.verdictLang p ∈ P := by obtain ⟨g, hgFP, hg⟩ := exists_decisionFn_of_mem_P A.ok_mem - have hin : (fun z : List Bool => A.inRange p (Cobham.fstBlock z)) ∈ FP := by + have hin : (fun z : List Bool => A.inRange p (pairFst z)) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (A.inRange_mem_FP p) simpa using this have hok : (fun z : List Bool => [g (okArg p z)]) ∈ FP := by have := mem_FP_comp (okArg_mem_FP p) hgFP simpa using this have hflag : (fun z : List Bool => - Cobham.selectHead (A.inRange p (Cobham.fstBlock z)) [g (okArg p z)] [true]) ∈ FP := + Cobham.selectHead (A.inRange p (pairFst z)) [g (okArg p z)] [true]) ∈ FP := Cobham.selectHeadFn_mem_FP hin hok (constFn_mem_FP [true]) refine mem_P_of_decisionFn hflag fun z => ?_ - show (A.inRange p (Cobham.fstBlock z) = [true] → okArg p z ∈ A.ok) ↔ _ + show (A.inRange p (pairFst z) = [true] → okArg p z ∈ A.ok) ↔ _ rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges - (Cobham.fstBlock (Cobham.fstBlock z))) true) - (true :: edgeU p (Cobham.fstBlock z)) with h | h - · have hv : A.inRange p (Cobham.fstBlock z) = [true] := by rw [inRange]; exact h + (pairFst (pairFst z))) true) + (true :: edgeU p (pairFst z)) with h | h + · have hv : A.inRange p (pairFst z) = [true] := by rw [inRange]; exact h rw [hv, selectHead_cons_true] simp only [List.mem_singleton, exists_eq_left, forall_const] exact hg _ - · have hv : A.inRange p (Cobham.fstBlock z) = [false] := by rw [inRange]; exact h + · have hv : A.inRange p (pairFst z) = [false] := by rw [inRange]; exact h rw [hv, selectHead_cons_false] simp theorem cnt_le (z : List Bool) : A.cnt p z ≤ 2 * A.width := by rw [cnt, cntU] - rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges (Cobham.fstBlock z)) true) + rcases Cobham.lenLeFlag_flag (List.replicate (A.numEdges (pairFst z)) true) (true :: edgeU p z) with h | h <;> rw [inRange, h] · rw [selectHead_cons_true, List.length_replicate] · rw [selectHead_cons_false] @@ -270,7 +270,7 @@ theorem verifier_queryBounded : (A.verifier p).QueryBounded (fun _ => 2 * A.widt theorem mem_verdict_verifier (z : List Bool) : z ∈ (A.verifier p).verdict - ↔ (A.inRange p (Cobham.fstBlock z) = [true] → okArg p z ∈ A.ok) := Iff.rfl + ↔ (A.inRange p (pairFst z) = [true] → okArg p z ∈ A.ok) := Iff.rfl /-! ### What the verifier reads and decides -/ @@ -280,16 +280,16 @@ def posVal (x : List Bool) (e i : ℕ) : ℕ := theorem pos_eq {x ρ : List Bool} (h : 2 ^ ρ.length ≤ p.eval (pair x ρ).length) (i : ℕ) : A.pos p (pair x ρ) i = A.posVal x (binValLE ρ) i := by - have hz : Cobham.sndBlock (pair x ρ) = ρ := Cobham.sndBlock_pair x ρ + have hz : pairSnd (pair x ρ) = ρ := pairSnd_pair x ρ have hE : edgeU p (pair x ρ) = List.replicate (binValLE ρ) true := by have := edgeU_eq (p := p) (z := pair x ρ) (by rw [hz]; exact h) rw [this, edgeIdx, hz] set w := pair (pair x ρ) (List.replicate i true) with hw - have hsnd : Cobham.sndBlock w = List.replicate i true := Cobham.sndBlock_pair _ _ - have hfst : Cobham.fstBlock w = pair x ρ := Cobham.fstBlock_pair _ _ + have hsnd : pairSnd w = List.replicate i true := pairSnd_pair _ _ + have hfst : pairFst w = pair x ρ := pairFst_pair _ _ have hlow : A.lowFlag w = if i < A.width then [true] else [false] := by rcases Cobham.lenLeFlag_flag (List.replicate A.width true) - (true :: Cobham.sndBlock w) with hf | hf + (true :: pairSnd w) with hf | hf · rw [lowFlag, hf, if_pos] rw [← lowFlag, A.lowFlag_eq_true_iff w, hsnd, List.length_replicate] at hf exact hf @@ -301,7 +301,7 @@ theorem pos_eq {x ρ : List Bool} (h : 2 ^ ρ.length ≤ p.eval (pair x ρ).leng have hv : ∀ b, (A.vertU p b w).length = A.vert b x (binValLE ρ) := by intro b rw [vertU, List.length_replicate, hfst, hE, List.length_replicate, - Cobham.fstBlock_pair] + pairFst_pair] have hoff : (A.offU w).length = if i < A.width then i else i - A.width := by rw [offU, hlow, hsnd] by_cases hi : i < A.width @@ -334,16 +334,16 @@ theorem accepts_verifier_iff {x ρ : List Bool} (h : 2 ^ ρ.length ≤ p.eval (pair x ρ).length) (π : List Bool) : (A.verifier p).Accepts x π ρ ↔ (binValLE ρ < A.numEdges x → A.Sat x π (binValLE ρ)) := by - have hz : Cobham.sndBlock (pair x ρ) = ρ := Cobham.sndBlock_pair x ρ + have hz : pairSnd (pair x ρ) = ρ := pairSnd_pair x ρ have hE : edgeU p (pair x ρ) = List.replicate (binValLE ρ) true := by have := edgeU_eq (p := p) (z := pair x ρ) (by rw [hz]; exact h) rw [this, edgeIdx, hz] have hin : A.inRange p (pair x ρ) = [true] ↔ binValLE ρ < A.numEdges x := by - rw [A.inRange_eq_true_iff p (by rw [hz]; exact h), edgeIdx, hz, Cobham.fstBlock_pair] + rw [A.inRange_eq_true_iff p (by rw [hz]; exact h), edgeIdx, hz, pairFst_pair] set a := PCPVerifier.answers π ((A.verifier p).positions x ρ) with ha have hacc : (A.verifier p).Accepts x π ρ ↔ (A.inRange p (pair x ρ) = [true] → okArg p (pair (pair x ρ) a) ∈ A.ok) := by - rw [PCPVerifier.Accepts, mem_verdict_verifier, Cobham.fstBlock_pair] + rw [PCPVerifier.Accepts, mem_verdict_verifier, pairFst_pair] have haeq : binValLE ρ < A.numEdges x → a = PCPVerifier.answers π ((List.range (2 * A.width)).map (A.posVal x (binValLE ρ))) := by intro hlt @@ -354,13 +354,13 @@ theorem accepts_verifier_iff {x ρ : List Bool} constructor · intro hh hlt have hok := hh hlt - rw [okArg, Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hE] at hok + rw [okArg, pairFst_pair, pairFst_pair, pairSnd_pair, hE] at hok rw [Sat, ← haeq hlt] exact hok · intro hh hlt have hs := hh hlt rw [Sat] at hs - rw [okArg, Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair, hE, + rw [okArg, pairFst_pair, pairFst_pair, pairSnd_pair, hE, haeq hlt] exact hs diff --git a/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean b/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean index e64e55aa..b21d9cc3 100644 --- a/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean +++ b/Complexitylib/Classes/PCP/Internal/ConsistencyLang.lean @@ -42,31 +42,31 @@ The innermost input is `pair (pair (pair (pair (pair x w) ρ) ρ') i) i'`, with the four loop indices in unary. -/ /-- Strip the last two indices. -/ -def conY2 (y : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock y) +def conY2 (y : List Bool) : List Bool := pairFst (pairFst y) /-- Strip the last three indices. -/ -def conY1 (y : List Bool) : List Bool := Cobham.fstBlock (conY2 y) +def conY1 (y : List Bool) : List Bool := pairFst (conY2 y) /-- The original `pair x w`. -/ -def conY0 (y : List Bool) : List Bool := Cobham.fstBlock (conY1 y) +def conY0 (y : List Bool) : List Bool := pairFst (conY1 y) /-- The input. -/ -def conX (y : List Bool) : List Bool := Cobham.fstBlock (conY0 y) +def conX (y : List Bool) : List Bool := pairFst (conY0 y) /-- The witness. -/ -def conW (y : List Bool) : List Bool := Cobham.sndBlock (conY0 y) +def conW (y : List Bool) : List Bool := pairSnd (conY0 y) /-- The first coin index. -/ -def conC1 (y : List Bool) : ℕ := (Cobham.sndBlock (conY1 y)).length +def conC1 (y : List Bool) : ℕ := (pairSnd (conY1 y)).length /-- The second coin index. -/ -def conC2 (y : List Bool) : ℕ := (Cobham.sndBlock (conY2 y)).length +def conC2 (y : List Bool) : ℕ := (pairSnd (conY2 y)).length /-- The first query index. -/ -def conC3 (y : List Bool) : ℕ := (Cobham.sndBlock (Cobham.fstBlock y)).length +def conC3 (y : List Bool) : ℕ := (pairSnd (pairFst y)).length /-- The second query index. -/ -def conC4 (y : List Bool) : ℕ := (Cobham.sndBlock y).length +def conC4 (y : List Bool) : ℕ := (pairSnd y).length theorem conY2_mem_FP : conY2 ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP @@ -230,12 +230,12 @@ noncomputable def consL2 : Language := /-- The outer loop over the second coin string. -/ noncomputable def consL1 : Language := - {y | ∀ c' < 2 ^ r (Cobham.fstBlock (Cobham.fstBlock y)).length, + {y | ∀ c' < 2 ^ r (pairFst (pairFst y)).length, pair y (List.replicate c' true) ∈ consL2 f r Q} /-- **The consistency check**, as a language of `pair x w`. -/ noncomputable def consLang : Language := - {z | ∀ c < 2 ^ r (Cobham.fstBlock z).length, + {z | ∀ c < 2 ^ r (pairFst z).length, pair z (List.replicate c true) ∈ consL1 f r Q} open scoped Complexity in @@ -248,11 +248,11 @@ theorem consLang_mem_P (hrlog : r =O fun n => Nat.log 2 n) : consLang f r Q ∈ forall_unary_mem_P (consInner_mem_P f r Q hf hr) hQ have h2 : consL2 f r Q ∈ P := forall_unary_mem_P h3 hQ' have hexp : (fun z : List Bool => - List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by + List.replicate (2 ^ r (pairFst z).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) simpa using this have hexp2 : (fun y : List Bool => - List.replicate (2 ^ r (Cobham.fstBlock (Cobham.fstBlock y)).length) true) ∈ FP := by + List.replicate (2 ^ r (pairFst (pairFst y)).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP hexp simpa using this have h1 : consL1 f r Q ∈ P := forall_unary_mem_P h2 hexp2 @@ -317,32 +317,32 @@ def conArg (x w : List Bool) (c c' i i' : ℕ) : List Bool := @[simp] theorem conX_arg (x w : List Bool) (c c' i i' : ℕ) : conX (conArg x w c c' i i') = x := by rw [conArg, conX, conY0, conY1, conY2] - simp only [Cobham.fstBlock_pair] + simp only [pairFst_pair] @[simp] theorem conW_arg (x w : List Bool) (c c' i i' : ℕ) : conW (conArg x w c c' i i') = w := by rw [conArg, conW, conY0, conY1, conY2] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [pairFst_pair, pairSnd_pair] @[simp] theorem conC1_arg (x w : List Bool) (c c' i i' : ℕ) : conC1 (conArg x w c c' i i') = c := by rw [conArg, conC1, conY1, conY2] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate] + simp only [pairFst_pair, pairSnd_pair, List.length_replicate] @[simp] theorem conC2_arg (x w : List Bool) (c c' i i' : ℕ) : conC2 (conArg x w c c' i i') = c' := by rw [conArg, conC2, conY2] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate] + simp only [pairFst_pair, pairSnd_pair, List.length_replicate] @[simp] theorem conC3_arg (x w : List Bool) (c c' i i' : ℕ) : conC3 (conArg x w c c' i i') = i := by rw [conArg, conC3] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate] + simp only [pairFst_pair, pairSnd_pair, List.length_replicate] @[simp] theorem conC4_arg (x w : List Bool) (c c' i i' : ℕ) : conC4 (conArg x w c c' i i') = i' := by rw [conArg, conC4] - simp only [Cobham.sndBlock_pair, List.length_replicate] + simp only [pairSnd_pair, List.length_replicate] /-! ### The pieces on a packed argument -/ @@ -389,9 +389,9 @@ theorem mem_consLang_iff_forall (x w : List Bool) : pair x w ∈ consLang f r Q ↔ ∀ c < 2 ^ r x.length, ∀ c' < 2 ^ r x.length, ∀ i < Q, ∀ i' < Q, conArg x w c c' i i' ∈ consInner f r Q := by - rw [consLang, Set.mem_setOf_eq, Cobham.fstBlock_pair] + rw [consLang, Set.mem_setOf_eq, pairFst_pair] refine forall_congr' fun c => forall_congr' fun _ => ?_ - rw [consL1, Set.mem_setOf_eq, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + rw [consL1, Set.mem_setOf_eq, pairFst_pair, pairFst_pair] refine forall_congr' fun c' => forall_congr' fun _ => ?_ rw [consL2, Set.mem_setOf_eq] refine forall_congr' fun i => forall_congr' fun _ => ?_ diff --git a/Complexitylib/Classes/PCP/Internal/DataScan.lean b/Complexitylib/Classes/PCP/Internal/DataScan.lean index 594058ae..358bee94 100644 --- a/Complexitylib/Classes/PCP/Internal/DataScan.lean +++ b/Complexitylib/Classes/PCP/Internal/DataScan.lean @@ -55,19 +55,19 @@ namespace DataScan the state built so far and `t` the unscanned tail. -/ /-- The workspace: the index of the child being extracted, in unary. -/ -def wsOf (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock z) +def wsOf (z : List Bool) : List Bool := pairFst (pairFst z) /-- The state carried by the scan. -/ -def stOf (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock z) +def stOf (z : List Bool) : List Bool := pairSnd (pairFst z) /-- The bracket depth, in unary. -/ -def depthOf (z : List Bool) : List Bool := Cobham.fstBlock (stOf z) +def depthOf (z : List Bool) : List Bool := pairFst (stOf z) /-- The number of children already passed, in unary. -/ -def countOf (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.sndBlock (stOf z)) +def countOf (z : List Bool) : List Bool := pairFst (pairSnd (stOf z)) /-- The bits collected so far. -/ -def accOf (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.sndBlock (stOf z)) +def accOf (z : List Bool) : List Bool := pairSnd (pairSnd (stOf z)) /-- Append the current bit, but only while inside the requested child. -/ def collect (z : List Bool) (b : Bool) : List Bool := @@ -124,9 +124,9 @@ theorem closeStep_mem_FP : closeStep ∈ FP := by /-- **The scan.** On `pair (unary i) s` it runs the two steps over `s`, keeping every intermediate state within `p.eval` bits, and returns the collected bits. -/ def childOf (p : Polynomial ℕ) (z : List Bool) : List Bool := - Cobham.sndBlock (Cobham.sndBlock + pairSnd (pairSnd (Cobham.recFoldClamp openStep closeStep (p.eval z.length) initState - (Cobham.fstBlock z) (Cobham.sndBlock z))) + (pairFst z) (pairSnd z))) theorem childOf_mem_FP (p : Polynomial ℕ) : childOf p ∈ FP := by have hfold := Cobham.recFoldClamp_mem_FP openStep_mem_FP closeStep_mem_FP @@ -164,20 +164,20 @@ theorem eqFlag_replicate (c i : ℕ) : theorem depthOf_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : depthOf (pair (pair (List.replicate i true) (pack st)) t) = List.replicate st.1 true := by - rw [depthOf, stOf, Cobham.fstBlock_pair, Cobham.sndBlock_pair, pack, Cobham.fstBlock_pair] + rw [depthOf, stOf, pairFst_pair, pairSnd_pair, pack, pairFst_pair] theorem countOf_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : countOf (pair (pair (List.replicate i true) (pack st)) t) = List.replicate st.2.1 true := by - rw [countOf, stOf, Cobham.fstBlock_pair, Cobham.sndBlock_pair, pack, Cobham.sndBlock_pair, - Cobham.fstBlock_pair] + rw [countOf, stOf, pairFst_pair, pairSnd_pair, pack, pairSnd_pair, + pairFst_pair] theorem collect_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) (b : Bool) : collect (pair (pair (List.replicate i true) (pack st)) t) b = if st.2.1 = i then st.2.2 ++ [b] else st.2.2 := by - rw [collect, countOf, accOf, wsOf, stOf, Cobham.fstBlock_pair, Cobham.sndBlock_pair, - pack, Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, eqFlag_replicate] + rw [collect, countOf, accOf, wsOf, stOf, pairFst_pair, pairSnd_pair, + pack, pairFst_pair, pairSnd_pair, pairFst_pair, + pairSnd_pair, eqFlag_replicate] by_cases h : st.2.1 = i <;> simp [h] theorem openStep_pack (i : ℕ) (st : ℕ × ℕ × List Bool) (t : List Bool) : @@ -308,17 +308,17 @@ theorem child_flatten (i : ℕ) (xs : List Data) : set F := (xs.map Data.toBits).flatten with hF have hlen : (scanArg i F).length = 2 * i + 2 + F.length := by rw [scanArg, pair_length, List.length_replicate, List.length_reverse] - rw [childOf, scanArg, Cobham.fstBlock_pair, Cobham.sndBlock_pair, ← scanArg, hlen, + rw [childOf, scanArg, pairFst_pair, pairSnd_pair, ← scanArg, hlen, scanPoly_eval, recFoldClamp_eq_pack i _ F.reverse (by simp), - List.reverse_reverse, hF, runSpec_inner, pack, Cobham.sndBlock_pair, - Cobham.sndBlock_pair] + List.reverse_reverse, hF, runSpec_inner, pack, pairSnd_pair, + pairSnd_pair] /-- **How many children there are**, in unary: the same pass, reading off the counter instead of the collected bits. -/ def childCount (p : Polynomial ℕ) (z : List Bool) : List Bool := - Cobham.fstBlock (Cobham.sndBlock + pairFst (pairSnd (Cobham.recFoldClamp openStep closeStep (p.eval z.length) initState - (Cobham.fstBlock z) (Cobham.sndBlock z))) + (pairFst z) (pairSnd z))) theorem childCount_mem_FP (p : Polynomial ℕ) : childCount p ∈ FP := by have hfold := Cobham.recFoldClamp_mem_FP openStep_mem_FP closeStep_mem_FP @@ -331,10 +331,10 @@ theorem childCount_flatten (i : ℕ) (xs : List Data) : set F := (xs.map Data.toBits).flatten with hF have hlen : (scanArg i F).length = 2 * i + 2 + F.length := by rw [scanArg, pair_length, List.length_replicate, List.length_reverse] - rw [childCount, scanArg, Cobham.fstBlock_pair, Cobham.sndBlock_pair, ← scanArg, hlen, + rw [childCount, scanArg, pairFst_pair, pairSnd_pair, ← scanArg, hlen, scanPoly_eval, recFoldClamp_eq_pack i _ F.reverse (by simp), - List.reverse_reverse, hF, runSpec_inner, pack, Cobham.sndBlock_pair, - Cobham.fstBlock_pair] + List.reverse_reverse, hF, runSpec_inner, pack, pairSnd_pair, + pairFst_pair] /-- The bits strictly between the outer brackets of a serialized list. -/ theorem inner_toBits (xs : List Data) : diff --git a/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean b/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean index f6a7f534..a0ba9699 100644 --- a/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean +++ b/Complexitylib/Classes/PCP/Internal/GuessVerifyGeneric.lean @@ -89,29 +89,29 @@ theorem padWith_mem_FP (p : Polynomial ℕ) : padWith p ∈ FP := by /-- The verifier for the padded language: run the original verifier on the unpadded input, and check that the padding really is long enough. -/ noncomputable def padVerifier (p : Polynomial ℕ) (L₀ : Language) : Language := - {w | pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w) ∈ L₀ ∧ - (polyRuler p (Cobham.fstBlock (Cobham.fstBlock w))).length - ≤ (Cobham.sndBlock (Cobham.fstBlock w)).length} + {w | pair (pairFst (pairFst w)) (pairSnd w) ∈ L₀ ∧ + (polyRuler p (pairFst (pairFst w))).length + ≤ (pairSnd (pairFst w)).length} theorem padVerifier_mem_P {p : Polynomial ℕ} {L₀ : Language} (hL₀ : L₀ ∈ P) : padVerifier p L₀ ∈ P := by - have hff : (fun w : List Bool => Cobham.fstBlock (Cobham.fstBlock w)) ∈ FP := + have hff : (fun w : List Bool => pairFst (pairFst w)) ∈ FP := fstBlockOf_mem_FP Cobham.fstBlock_mem_FP - have hsf : (fun w : List Bool => Cobham.sndBlock (Cobham.fstBlock w)) ∈ FP := + have hsf : (fun w : List Bool => pairSnd (pairFst w)) ∈ FP := sndBlockOf_mem_FP Cobham.fstBlock_mem_FP have hA : (fun w : List Bool => - pair (Cobham.fstBlock (Cobham.fstBlock w)) (Cobham.sndBlock w)) ⁻¹' L₀ ∈ P := + pair (pairFst (pairFst w)) (pairSnd w)) ⁻¹' L₀ ∈ P := mem_P_preimage (Cobham.pairFn_mem_FP hff Cobham.sndBlock_mem_FP) hL₀ have hruler : (fun w : List Bool => - polyRuler p (Cobham.fstBlock (Cobham.fstBlock w))) ∈ FP := + polyRuler p (pairFst (pairFst w))) ∈ FP := polyRulerFn_mem_FP p hff have hB : {w : List Bool | - (polyRuler p (Cobham.fstBlock (Cobham.fstBlock w))).length - ≤ (Cobham.sndBlock (Cobham.fstBlock w)).length} ∈ P := by + (polyRuler p (pairFst (pairFst w))).length + ≤ (pairSnd (pairFst w)).length} ∈ P := by refine mem_P_of_decisionFn (lenLeFlagFn_mem_FP hsf hruler) fun w => ?_ simp only [Set.mem_setOf_eq] - set a := Cobham.sndBlock (Cobham.fstBlock w) with ha - set b := polyRuler p (Cobham.fstBlock (Cobham.fstBlock w)) with hb + set a := pairSnd (pairFst w) with ha + set b := polyRuler p (pairFst (pairFst w)) with hb constructor · intro hle rw [(Cobham.lenLeFlag_eq_true_iff a b).mpr hle] @@ -149,12 +149,12 @@ theorem mem_NP_of_poly_witness {L L₀ : Language} (p : Polynomial ℕ) (hL₀ : · have := hbal x y hy rw [padWith, pair_length, polyRuler_length] omega - · rw [padWith, Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + · rw [padWith, pairSnd_pair, pairFst_pair, pairFst_pair] exact hy - · rw [padWith, Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + · rw [padWith, pairFst_pair, pairFst_pair, pairSnd_pair] · rintro ⟨y, _, hmem, _⟩ refine ⟨y, ?_⟩ - rw [padWith, Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.fstBlock_pair] at hmem + rw [padWith, pairSnd_pair, pairFst_pair, pairFst_pair] at hmem exact hmem rw [hpre] exact mem_NP_preimage (padWith_mem_FP p) (padLang_mem_NP hL₀) diff --git a/Complexitylib/Classes/PCP/Internal/ListEncode.lean b/Complexitylib/Classes/PCP/Internal/ListEncode.lean index d3792fe8..efae66aa 100644 --- a/Complexitylib/Classes/PCP/Internal/ListEncode.lean +++ b/Complexitylib/Classes/PCP/Internal/ListEncode.lean @@ -35,18 +35,18 @@ namespace Complexity /-- One step: append the next entry's encoding and advance the counter. The state is `pair (pair accumulated counter) input`. -/ def listStep (E : List Bool → List Bool) (st : List Bool) : List Bool := - pair (pair (Cobham.fstBlock (Cobham.fstBlock st) - ++ E (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) - (true :: Cobham.sndBlock (Cobham.fstBlock st))) (Cobham.sndBlock st) + pair (pair (pairFst (pairFst st) + ++ E (pair (pairSnd st) (pairSnd (pairFst st)))) + (true :: pairSnd (pairFst st))) (pairSnd st) theorem listStep_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : listStep E ∈ FP := by - have hacc : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + have hacc : (fun st : List Bool => pairFst (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hctr : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + have hctr : (fun st : List Bool => pairSnd (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have hx : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hx : (fun st : List Bool => pairSnd st) ∈ FP := Cobham.sndBlock_mem_FP have hE' : (fun st : List Bool => - E (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) ∈ FP := by + E (pair (pairSnd st) (pairSnd (pairFst st)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hx hctr) hE simpa using this exact Cobham.pairFn_mem_FP @@ -75,8 +75,8 @@ theorem listStep_iterate (E : List Bool → List Bool) (x : List Bool) : induction n with | zero => simp | succ n ih => - rw [Function.iterate_succ_apply', ih, listStep, Cobham.fstBlock_pair, - Cobham.sndBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + rw [Function.iterate_succ_apply', ih, listStep, pairFst_pair, + pairSnd_pair, pairFst_pair, pairSnd_pair, entryCat_succ, List.replicate_succ] /-- **The accumulation is the encoding.** If each step writes the encoding of @@ -119,21 +119,21 @@ theorem length_entryCat_le (E : List Bool → List Bool) (x : List Bool) (b : /-- **The list encoder**, on `pair (unary count) input`. -/ noncomputable def listEncFn (E : List Bool → List Bool) (z : List Bool) : List Bool := - false :: Cobham.fstBlock (Cobham.fstBlock - ((listStep E)^[(Cobham.fstBlock z).length] (pair (pair [] []) (Cobham.sndBlock z)))) + false :: pairFst (pairFst + ((listStep E)^[(pairFst z).length] (pair (pair [] []) (pairSnd z)))) ++ [true] theorem listEncFn_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) (p : Polynomial ℕ) - (hbound : ∀ z : List Bool, ∀ k ≤ (Cobham.fstBlock z).length, - ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z))).length + (hbound : ∀ z : List Bool, ∀ k ≤ (pairFst z).length, + ((listStep E)^[k] (pair (pair [] []) (pairSnd z))).length ≤ p.eval z.length) : listEncFn E ∈ FP := by - have hinit : (fun z : List Bool => pair (pair [] []) (Cobham.sndBlock z)) ∈ FP := + have hinit : (fun z : List Bool => pair (pair [] []) (pairSnd z)) ∈ FP := Cobham.pairFn_mem_FP (constFn_mem_FP (pair [] [])) Cobham.sndBlock_mem_FP have hwidth : (fun z : List Bool => polyRuler p (id z)) ∈ FP := polyRulerFn_mem_FP p id_mem_FP - have hbound' : ∀ z : List Bool, ∀ k ≤ (Cobham.fstBlock z).length, - ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z))).length + have hbound' : ∀ z : List Bool, ∀ k ≤ (pairFst z).length, + ((listStep E)^[k] (pair (pair [] []) (pairSnd z))).length ≤ (polyRuler p (id z)).length := by intro z k hk rw [polyRuler_length] @@ -150,15 +150,15 @@ theorem listEncFn_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) (p : Poly theorem listEncFn_eq (E : List Bool → List Bool) (z : List Bool) : listEncFn E z - = false :: entryCat E (Cobham.sndBlock z) (Cobham.fstBlock z).length ++ [true] := by - rw [listEncFn, listStep_iterate, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + = false :: entryCat E (pairSnd z) (pairFst z).length ++ [true] := by + rw [listEncFn, listStep_iterate, pairFst_pair, pairFst_pair] /-- **The loop writes the list's encoding.** -/ theorem listEncFn_eq_bitstringEncode {α : Type} [DataEncode α] {E : List Bool → List Bool} {z : List Bool} (l : List α) - (hn : (Cobham.fstBlock z).length = l.length) + (hn : (pairFst z).length = l.length) (h : ∀ i, ∀ hi : i < l.length, - E (pair (Cobham.sndBlock z) (List.replicate i true)) + E (pair (pairSnd z) (List.replicate i true)) = DataEncode.bitstringEncode (l[i]'hi)) : listEncFn E z = DataEncode.bitstringEncode l := by rw [listEncFn_eq, hn, ← bitstringEncode_of_entries l h] diff --git a/Complexitylib/Classes/PCP/Internal/Materialize.lean b/Complexitylib/Classes/PCP/Internal/Materialize.lean index 64fdbfe1..15a1920d 100644 --- a/Complexitylib/Classes/PCP/Internal/Materialize.lean +++ b/Complexitylib/Classes/PCP/Internal/Materialize.lean @@ -45,32 +45,32 @@ theorem materialize_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : listE set Q : Polynomial ℕ := q.comp (3 * Polynomial.X + Polynomial.C 2) with hQ refine listEncFn_mem_FP hE (4 * Polynomial.X * Q + 3 * Polynomial.X + Polynomial.C 6) fun z k hk => ?_ - have hfz : (Cobham.fstBlock z).length ≤ z.length := fstBlock_length_le z - have hsz : (Cobham.sndBlock z).length ≤ z.length := sndBlock_length_le z + have hfz : (pairFst z).length ≤ z.length := fstBlock_length_le z + have hsz : (pairSnd z).length ≤ z.length := sndBlock_length_le z have hkz : k ≤ z.length := le_trans hk hfz - have hrec : ∀ i < k, (E (pair (Cobham.sndBlock z) (List.replicate i true))).length + have hrec : ∀ i < k, (E (pair (pairSnd z) (List.replicate i true))).length ≤ Q.eval z.length := by intro i hi refine le_trans (hq _) ?_ - have hlen : (pair (Cobham.sndBlock z) (List.replicate i true)).length + have hlen : (pair (pairSnd z) (List.replicate i true)).length ≤ 3 * z.length + 2 := by rw [pair_length, List.length_replicate] omega have := polynomial_eval_mono_nat q hlen rw [hQ, Polynomial.eval_comp] simpa using this - have hcat : (entryCat E (Cobham.sndBlock z) k).length ≤ k * Q.eval z.length := + have hcat : (entryCat E (pairSnd z) k).length ≤ k * Q.eval z.length := length_entryCat_le E _ _ k hrec - have hstate : ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z))).length - = 2 * (2 * (entryCat E (Cobham.sndBlock z) k).length + 2 + k) + 2 - + (Cobham.sndBlock z).length := by + have hstate : ((listStep E)^[k] (pair (pair [] []) (pairSnd z))).length + = 2 * (2 * (entryCat E (pairSnd z) k).length + 2 + k) + 2 + + (pairSnd z).length := by rw [listStep_iterate, pair_length, pair_length, List.length_replicate] have heval : (4 * Polynomial.X * Q + 3 * Polynomial.X + Polynomial.C 6).eval z.length = 4 * (z.length * Q.eval z.length) + 3 * z.length + 6 := by simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_ofNat, Polynomial.eval_X, Polynomial.eval_C] ring - have hC : (entryCat E (Cobham.sndBlock z) k).length ≤ z.length * Q.eval z.length := + have hC : (entryCat E (pairSnd z) k).length ≤ z.length * Q.eval z.length := le_trans hcat (Nat.mul_le_mul_right _ hkz) rw [hstate, heval] set A := z.length * Q.eval z.length with hA @@ -82,8 +82,8 @@ theorem materialize_eq {α : Type} [DataEncode α] {E : List Bool → List Bool} (h : ∀ i, ∀ hi : i < l.length, E (pair x (List.replicate i true)) = DataEncode.bitstringEncode (l[i]'hi)) : listEncFn E (pair (List.replicate l.length true) x) = DataEncode.bitstringEncode l := - listEncFn_eq_bitstringEncode l (by rw [Cobham.fstBlock_pair, List.length_replicate]) - (by rw [Cobham.sndBlock_pair]; exact h) + listEncFn_eq_bitstringEncode l (by rw [pairFst_pair, List.length_replicate]) + (by rw [pairSnd_pair]; exact h) /-! ### Adding up -/ @@ -108,7 +108,7 @@ theorem length_countOver (E : List Bool → List Bool) (x : List Bool) (n : ℕ) (countOver E (pair (List.replicate n true) x)).length = ∑ i ∈ Finset.range n, (E (pair x (List.replicate i true))).length := by rw [countOver, marks_eq, List.length_replicate, dropOne, dropOne, List.length_drop, - List.length_drop, listEncFn_eq, Cobham.fstBlock_pair, Cobham.sndBlock_pair, + List.length_drop, listEncFn_eq, pairFst_pair, pairSnd_pair, List.length_replicate, List.length_append, List.length_cons, length_entryCat] simp @@ -214,7 +214,7 @@ bound itself when it never does: count the indices no answer has been seen up to. -/ noncomputable def findFirst (E : List Bool → List Bool) (z : List Bool) : List Bool := countOver (fun w => - isEmptyMark (countOver E (pair (Cobham.sndBlock w ++ [true]) (Cobham.fstBlock w)))) z + isEmptyMark (countOver E (pair (pairSnd w ++ [true]) (pairFst w)))) z theorem findFirst_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : findFirst E ∈ FP := by have harg := Cobham.pairFn_mem_FP @@ -222,7 +222,7 @@ theorem findFirst_mem_FP {E : List Bool → List Bool} (hE : E ∈ FP) : findFir Cobham.fstBlock_mem_FP have hcount : countOver E ∈ FP := countOver_mem_FP hE have hcomp : (fun w : List Bool => - countOver E (pair (Cobham.sndBlock w ++ [true]) (Cobham.fstBlock w))) ∈ FP := + countOver E (pair (pairSnd w ++ [true]) (pairFst w))) ∈ FP := mem_FP_of_eq (mem_FP_comp harg hcount) fun _ => rfl exact countOver_mem_FP (isEmptyMark_mem_FP hcomp) @@ -239,7 +239,7 @@ theorem length_findFirst (E : List Bool → List Bool) (x : List Bool) (n : ℕ) then 1 else 0 := by rw [findFirst, length_countOver] refine Finset.sum_congr rfl fun j _ => ?_ - rw [Cobham.sndBlock_pair, Cobham.fstBlock_pair, ← List.replicate_succ', + rw [pairSnd_pair, pairFst_pair, ← List.replicate_succ', length_isEmptyMark] by_cases h : (∑ k ∈ Finset.range (j + 1), (E (pair x (List.replicate k true))).length) = 0 · rw [if_pos h, if_pos] diff --git a/Complexitylib/Classes/PCP/Internal/MaxLoop.lean b/Complexitylib/Classes/PCP/Internal/MaxLoop.lean index 431c698a..599b54ed 100644 --- a/Complexitylib/Classes/PCP/Internal/MaxLoop.lean +++ b/Complexitylib/Classes/PCP/Internal/MaxLoop.lean @@ -44,21 +44,21 @@ def maxStep (f : List Bool → List Bool) (st : List Bool) : List Bool := pair (pair (Cobham.selectHead - (Cobham.lenLeFlag (Cobham.fstBlock (Cobham.fstBlock st)) - (f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st))))) - (Cobham.fstBlock (Cobham.fstBlock st)) - (f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st))))) - (true :: Cobham.sndBlock (Cobham.fstBlock st))) - (Cobham.sndBlock st) + (Cobham.lenLeFlag (pairFst (pairFst st)) + (f (pair (pairSnd st) (pairSnd (pairFst st))))) + (pairFst (pairFst st)) + (f (pair (pairSnd st) (pairSnd (pairFst st))))) + (true :: pairSnd (pairFst st))) + (pairSnd st) theorem maxStep_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxStep f ∈ FP := by - have hm : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + have hm : (fun st : List Bool => pairFst (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hi : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + have hi : (fun st : List Bool => pairSnd (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have hz : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP + have hz : (fun st : List Bool => pairSnd st) ∈ FP := Cobham.sndBlock_mem_FP have hv : (fun st : List Bool => - f (pair (Cobham.sndBlock st) (Cobham.sndBlock (Cobham.fstBlock st)))) ∈ FP := by + f (pair (pairSnd st) (pairSnd (pairFst st)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hz hi) hf simpa using this exact Cobham.pairFn_mem_FP @@ -76,8 +76,8 @@ theorem maxStep_iterate (f : List Bool → List Bool) (z : List Bool) : ∀ n : | zero => exact ⟨[], rfl, rfl⟩ | succ n ih => obtain ⟨M, hM, hlen⟩ := ih - rw [Function.iterate_succ_apply', hM, maxStep, Cobham.fstBlock_pair, - Cobham.fstBlock_pair, Cobham.sndBlock_pair, Cobham.sndBlock_pair] + rw [Function.iterate_succ_apply', hM, maxStep, pairFst_pair, + pairFst_pair, pairSnd_pair, pairSnd_pair] set v := f (pair z (List.replicate n true)) with hv rcases Cobham.lenLeFlag_flag M v with hf | hf · rw [hf, selectHead_cons_true] @@ -145,25 +145,25 @@ theorem maxOver_le {f : List Bool → List Bool} {z : List Bool} {B : ℕ} : /-- **The packaged loop**, on `pair (unary count) input`. -/ noncomputable def maxFn (f : List Bool → List Bool) (w : List Bool) : List Bool := - Cobham.fstBlock (Cobham.fstBlock ((maxStep f)^[(Cobham.fstBlock w).length] - (pair (pair [] []) (Cobham.sndBlock w)))) + pairFst (pairFst ((maxStep f)^[(pairFst w).length] + (pair (pair [] []) (pairSnd w)))) theorem maxFn_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxFn f ∈ FP := by obtain ⟨pf, hpf⟩ := Cobham.output_length_poly_of_mem_FP hf - have hinit : (fun w : List Bool => pair (pair [] []) (Cobham.sndBlock w)) ∈ FP := + have hinit : (fun w : List Bool => pair (pair [] []) (pairSnd w)) ∈ FP := Cobham.pairFn_mem_FP (constFn_mem_FP _) Cobham.sndBlock_mem_FP set q : Polynomial ℕ := Polynomial.C 4 * (pf.comp (Polynomial.C 3 * Polynomial.X + Polynomial.C 2)) + Polynomial.C 3 * Polynomial.X + Polynomial.C 6 with hq have hwidth : (fun w : List Bool => polyRuler q (id w)) ∈ FP := polyRulerFn_mem_FP q id_mem_FP - have hbound : ∀ w : List Bool, ∀ k ≤ (Cobham.fstBlock w).length, - ((maxStep f)^[k] (pair (pair [] []) (Cobham.sndBlock w))).length + have hbound : ∀ w : List Bool, ∀ k ≤ (pairFst w).length, + ((maxStep f)^[k] (pair (pair [] []) (pairSnd w))).length ≤ (polyRuler q (id w)).length := by intro w k hk - obtain ⟨M, hM, hlen⟩ := maxStep_iterate f (Cobham.sndBlock w) k - have hfw : (Cobham.fstBlock w).length ≤ w.length := fstBlock_length_le w - have hzw : (Cobham.sndBlock w).length ≤ w.length := sndBlock_length_le w + obtain ⟨M, hM, hlen⟩ := maxStep_iterate f (pairSnd w) k + have hfw : (pairFst w).length ≤ w.length := fstBlock_length_le w + have hzw : (pairSnd w).length ≤ w.length := sndBlock_length_le w have hMB : M.length ≤ pf.eval (3 * w.length + 2) := by rw [hlen] refine maxOver_le k fun i hi => ?_ @@ -182,7 +182,7 @@ theorem maxFn_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : maxFn f ∈ theorem maxFn_eq (f : List Bool → List Bool) {n : ℕ} {z : List Bool} : (maxFn f (pair (List.replicate n true) z)).length = maxOver f z n := by obtain ⟨M, hM, hlen⟩ := maxStep_iterate f z n - rw [maxFn, Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, hM, - Cobham.fstBlock_pair, Cobham.fstBlock_pair, hlen] + rw [maxFn, pairFst_pair, pairSnd_pair, List.length_replicate, hM, + pairFst_pair, pairFst_pair, hlen] end Complexity diff --git a/Complexitylib/Classes/PCP/Internal/NatEncode.lean b/Complexitylib/Classes/PCP/Internal/NatEncode.lean index 9981f8ef..4a14721e 100644 --- a/Complexitylib/Classes/PCP/Internal/NatEncode.lean +++ b/Complexitylib/Classes/PCP/Internal/NatEncode.lean @@ -67,19 +67,19 @@ theorem bitstringEncode_list (l : List Bool) : /-- The fold step on a zero. -/ def blitZero (z : List Bool) : List Bool := - [false, true] ++ Cobham.sndBlock (Cobham.fstBlock z) + [false, true] ++ pairSnd (pairFst z) /-- The fold step on a one. -/ def blitOne (z : List Bool) : List Bool := - [false, false, true, true] ++ Cobham.sndBlock (Cobham.fstBlock z) + [false, false, true, true] ++ pairSnd (pairFst z) theorem blitZero_mem_FP : blitZero ∈ FP := by - have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact Cobham.appendFn_mem_FP (constFn_mem_FP [false, true]) h theorem blitOne_mem_FP : blitOne ∈ FP := by - have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact Cobham.appendFn_mem_FP (constFn_mem_FP [false, false, true, true]) h @@ -107,9 +107,9 @@ theorem recFoldClamp_flatBits (bound : ℕ) (W : List Bool) : simp only [List.length_cons] at hb omega rw [Cobham.recFoldClamp, ih hb'] - have hstate : Cobham.sndBlock (Cobham.fstBlock + have hstate : pairSnd (pairFst (pair (pair W (t.flatMap boolBits)) t)) = t.flatMap boolBits := by - rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [pairFst_pair, pairSnd_pair] have hlt := length_flatMap_boolBits t cases b · show (blitZero _).take bound = _ @@ -127,10 +127,10 @@ theorem recFoldClamp_flatBits (bound : ℕ) (W : List Bool) : simp only [List.length_cons, List.length_nil, List.length_cons] at hb ⊢ omega -/-- The cipher applied to `sndBlock z`. -/ +/-- The cipher applied to `pairSnd z`. -/ def flatBitsFn (z : List Bool) : List Bool := - Cobham.recFoldClamp blitZero blitOne (4 * z.length) [] (Cobham.fstBlock z) - (Cobham.sndBlock z) + Cobham.recFoldClamp blitZero blitOne (4 * z.length) [] (pairFst z) + (pairSnd z) theorem flatBitsFn_mem_FP : flatBitsFn ∈ FP := by have := Cobham.recFoldClamp_mem_FP blitZero_mem_FP blitOne_mem_FP @@ -140,7 +140,7 @@ theorem flatBitsFn_mem_FP : flatBitsFn ∈ FP := by simp theorem flatBitsFn_eq (z : List Bool) : - flatBitsFn z = (Cobham.sndBlock z).flatMap boolBits := by + flatBitsFn z = (pairSnd z).flatMap boolBits := by refine recFoldClamp_flatBits _ _ _ ?_ have := sndBlock_length_le z omega @@ -156,7 +156,7 @@ theorem encodeListFn_mem_FP : encodeListFn ∈ FP := by simp theorem encodeListFn_eq (z : List Bool) : - encodeListFn z = DataEncode.bitstringEncode (Cobham.sndBlock z) := by + encodeListFn z = DataEncode.bitstringEncode (pairSnd z) := by rw [encodeListFn, flatBitsFn_eq, bitstringEncode_list] /-! ### A number's own encoding -/ @@ -165,24 +165,24 @@ theorem encodeListFn_eq (z : List Bool) : unary. -/ noncomputable def natEncodeFn (z : List Bool) : List Bool := encodeListFn (pair [] (stripFn (pair [] - (coinStr (Cobham.fstBlock z).length (Cobham.sndBlock z).length)))) + (coinStr (pairFst z).length (pairSnd z).length)))) theorem natEncodeFn_mem_FP : natEncodeFn ∈ FP := by have hw : (fun z : List Bool => - List.replicate (Cobham.fstBlock z).length true) ∈ FP := by + List.replicate (pairFst z).length true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP unaryLength_mem_FP simpa using this have hv : (fun z : List Bool => - List.replicate (Cobham.sndBlock z).length true) ∈ FP := by + List.replicate (pairSnd z).length true) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP simpa using this have hcoin := coinStr_mem_FP hw hv - have h1 : (fun z => pair [] (coinStr (Cobham.fstBlock z).length - (Cobham.sndBlock z).length)) ∈ FP := + have h1 : (fun z => pair [] (coinStr (pairFst z).length + (pairSnd z).length)) ∈ FP := Cobham.pairFn_mem_FP (constFn_mem_FP []) hcoin have h2 := mem_FP_comp h1 stripFn_mem_FP have h3 : (fun z => pair [] (stripFn (pair [] - (coinStr (Cobham.fstBlock z).length (Cobham.sndBlock z).length)))) ∈ FP := by + (coinStr (pairFst z).length (pairSnd z).length)))) ∈ FP := by refine Cobham.pairFn_mem_FP (constFn_mem_FP []) ?_ simpa using h2 have := mem_FP_comp h3 encodeListFn_mem_FP @@ -191,9 +191,9 @@ theorem natEncodeFn_mem_FP : natEncodeFn ∈ FP := by /-- **It really is the number's encoding**, whenever the width holds the value. -/ theorem natEncodeFn_eq {z : List Bool} - (h : (Cobham.sndBlock z).length < 2 ^ (Cobham.fstBlock z).length) : - natEncodeFn z = DataEncode.bitstringEncode ((Cobham.sndBlock z).length) := by - rw [natEncodeFn, encodeListFn_eq, Cobham.sndBlock_pair, stripFn_eq, Cobham.sndBlock_pair, + (h : (pairSnd z).length < 2 ^ (pairFst z).length) : + natEncodeFn z = DataEncode.bitstringEncode ((pairSnd z).length) := by + rw [natEncodeFn, encodeListFn_eq, pairSnd_pair, stripFn_eq, pairSnd_pair, coinStr_eq h, stripTrailing_eq_bits, binValLE_bitsOfLenLE _ _ h] rfl diff --git a/Complexitylib/Classes/PCP/Internal/PositionsFP.lean b/Complexitylib/Classes/PCP/Internal/PositionsFP.lean index 97d49495..1063ec16 100644 --- a/Complexitylib/Classes/PCP/Internal/PositionsFP.lean +++ b/Complexitylib/Classes/PCP/Internal/PositionsFP.lean @@ -28,8 +28,8 @@ the width bound for `natEncodeFn`. namespace Complexity -theorem fstBlock_length_le (z : List Bool) : (Cobham.fstBlock z).length ≤ z.length := by - induction z using Cobham.fstBlock.induct <;> simp [Cobham.fstBlock] <;> omega +theorem fstBlock_length_le (z : List Bool) : (pairFst z).length ≤ z.length := by + induction z using pairFst.induct <;> simp [pairFst] <;> omega /-- The encoding of one position, read off a packed argument. -/ noncomputable def posEntryFn (P : List Bool → List Bool) (w : List Bool) : List Bool := @@ -42,8 +42,8 @@ theorem posEntryFn_mem_FP {P : List Bool → List Bool} (hP : P ∈ FP) : theorem posEntryFn_eq {P : List Bool → List Bool} (w : List Bool) : posEntryFn P w = DataEncode.bitstringEncode ((P w).length) := by - rw [posEntryFn, natEncodeFn_eq, Cobham.sndBlock_pair] - rw [Cobham.sndBlock_pair, Cobham.fstBlock_pair] + rw [posEntryFn, natEncodeFn_eq, pairSnd_pair] + rw [pairSnd_pair, pairFst_pair] exact Nat.lt_two_pow_self /-- **A unary position rule gives the query list.** If the number of queries and @@ -68,20 +68,20 @@ theorem positions_mem_of_unary {pos : List Bool → ℕ → ℕ} {cnt : List Boo set p : Polynomial ℕ := Polynomial.C 4 * Polynomial.X * (pE.comp (Polynomial.C 3 * Polynomial.X + Polynomial.C 2)) + Polynomial.C 3 * Polynomial.X + Polynomial.C 6 with hp - have hbound : ∀ z' : List Bool, ∀ k ≤ (Cobham.fstBlock z').length, - ((listStep E)^[k] (pair (pair [] []) (Cobham.sndBlock z'))).length + have hbound : ∀ z' : List Bool, ∀ k ≤ (pairFst z').length, + ((listStep E)^[k] (pair (pair [] []) (pairSnd z'))).length ≤ p.eval z'.length := by intro z' k hk - have hx : (Cobham.sndBlock z').length ≤ z'.length := sndBlock_length_le z' - have hf : (Cobham.fstBlock z').length ≤ z'.length := fstBlock_length_le z' - have hb : ∀ i < k, (E (pair (Cobham.sndBlock z') (List.replicate i true))).length + have hx : (pairSnd z').length ≤ z'.length := sndBlock_length_le z' + have hf : (pairFst z').length ≤ z'.length := fstBlock_length_le z' + have hb : ∀ i < k, (E (pair (pairSnd z') (List.replicate i true))).length ≤ pE.eval (3 * z'.length + 2) := by intro i hi refine le_trans (hpE _) ?_ refine polynomial_eval_mono_nat pE ?_ rw [pair_length, List.length_replicate] omega - have hcat := length_entryCat_le E (Cobham.sndBlock z') _ k hb + have hcat := length_entryCat_le E (pairSnd z') _ k hb rw [listStep_iterate, pair_length, pair_length, List.length_replicate] have hpe : p.eval z'.length = 4 * z'.length * (pE.eval (3 * z'.length + 2)) + 3 * z'.length + 6 := by @@ -91,7 +91,7 @@ theorem positions_mem_of_unary {pos : List Bool → ℕ → ℕ} {cnt : List Boo have hkz : k ≤ z'.length := le_trans hk hf have hmul : k * pE.eval (3 * z'.length + 2) ≤ z'.length * pE.eval (3 * z'.length + 2) := Nat.mul_le_mul_right _ hkz - have hcat' : (entryCat E (Cobham.sndBlock z') k).length + have hcat' : (entryCat E (pairSnd z') k).length ≤ z'.length * pE.eval (3 * z'.length + 2) := le_trans hcat hmul rw [show 4 * z'.length * pE.eval (3 * z'.length + 2) = 4 * (z'.length * pE.eval (3 * z'.length + 2)) from by ring] @@ -103,9 +103,9 @@ theorem positions_mem_of_unary {pos : List Bool → ℕ → ℕ} {cnt : List Boo simpa using this · intro z refine listEncFn_eq_bitstringEncode _ ?_ ?_ - · rw [Cobham.fstBlock_pair, List.length_replicate, List.length_map, List.length_range] + · rw [pairFst_pair, List.length_replicate, List.length_map, List.length_range] · intro i hi - rw [Cobham.sndBlock_pair, hEspec] + rw [pairSnd_pair, hEspec] congr 1 rw [List.getElem_map, List.getElem_range] diff --git a/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean b/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean index 42df5bd0..fdf64770 100644 --- a/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean +++ b/Complexitylib/Classes/PCP/Internal/SquareVerifier.lean @@ -53,13 +53,13 @@ def sqPositions (x ρ : List Bool) : List ℕ := V.positions x (fstCoins t x ρ) ++ V.positions x (sndCoins t x ρ) /-- The input, out of a verdict argument `pair (pair x ρ) a`. -/ -def vX (z : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock z) +def vX (z : List Bool) : List Bool := pairFst (pairFst z) /-- The coins, out of a verdict argument. -/ -def vR (z : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock z) +def vR (z : List Bool) : List Bool := pairSnd (pairFst z) /-- The answers, out of a verdict argument. -/ -def vA (z : List Bool) : List Bool := Cobham.sndBlock z +def vA (z : List Bool) : List Bool := pairSnd z /-- The verdict of the doubled verifier: both runs accept. The answers of the first run are the first `|positions|` of them. -/ @@ -110,34 +110,34 @@ theorem sqPositions_mem (hf : f ∈ FP) f (pair x rr) = DataEncode.bitstringEncode (V.positions x rr)) : ∃ g ∈ FP, ∀ x ρ : List Bool, g (pair x ρ) = DataEncode.bitstringEncode (sqPositions V t x ρ) := by - have hx : (fun z : List Bool => Cobham.fstBlock z) ∈ FP := Cobham.fstBlock_mem_FP - have hr : (fun z : List Bool => Cobham.sndBlock z) ∈ FP := Cobham.sndBlock_mem_FP - have h1 : (fun z : List Bool => f (pair (Cobham.fstBlock z) - (fstCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ∈ FP := by + have hx : (fun z : List Bool => pairFst z) ∈ FP := Cobham.fstBlock_mem_FP + have hr : (fun z : List Bool => pairSnd z) ∈ FP := Cobham.sndBlock_mem_FP + have h1 : (fun z : List Bool => f (pair (pairFst z) + (fstCoins t (pairFst z) (pairSnd z)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hx (fstCoinsFn_mem_FP ht hx hr)) hf simpa using this - have h2 : (fun z : List Bool => f (pair (Cobham.fstBlock z) - (sndCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) ∈ FP := by + have h2 : (fun z : List Bool => f (pair (pairFst z) + (sndCoins t (pairFst z) (pairSnd z)))) ∈ FP := by have := mem_FP_comp (Cobham.pairFn_mem_FP hx (sndCoinsFn_mem_FP ht hx hr)) hf simpa using this - refine ⟨fun z => false :: (posInner (f (pair (Cobham.fstBlock z) - (fstCoins t (Cobham.fstBlock z) (Cobham.sndBlock z)))) - ++ posInner (f (pair (Cobham.fstBlock z) - (sndCoins t (Cobham.fstBlock z) (Cobham.sndBlock z))))) ++ [true], ?_, ?_⟩ + refine ⟨fun z => false :: (posInner (f (pair (pairFst z) + (fstCoins t (pairFst z) (pairSnd z)))) + ++ posInner (f (pair (pairFst z) + (sndCoins t (pairFst z) (pairSnd z))))) ++ [true], ?_, ?_⟩ · have hcat := Cobham.appendFn_mem_FP (posInner_mem_FP h1) (posInner_mem_FP h2) have hcons := mem_FP_comp hcat (Cobham.cons_mem_FP false) have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) refine mem_FP_of_eq this fun z => ?_ simp · intro x ρ - show false :: (posInner (f (pair (Cobham.fstBlock (pair x ρ)) - (fstCoins t (Cobham.fstBlock (pair x ρ)) (Cobham.sndBlock (pair x ρ))))) - ++ posInner (f (pair (Cobham.fstBlock (pair x ρ)) - (sndCoins t (Cobham.fstBlock (pair x ρ)) (Cobham.sndBlock (pair x ρ)))))) ++ [true] + show false :: (posInner (f (pair (pairFst (pair x ρ)) + (fstCoins t (pairFst (pair x ρ)) (pairSnd (pair x ρ))))) + ++ posInner (f (pair (pairFst (pair x ρ)) + (sndCoins t (pairFst (pair x ρ)) (pairSnd (pair x ρ)))))) ++ [true] = _ - rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair, hfspec, hfspec, sqPositions, + rw [pairFst_pair, pairSnd_pair, hfspec, hfspec, sqPositions, bitstringEncode_append] include ht in @@ -227,7 +227,7 @@ theorem accepts_squareAt (ht : (fun x : List Bool => rw [Accepts, positions_squareAt, sqPositions, answers, List.map_append] show _ ∈ V.sqVerdict t ↔ _ rw [sqVerdict, Set.mem_setOf_eq] - simp only [vX, vR, vA, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + simp only [vX, vR, vA, pairFst_pair, pairSnd_pair] rw [show List.map (fun i => π.getD i false) (V.positions x (fstCoins t x ρ)) = answers π (V.positions x (fstCoins t x ρ)) from rfl, show List.map (fun i => π.getD i false) (V.positions x (sndCoins t x ρ)) diff --git a/Complexitylib/Classes/PCP/Internal/StripTrailing.lean b/Complexitylib/Classes/PCP/Internal/StripTrailing.lean index 6cd0b460..7eea1340 100644 --- a/Complexitylib/Classes/PCP/Internal/StripTrailing.lean +++ b/Complexitylib/Classes/PCP/Internal/StripTrailing.lean @@ -89,21 +89,21 @@ theorem stripTrailing_eq_bits (l : List Bool) : stripTrailing l = (binValLE l).b /-- The fold step on a zero. -/ def stripZero (z : List Bool) : List Bool := - Cobham.selectHead (emptyFlag (Cobham.sndBlock (Cobham.fstBlock z))) [] - (false :: Cobham.sndBlock (Cobham.fstBlock z)) + Cobham.selectHead (emptyFlag (pairSnd (pairFst z))) [] + (false :: pairSnd (pairFst z)) /-- The fold step on a one. -/ def stripOne (z : List Bool) : List Bool := - true :: Cobham.sndBlock (Cobham.fstBlock z) + true :: pairSnd (pairFst z) theorem stripZero_mem_FP : stripZero ∈ FP := by - have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact Cobham.selectHeadFn_mem_FP (emptyFlagFn_mem_FP h) (constFn_mem_FP []) (mem_FP_comp h (Cobham.cons_mem_FP false)) theorem stripOne_mem_FP : stripOne ∈ FP := by - have h : (fun z : List Bool => Cobham.sndBlock (Cobham.fstBlock z)) ∈ FP := + have h : (fun z : List Bool => pairSnd (pairFst z)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP exact mem_FP_comp h (Cobham.cons_mem_FP true) @@ -123,9 +123,9 @@ theorem recFoldClamp_stripTrailing (bound : ℕ) (W : List Bool) : simp only [List.length_cons] at hb omega rw [Cobham.recFoldClamp, ih hb'] - have hstate : Cobham.sndBlock (Cobham.fstBlock + have hstate : pairSnd (pairFst (pair (pair W (stripTrailing t)) t)) = stripTrailing t := by - rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [pairFst_pair, pairSnd_pair] have hlt : (stripTrailing t).length ≤ t.length := length_stripTrailing t cases b · show (stripZero _).take bound = _ @@ -150,8 +150,8 @@ theorem recFoldClamp_stripTrailing (bound : ℕ) (W : List Bool) : /-- Dropping trailing zeros, on `pair anything bits`. -/ def stripFn (z : List Bool) : List Bool := - Cobham.recFoldClamp stripZero stripOne z.length [] (Cobham.fstBlock z) - (Cobham.sndBlock z) + Cobham.recFoldClamp stripZero stripOne z.length [] (pairFst z) + (pairSnd z) theorem stripFn_mem_FP : stripFn ∈ FP := by have := Cobham.recFoldClamp_mem_FP stripZero_mem_FP stripOne_mem_FP @@ -161,7 +161,7 @@ theorem stripFn_mem_FP : stripFn ∈ FP := by simp theorem stripFn_eq (z : List Bool) : - stripFn z = stripTrailing (Cobham.sndBlock z) := by + stripFn z = stripTrailing (pairSnd z) := by refine recFoldClamp_stripTrailing _ _ _ ?_ exact sndBlock_length_le z diff --git a/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean b/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean index 11e1149c..b71f7b99 100644 --- a/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean +++ b/Complexitylib/Classes/PCP/Internal/SubsetNPFinal.lean @@ -36,22 +36,22 @@ variable (r : ℕ → ℕ) (Q : ℕ) /-- The witness has exactly one block per coin string. -/ noncomputable def lenLang : Language := - {z | (Cobham.sndBlock z).length = 2 ^ r (Cobham.fstBlock z).length * Q} + {z | (pairSnd z).length = 2 ^ r (pairFst z).length * Q} open scoped Complexity in theorem lenLang_mem_P (hr : (fun x : List Bool => List.replicate (r x.length) true) ∈ FP) (hrlog : r =O fun n => Nat.log 2 n) : lenLang r Q ∈ P := by - have ha : (fun z : List Bool => List.replicate (Cobham.sndBlock z).length false) ∈ FP := + have ha : (fun z : List Bool => List.replicate (pairSnd z).length false) ∈ FP := zeroBlockFn_mem_FP Cobham.sndBlock_mem_FP have hexp : (fun z : List Bool => - List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by + List.replicate (2 ^ r (pairFst z).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) simpa using this have hQ : (fun _ : List Bool => List.replicate Q false) ∈ FP := Cobham.const_replicate_mem_FP Q have hb : (fun z : List Bool => - List.replicate (2 ^ r (Cobham.fstBlock z).length * Q) false) ∈ FP := by + List.replicate (2 ^ r (pairFst z).length * Q) false) ∈ FP := by have := Cobham.mulLenFn_mem_FP hexp hQ refine mem_FP_of_eq this fun z => ?_ rw [List.length_replicate, List.length_replicate] @@ -89,14 +89,14 @@ theorem mem_witLang_iff constructor · rintro ⟨hlen, hcons, hacc⟩ have hlen' : w.length = 2 ^ r x.length * Q := by - rw [lenLang, Set.mem_setOf_eq, Cobham.fstBlock_pair, Cobham.sndBlock_pair] at hlen + rw [lenLang, Set.mem_setOf_eq, pairFst_pair, pairSnd_pair] at hlen exact hlen refine ⟨hlen', ?_, ?_⟩ · exact (mem_consLang_iff V f r Q hfspec hlen' (hQ x)).mp hcons · exact (mem_accLang_iff V f r Q hfspec hlen' (hQ x)).mp hacc · rintro ⟨hlen, hcons, hacc⟩ refine ⟨?_, ?_, ?_⟩ - · rw [lenLang, Set.mem_setOf_eq, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + · rw [lenLang, Set.mem_setOf_eq, pairFst_pair, pairSnd_pair] exact hlen · exact (mem_consLang_iff V f r Q hfspec hlen (hQ x)).mpr hcons · exact (mem_accLang_iff V f r Q hfspec hlen (hQ x)).mpr hacc diff --git a/Complexitylib/Classes/PCP/Internal/TowerTable.lean b/Complexitylib/Classes/PCP/Internal/TowerTable.lean index 2b4c8478..5c14c886 100644 --- a/Complexitylib/Classes/PCP/Internal/TowerTable.lean +++ b/Complexitylib/Classes/PCP/Internal/TowerTable.lean @@ -92,9 +92,9 @@ theorem tableSnd_table {k j : ℕ} (hj : j < F.size k * F.deg ^ 2) : noncomputable def baseRaw (z : List Bool) : List Bool := encPair (List.replicate - (F.baseVal (Cobham.fstBlock z).length (Cobham.sndBlock z).length).1 true) + (F.baseVal (pairFst z).length (pairSnd z).length).1 true) (List.replicate - (F.baseVal (Cobham.fstBlock z).length (Cobham.sndBlock z).length).2 true) + (F.baseVal (pairFst z).length (pairSnd z).length).2 true) /-- How long an argument to the base's table can be. -/ def baseKeyBound : ℕ := 2 * F.deg ^ 4 + 2 + F.deg @@ -115,7 +115,7 @@ theorem baseRec_eq {x a : ℕ} (hx : x < F.deg ^ 4) (ha : a < F.deg) : rw [pair_length, List.length_replicate, List.length_replicate, baseKeyBound] omega rw [baseRec, if_pos (mem_keySet.mpr ⟨hlen, trivial⟩), baseRaw, - Cobham.fstBlock_pair, Cobham.sndBlock_pair, List.length_replicate, + pairFst_pair, pairSnd_pair, List.length_replicate, List.length_replicate] /-! ### One record of the next level -/ @@ -125,8 +125,8 @@ theorem baseRec_eq {x a : ℕ} (hx : x < F.deg ^ 4) (ha : a < F.deg) : vertex into a vertex of the level below and a base vertex, and the dart into two base darts. -/ noncomputable def stepRec (z : List Bool) : List Bool := - let T := Cobham.fstBlock z - let J := Cobham.sndBlock z + let T := pairFst z + let J := pairSnd z let V := divC (F.deg ^ 2) J let I := modC (F.deg ^ 2) J let U := divC (F.deg ^ 4) V @@ -207,7 +207,7 @@ theorem stepRec_eq {k j : ℕ} (hj : j < F.size (k + 1) * F.deg ^ 2) : have := (F.baseVal_lt hxlt halt).1 rwa [hp] at this rw [stepRec] - simp only [Cobham.fstBlock_pair, Cobham.sndBlock_pair, divC_eq hd2, modC_eq hd2, + simp only [pairFst_pair, pairSnd_pair, divC_eq hd2, modC_eq hd2, divC_eq hd4, modC_eq hd4, divC_eq hd1, modC_eq hd1, List.length_replicate, F.baseRec_eq hxlt halt, hp, unaryOf_fstEnc_encPair, unaryOf_sndEnc_encPair, length_mulC_append, ← tableFst_def, ← tableSnd_def] diff --git a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean index 27534762..07a3b069 100644 --- a/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean +++ b/Complexitylib/Classes/PCP/Internal/UnaryDivMod.lean @@ -34,25 +34,25 @@ reaches the divisor. The state is `pair (pair quotient remainder) divisor`. -/ def dmStep (st : List Bool) : List Bool := pair (pair (Cobham.selectHead - (Cobham.lenEqFlag (true :: Cobham.sndBlock (Cobham.fstBlock st)) (Cobham.sndBlock st)) - (true :: Cobham.fstBlock (Cobham.fstBlock st)) - (Cobham.fstBlock (Cobham.fstBlock st))) + (Cobham.lenEqFlag (true :: pairSnd (pairFst st)) (pairSnd st)) + (true :: pairFst (pairFst st)) + (pairFst (pairFst st))) (Cobham.selectHead - (Cobham.lenEqFlag (true :: Cobham.sndBlock (Cobham.fstBlock st)) (Cobham.sndBlock st)) - [] (true :: Cobham.sndBlock (Cobham.fstBlock st)))) - (Cobham.sndBlock st) + (Cobham.lenEqFlag (true :: pairSnd (pairFst st)) (pairSnd st)) + [] (true :: pairSnd (pairFst st)))) + (pairSnd st) theorem dmStep_mem_FP : dmStep ∈ FP := by - have hq : (fun st : List Bool => Cobham.fstBlock (Cobham.fstBlock st)) ∈ FP := + have hq : (fun st : List Bool => pairFst (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.fstBlock_mem_FP - have hr : (fun st : List Bool => Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + have hr : (fun st : List Bool => pairSnd (pairFst st)) ∈ FP := mem_FP_comp Cobham.fstBlock_mem_FP Cobham.sndBlock_mem_FP - have hb : (fun st : List Bool => Cobham.sndBlock st) ∈ FP := Cobham.sndBlock_mem_FP - have hr' : (fun st : List Bool => true :: Cobham.sndBlock (Cobham.fstBlock st)) ∈ FP := + have hb : (fun st : List Bool => pairSnd st) ∈ FP := Cobham.sndBlock_mem_FP + have hr' : (fun st : List Bool => true :: pairSnd (pairFst st)) ∈ FP := mem_FP_comp hr (Cobham.cons_mem_FP true) have hflag : (fun st : List Bool => - Cobham.lenEqFlag (true :: Cobham.sndBlock (Cobham.fstBlock st)) - (Cobham.sndBlock st)) ∈ FP := by + Cobham.lenEqFlag (true :: pairSnd (pairFst st)) + (pairSnd st)) ∈ FP := by exact andBitFn_mem_FP (lenLeFlagFn_mem_FP hr' hb) (lenLeFlagFn_mem_FP hb hr') exact Cobham.pairFn_mem_FP (Cobham.pairFn_mem_FP @@ -68,8 +68,8 @@ theorem dmStep_iterate {B : List Bool} (hb : 0 < B.length) : induction a with | zero => simp | succ a ih => - rw [Function.iterate_succ_apply', ih, dmStep, Cobham.sndBlock_pair, - Cobham.fstBlock_pair, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [Function.iterate_succ_apply', ih, dmStep, pairSnd_pair, + pairFst_pair, pairFst_pair, pairSnd_pair] set b := B.length with hbdef have hlen : (true :: List.replicate (a % b) true).length = a % b + 1 := by simp have hmod : a % b < b := Nat.mod_lt _ hb @@ -118,11 +118,11 @@ theorem length_selectHead_le (s x y : List Bool) : theorem dmStep_one (q r b : List Bool) : ∃ q' r', dmStep (pair (pair q r) b) = pair (pair q' r') b ∧ q'.length ≤ q.length + 1 ∧ r'.length ≤ r.length + 1 := by - have hq : Cobham.fstBlock (Cobham.fstBlock (pair (pair q r) b)) = q := by - rw [Cobham.fstBlock_pair, Cobham.fstBlock_pair] - have hr : Cobham.sndBlock (Cobham.fstBlock (pair (pair q r) b)) = r := by - rw [Cobham.fstBlock_pair, Cobham.sndBlock_pair] - have hb : Cobham.sndBlock (pair (pair q r) b) = b := Cobham.sndBlock_pair _ _ + have hq : pairFst (pairFst (pair (pair q r) b)) = q := by + rw [pairFst_pair, pairFst_pair] + have hr : pairSnd (pairFst (pair (pair q r) b)) = r := by + rw [pairFst_pair, pairSnd_pair] + have hb : pairSnd (pair (pair q r) b) = b := pairSnd_pair _ _ rw [dmStep, hq, hr, hb] refine ⟨_, _, rfl, ?_, ?_⟩ · refine le_trans (length_selectHead_le _ _ _) ?_ @@ -150,11 +150,11 @@ noncomputable def dmRun (b s : List Bool) : List Bool := /-- The quotient of a length by a fixed divisor, in unary. -/ noncomputable def divFn (b s : List Bool) : List Bool := - Cobham.fstBlock (Cobham.fstBlock (dmRun b s)) + pairFst (pairFst (dmRun b s)) /-- The remainder of a length by a fixed divisor, in unary. -/ noncomputable def modFn (b s : List Bool) : List Bool := - Cobham.sndBlock (Cobham.fstBlock (dmRun b s)) + pairSnd (pairFst (dmRun b s)) theorem dmRun_mem_FP (b : List Bool) : dmRun b ∈ FP := by have hinit : (fun _ : List Bool => pair (pair [] []) b) ∈ FP := constFn_mem_FP _ @@ -185,49 +185,49 @@ theorem modFn_mem_FP (b : List Bool) : modFn b ∈ FP := by theorem divFn_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : divFn b s = List.replicate (s.length / b.length) true := by - rw [divFn, dmRun, dmStep_iterate hb s.length, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + rw [divFn, dmRun, dmStep_iterate hb s.length, pairFst_pair, pairFst_pair] theorem modFn_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : modFn b s = List.replicate (s.length % b.length) true := by - rw [modFn, dmRun, dmStep_iterate hb s.length, Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [modFn, dmRun, dmStep_iterate hb s.length, pairFst_pair, pairSnd_pair] /-! ### Dividing by a length read from the input -/ -theorem fstBlock_len_le (z : List Bool) : (Cobham.fstBlock z).length ≤ z.length := by - induction z using Cobham.fstBlock.induct <;> simp [Cobham.fstBlock] <;> omega +theorem fstBlock_len_le (z : List Bool) : (pairFst z).length ≤ z.length := by + induction z using pairFst.induct <;> simp [pairFst] <;> omega -theorem sndBlock_len_le (z : List Bool) : (Cobham.sndBlock z).length ≤ z.length := by +theorem sndBlock_len_le (z : List Bool) : (pairSnd z).length ≤ z.length := by rcases hu : unpair? z with _ | ⟨p, q⟩ - · rw [show Cobham.sndBlock z = [] from by rw [Cobham.sndBlock, hu]] + · rw [show pairSnd z = [] from by rw [pairSnd, hu]] simp · have hz : z = pair p q := unpair?_eq_some_iff.mp hu - rw [show Cobham.sndBlock z = q from by rw [Cobham.sndBlock, hu], hz, pair_length] + rw [show pairSnd z = q from by rw [pairSnd, hu], hz, pair_length] omega /-- The counting run with the divisor read from the argument: `pair b s`. -/ noncomputable def dmRun2 (z : List Bool) : List Bool := - dmStep^[(Cobham.sndBlock z).length] (pair (pair [] []) (Cobham.fstBlock z)) + dmStep^[(pairSnd z).length] (pair (pair [] []) (pairFst z)) /-- The quotient of one length by another, in unary. -/ noncomputable def divFn2 (z : List Bool) : List Bool := - Cobham.fstBlock (Cobham.fstBlock (dmRun2 z)) + pairFst (pairFst (dmRun2 z)) /-- The remainder of one length by another, in unary. -/ noncomputable def modFn2 (z : List Bool) : List Bool := - Cobham.sndBlock (Cobham.fstBlock (dmRun2 z)) + pairSnd (pairFst (dmRun2 z)) theorem dmRun2_mem_FP : dmRun2 ∈ FP := by - have hinit : (fun z : List Bool => pair (pair [] []) (Cobham.fstBlock z)) ∈ FP := + have hinit : (fun z : List Bool => pair (pair [] []) (pairFst z)) ∈ FP := Cobham.pairFn_mem_FP (constFn_mem_FP (pair [] [])) Cobham.fstBlock_mem_FP have hwidth : (fun z : List Bool => polyRuler (Polynomial.C 7 * Polynomial.X + Polynomial.C 6) (id z)) ∈ FP := polyRulerFn_mem_FP _ id_mem_FP - have hbound : ∀ z : List Bool, ∀ k ≤ (Cobham.sndBlock z).length, - (dmStep^[k] (pair (pair [] []) (Cobham.fstBlock z))).length + have hbound : ∀ z : List Bool, ∀ k ≤ (pairSnd z).length, + (dmStep^[k] (pair (pair [] []) (pairFst z))).length ≤ (polyRuler (Polynomial.C 7 * Polynomial.X + Polynomial.C 6) (id z)).length := by intro z k hk - obtain ⟨q', r', h1, hq, hr⟩ := dmStep_shape k [] [] (Cobham.fstBlock z) - have hf : (Cobham.fstBlock z).length ≤ z.length := fstBlock_len_le z - have hs : (Cobham.sndBlock z).length ≤ z.length := sndBlock_len_le z + obtain ⟨q', r', h1, hq, hr⟩ := dmStep_shape k [] [] (pairFst z) + have hf : (pairFst z).length ≤ z.length := fstBlock_len_le z + have hs : (pairSnd z).length ≤ z.length := sndBlock_len_le z rw [h1, pair_length, pair_length, polyRuler_length] simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X, id, List.length_nil, Nat.zero_add] at * @@ -247,13 +247,13 @@ theorem modFn2_mem_FP : modFn2 ∈ FP := by theorem divFn2_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : divFn2 (pair b s) = List.replicate (s.length / b.length) true := by - rw [divFn2, dmRun2, Cobham.sndBlock_pair, Cobham.fstBlock_pair, dmStep_iterate hb s.length, - Cobham.fstBlock_pair, Cobham.fstBlock_pair] + rw [divFn2, dmRun2, pairSnd_pair, pairFst_pair, dmStep_iterate hb s.length, + pairFst_pair, pairFst_pair] theorem modFn2_eq {b : List Bool} (hb : 0 < b.length) (s : List Bool) : modFn2 (pair b s) = List.replicate (s.length % b.length) true := by - rw [modFn2, dmRun2, Cobham.sndBlock_pair, Cobham.fstBlock_pair, dmStep_iterate hb s.length, - Cobham.fstBlock_pair, Cobham.sndBlock_pair] + rw [modFn2, dmRun2, pairSnd_pair, pairFst_pair, dmStep_iterate hb s.length, + pairFst_pair, pairSnd_pair] /-- **Halving a length**, in unary. -/ noncomputable def halfFn (s : List Bool) : List Bool := divFn [false, false] s diff --git a/Complexitylib/Classes/PCP/Internal/UnaryList.lean b/Complexitylib/Classes/PCP/Internal/UnaryList.lean index e5c31fbd..3e35ede1 100644 --- a/Complexitylib/Classes/PCP/Internal/UnaryList.lean +++ b/Complexitylib/Classes/PCP/Internal/UnaryList.lean @@ -205,7 +205,7 @@ theorem encUnary_mem_FP {a : List Bool → List Bool} (ha : a ∈ FP) : have hpair : (fun z => pair z (a z)) ∈ FP := Cobham.pairFn_mem_FP id_mem_FP ha have := mem_FP_comp hpair flatBitsFn_mem_FP refine mem_FP_of_eq this fun z => ?_ - rw [Function.comp_apply, flatBitsFn_eq, Cobham.sndBlock_pair] + rw [Function.comp_apply, flatBitsFn_eq, pairSnd_pair] have hcons := mem_FP_comp hflat (Cobham.cons_mem_FP false) have := Cobham.appendFn_mem_FP hcons (constFn_mem_FP [true]) exact mem_FP_of_eq this fun z => rfl diff --git a/Complexitylib/Classes/PCP/Internal/VerifierLang.lean b/Complexitylib/Classes/PCP/Internal/VerifierLang.lean index 98d5aa36..fd833557 100644 --- a/Complexitylib/Classes/PCP/Internal/VerifierLang.lean +++ b/Complexitylib/Classes/PCP/Internal/VerifierLang.lean @@ -123,20 +123,20 @@ section Acceptance variable (V : PCPVerifier) (f : List Bool → List Bool) (r : ℕ → ℕ) (Q : ℕ) /-- The input of one iteration is `pair (pair x w) (unary c)`. -/ -def accX (y : List Bool) : List Bool := Cobham.fstBlock (Cobham.fstBlock y) +def accX (y : List Bool) : List Bool := pairFst (pairFst y) /-- The witness, out of the iteration's input. -/ -def accW (y : List Bool) : List Bool := Cobham.sndBlock (Cobham.fstBlock y) +def accW (y : List Bool) : List Bool := pairSnd (pairFst y) /-- The coin string named by the iteration's index. -/ noncomputable def accCoin (y : List Bool) : List Bool := - coinStr (r (accX y).length) (Cobham.sndBlock y).length + coinStr (r (accX y).length) (pairSnd y).length /-- The verifier's view: input and coins paired with the answers read off the witness block. -/ noncomputable def accView (y : List Bool) : List Bool := pair (pair (accX y) (accCoin r y)) - (wBlock (accW y) ((Cobham.sndBlock y).length * Q) + (wBlock (accW y) ((pairSnd y).length * Q) (posCount (f (pair (accX y) (accCoin r y)))).length) theorem accX_mem_FP : accX ∈ FP := @@ -151,7 +151,7 @@ theorem accCoin_mem_FP have ht : (fun y : List Bool => List.replicate (r (accX y).length) true) ∈ FP := by have := mem_FP_comp accX_mem_FP hr simpa using this - have hc : (fun y : List Bool => List.replicate (Cobham.sndBlock y).length true) ∈ FP := by + have hc : (fun y : List Bool => List.replicate (pairSnd y).length true) ∈ FP := by have := mem_FP_comp Cobham.sndBlock_mem_FP unaryLength_mem_FP simpa using this exact coinStr_mem_FP ht hc @@ -168,14 +168,14 @@ theorem accView_mem_FP (hf : f ∈ FP) have hcount : (fun y => posCount (f (pair (accX y) (accCoin r y)))) ∈ FP := posCount_mem_FP hfv have hoff : (fun y : List Bool => - List.replicate ((Cobham.sndBlock y).length * Q) false) ∈ FP := by + List.replicate ((pairSnd y).length * Q) false) ∈ FP := by have hb : (fun _ : List Bool => List.replicate Q false) ∈ FP := Cobham.const_replicate_mem_FP Q have := Cobham.mulLenFn_mem_FP Cobham.sndBlock_mem_FP hb refine mem_FP_of_eq this fun y => ?_ rw [List.length_replicate] have hblk : (fun y => wBlock (accW y) - (List.replicate ((Cobham.sndBlock y).length * Q) false).length + (List.replicate ((pairSnd y).length * Q) false).length (posCount (f (pair (accX y) (accCoin r y)))).length) ∈ FP := wBlock_mem_FP accW_mem_FP hoff hcount refine Cobham.pairFn_mem_FP hview (mem_FP_of_eq hblk fun y => ?_) @@ -191,7 +191,7 @@ theorem accInner_mem_P (hf : f ∈ FP) /-- **Acceptance on every coin string**, as a language of `pair x w`. -/ noncomputable def accLang : Language := - {z : List Bool | ∀ c < 2 ^ r (Cobham.fstBlock z).length, + {z : List Bool | ∀ c < 2 ^ r (pairFst z).length, pair z (List.replicate c true) ∈ accInner V f r Q} open scoped Complexity in @@ -200,7 +200,7 @@ theorem accLang_mem_P (hf : f ∈ FP) (hrlog : r =O fun n => Nat.log 2 n) : accLang V f r Q ∈ P := by have hlen : (fun z : List Bool => - List.replicate (2 ^ r (Cobham.fstBlock z).length) true) ∈ FP := by + List.replicate (2 ^ r (pairFst z).length) true) ∈ FP := by have := mem_FP_comp Cobham.fstBlock_mem_FP (unaryExp_mem_FP_of_bigO_log hr hrlog) simpa using this exact forall_unary_mem_P (accInner_mem_P V f r Q hf hr) hlen @@ -218,11 +218,11 @@ theorem accView_pair (PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩)) := by set ρ := PCPVerifier.coinOfIndex (t := r x.length) ⟨c, hc⟩ with hρ have hX : accX (pair (pair x w) (List.replicate c true)) = x := by - rw [accX, Cobham.fstBlock_pair, Cobham.fstBlock_pair] + rw [accX, pairFst_pair, pairFst_pair] have hW : accW (pair (pair x w) (List.replicate c true)) = w := by - rw [accW, Cobham.fstBlock_pair, Cobham.sndBlock_pair] - have hC : (Cobham.sndBlock (pair (pair x w) (List.replicate c true))).length = c := by - rw [Cobham.sndBlock_pair, List.length_replicate] + rw [accW, pairFst_pair, pairSnd_pair] + have hC : (pairSnd (pair (pair x w) (List.replicate c true))).length = c := by + rw [pairSnd_pair, List.length_replicate] have hcoin : accCoin r (pair (pair x w) (List.replicate c true)) = BitString.toList ρ := by rw [accCoin, hX, hC, coinStr_eq hc, hρ, toList_coinOfIndex] have hidx : PCPVerifier.coinIndex ρ = c := coinIndex_coinOfIndex _ @@ -249,7 +249,7 @@ theorem mem_accLang_iff pair x w ∈ accLang V f r Q ↔ ∀ ρ : Fin (r x.length) → Bool, pair (pair x (BitString.toList ρ)) (V.tableOf (r x.length) Q x w ρ) ∈ V.verdict := by - have hfst : Cobham.fstBlock (pair x w) = x := Cobham.fstBlock_pair x w + have hfst : pairFst (pair x w) = x := pairFst_pair x w constructor · intro h ρ have hc : PCPVerifier.coinIndex ρ < 2 ^ r x.length := PCPVerifier.coinIndex_lt ρ diff --git a/Complexitylib/Classes/PH.lean b/Complexitylib/Classes/PH.lean index e8e8f15f..6245fa02 100644 --- a/Complexitylib/Classes/PH.lean +++ b/Complexitylib/Classes/PH.lean @@ -23,7 +23,7 @@ polyExistsClass (PiP n)`, `PiP n = complClass (SigmaP n)`, and their union `PH`. The level inclusions `SigmaP n ⊆ SigmaP (n + 1)` and `PiP n ⊆ PiP (n + 1)` need one computational fact: decoding the first component of a canonical pair is polynomial-time computable. That is `pairFst_mem_FP`, which reuses the payload -scanner `Cobham.fstBlock` of Cobham's algebra, so every result in this file is +scanner `pairFst` of Cobham's algebra, so every result in this file is unconditional. ## Main definitions @@ -147,17 +147,6 @@ theorem complClass_polyForallClass (C : Set Language) : /-! ## The pair decoder seam -/ -/-- Decode the first component of a canonical pair. This is the payload scanner -`Cobham.fstBlock` of Cobham's algebra: it reads doubled bits up to the -separator, so on a canonical pair it returns the first component, and on -malformed input it returns the bits decoded so far. Only its behaviour on -canonical pairs is used. -/ -def pairFst (z : List Bool) : List Bool := Cobham.fstBlock z - -/-- `pairFst` recovers the first component of a canonical pair. -/ -@[simp] theorem pairFst_pair (x y : List Bool) : pairFst (pair x y) = x := - Cobham.fstBlock_pair x y - /-- **Decoding the first component is polynomial-time.** The scanner is one of the bespoke transducers of Cobham's soundness direction. -/ theorem pairFst_mem_FP : pairFst ∈ FP := Cobham.fstBlock_mem_FP diff --git a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean index 638ae476..1cfcefff 100644 --- a/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean +++ b/Complexitylib/Classes/PH/SipserLautemann/Matrix.lean @@ -85,12 +85,12 @@ theorem matrixVerdictOn_eq_true_iff (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x /-- The innermost predicate of the Lautemann characterization, as a language of encoded triples. The components are decoded with the polynomial-time payload -scanners `Cobham.fstBlock` and `Cobham.sndBlock`, which recover them from a +scanners `pairFst` and `pairSnd`, which recover them from a canonical pair; on malformed input the decoders return their partial reads, and the language's contents there are irrelevant to the `Σ₂` identity below. -/ def matrixLang (tm : NTM k) (f : ℕ → ℕ) (b : Bool) : Language := - {z | matrixPred tm f b (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)) (Cobham.sndBlock z)} + {z | matrixPred tm f b (pairFst (pairFst z)) + (pairSnd (pairFst z)) (pairSnd z)} /-- Membership of an encoded triple in the matrix language. -/ theorem mem_matrixLang_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : @@ -103,8 +103,8 @@ polynomial-time obligation is about a *function*, which `Complexitylib.Classes.P.Cobham` can discharge inside Cobham's algebra without constructing a machine. -/ noncomputable def matrixVerdict (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (z : List Bool) : Bool := - matrixVerdictOn tm f b (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.sndBlock (Cobham.fstBlock z)) (Cobham.sndBlock z) + matrixVerdictOn tm f b (pairFst (pairFst z)) + (pairSnd (pairFst z)) (pairSnd z) /-- The verdict function on an encoded triple. -/ @[simp] theorem matrixVerdict_pair (tm : NTM k) (f : ℕ → ℕ) (b : Bool) (x w r : List Bool) : diff --git a/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean b/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean index fe5a090e..c6081c8f 100644 --- a/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean +++ b/Complexitylib/Classes/PH/SipserLautemann/Verdict.lean @@ -207,16 +207,16 @@ the amplified majority verdict. -/ noncomputable def matrixFn (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) (z : List Bool) : List Bool := caseBit₀ - (Cobham.lenEqFlag (Cobham.sndBlock z) - (seedStr pt (Cobham.fstBlock (Cobham.fstBlock z)))) + (Cobham.lenEqFlag (pairSnd z) + (seedStr pt (pairFst (pairFst z)))) (Cobham.anyShiftAux tm b - (clockStr pt (Fintype.card tm.Q) (Cobham.fstBlock (Cobham.fstBlock z))) - (Cobham.fstBlock (Cobham.fstBlock z)) - (Cobham.polyLen pt (Cobham.fstBlock (Cobham.fstBlock z))) - (runsStr pt (Cobham.fstBlock (Cobham.fstBlock z))) - (seedStr pt (Cobham.fstBlock (Cobham.fstBlock z))) - (Cobham.sndBlock z) (Cobham.sndBlock (Cobham.fstBlock z)) - (shiftStr pt (Cobham.fstBlock (Cobham.fstBlock z)))) + (clockStr pt (Fintype.card tm.Q) (pairFst (pairFst z))) + (pairFst (pairFst z)) + (Cobham.polyLen pt (pairFst (pairFst z))) + (runsStr pt (pairFst (pairFst z))) + (seedStr pt (pairFst (pairFst z))) + (pairSnd z) (pairSnd (pairFst z)) + (shiftStr pt (pairFst (pairFst z)))) [true] /-- A flag matching a Boolean, in the two polarities. -/ @@ -327,12 +327,12 @@ theorem matrixFn_eq (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) (z : List Bool /-- The pair decoders are in the algebra, being polynomial-time. -/ theorem fstBlock_cobham {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : - Cobham fun v : Fin n → List Bool => Cobham.fstBlock (g v) := + Cobham fun v : Fin n → List Bool => pairFst (g v) := (Cobham.comp (FP_subset_CobhamFP Cobham.fstBlock_mem_FP) fun _ : Fin 1 => hg).of_eq fun _ => rfl theorem sndBlock_cobham {n : ℕ} {g : (Fin n → List Bool) → List Bool} (hg : Cobham g) : - Cobham fun v : Fin n → List Bool => Cobham.sndBlock (g v) := + Cobham fun v : Fin n → List Bool => pairSnd (g v) := (Cobham.comp (FP_subset_CobhamFP Cobham.sndBlock_mem_FP) fun _ : Fin 1 => hg).of_eq fun _ => rfl @@ -363,10 +363,10 @@ theorem matrixFn_mem (tm : NTM k) (pt : Polynomial ℕ) (b : Bool) : Cobham fun v : Fin 1 → List Bool => matrixFn tm pt b (v 0) := by have hz : Cobham fun v : Fin 1 → List Bool => v 0 := Cobham.proj 0 have hx : Cobham fun v : Fin 1 → List Bool => - Cobham.fstBlock (Cobham.fstBlock (v 0)) := fstBlock_cobham (fstBlock_cobham hz) + pairFst (pairFst (v 0)) := fstBlock_cobham (fstBlock_cobham hz) have hw : Cobham fun v : Fin 1 → List Bool => - Cobham.sndBlock (Cobham.fstBlock (v 0)) := sndBlock_cobham (fstBlock_cobham hz) - have hr : Cobham fun v : Fin 1 → List Bool => Cobham.sndBlock (v 0) := sndBlock_cobham hz + pairSnd (pairFst (v 0)) := sndBlock_cobham (fstBlock_cobham hz) + have hr : Cobham fun v : Fin 1 → List Bool => pairSnd (v 0) := sndBlock_cobham hz exact (Cobham.iteFn (Cobham.lenEqFlag_mem hr (seedStr_mem pt hx)) (Cobham.anyShiftAux_mem tm b (clockStr_mem pt (Fintype.card tm.Q) hx) hx (Cobham.polyLen_mem pt hx) (runsStr_mem pt hx) (seedStr_mem pt hx) hr hw