diff --git a/Complexity.lean b/Complexity.lean index fa988aa3f6..ff38dfb625 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -1372,6 +1372,7 @@ public import Complexity.Computability.Complexity.Classes.Promise.Probabilistic public import Complexity.Computability.Complexity.Classes.Promise.Randomized public import Complexity.Computability.Complexity.Classes.Promise.Reduction public import Complexity.Computability.Complexity.Classes.Promise.Time +public import Complexity.Computability.Complexity.Classes.Promise.Time.Verifier public import Complexity.Computability.Complexity.Classes.RP public import Complexity.Computability.Complexity.Classes.RP.Closure public import Complexity.Computability.Complexity.Classes.RepeatedTrials @@ -1434,6 +1435,7 @@ public import Complexity.Computability.Complexity.Classes.Time public import Complexity.Computability.Complexity.Classes.Time.AcceptCount public import Complexity.Computability.Complexity.Classes.Time.BoundedExists public import Complexity.Computability.Complexity.Classes.Time.Polynomial +public import Complexity.Computability.Complexity.Classes.Time.SampleVerify public import Complexity.Computability.Complexity.Classes.Time.Verifier public import Complexity.Computability.Complexity.Classes.Time.WordRAM public import Complexity.Computability.Complexity.Classes.TimeSpace.Williams @@ -2951,6 +2953,7 @@ public import Complexity.DataStructure.HashFamily.WordRAM.DoubleTabulation public import Complexity.DataStructure.HashFamily.WordRAM.KWise public import Complexity.DataStructure.HashFamily.WordRAM.MultiplyShift public import Complexity.DataStructure.HashFamily.WordRAM.Tabulation +public import Complexity.DataStructure.Memory.Alloc public import Complexity.DataStructure.Memory.Field public import Complexity.DataStructure.Memory.Frame public import Complexity.DataStructure.Memory.Record @@ -2971,6 +2974,7 @@ public import Complexity.DataStructure.PrefixSums.WordRAM.Update public import Complexity.DataStructure.PriorityQueue.BinaryHeap.Memory public import Complexity.DataStructure.PriorityQueue.BinaryHeap.Order public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.Basic +public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.DecreaseKey public import Complexity.DataStructure.PriorityQueue.Spec public import Complexity.DataStructure.PriorityQueue.WordRAM.Basic public import Complexity.DataStructure.PriorityQueue.WordRAM.BinaryHeap @@ -3040,6 +3044,7 @@ public import Complexity.Foundations.Algebra.Shear public import Complexity.Foundations.Analysis.Asymptotics.CostBound public import Complexity.Foundations.Analysis.Asymptotics.Exponential public import Complexity.Foundations.Analysis.BernoulliInequality +public import Complexity.Foundations.Analysis.ENNRealFraction public import Complexity.Foundations.Analysis.ENNRealTsum public import Complexity.Foundations.Analysis.Fourier.ZModProd public import Complexity.Foundations.Analysis.HarmonicMean diff --git a/Complexity/Algorithms/Lean/Dijkstra/Memory.lean b/Complexity/Algorithms/Lean/Dijkstra/Memory.lean index 62e06022a5..8a9081023f 100644 --- a/Complexity/Algorithms/Lean/Dijkstra/Memory.lean +++ b/Complexity/Algorithms/Lean/Dijkstra/Memory.lean @@ -176,12 +176,14 @@ theorem holds_inputGraph (G : ListInstance) : /-- **The structures after allocation.** Past the input of `G`, a distance table and then a heap, allocated without clearing, together with the adjacency arrays of the input, represent the initial state of Dijkstra's algorithm on `G`: an empty queue, an empty distance map and the -graph. -/ +graph. The structures share memory only while its frontier fits a word (`Memory.Framed.Apart`). -/ theorem inv_input (G : ListInstance) {w K V : ℕ} (hH : (BinaryHeap.Memory.allocated G.n ((Memory.State.init G.encode).frontier + G.n)).Valid w K) (hT : Dictionary.Memory.Valid ⟨(Memory.State.init G.encode).frontier, G.n⟩ w G.n V) - (hA : (inputGraph G.n G.m).Valid G.n) : + (hA : (inputGraph G.n G.m).Valid G.n) + (hfit : Fits w ((Memory.State.init G.encode).frontier + G.n + 1 + + PriorityQueue.WordRAM.BinaryHeap.space G.n)) : (framed hH hT hA G.adj).inv ⟨(Memory.State.init G.encode).mem, (Memory.State.init G.encode).frontier + G.n + 1 + PriorityQueue.WordRAM.BinaryHeap.space G.n⟩ ∧ @@ -202,13 +204,15 @@ theorem inv_input (G : ListInstance) {w K V : ℕ} ⟨by simp only [inputGraph, Block.Allocated]; omega, by simp only [inputGraph, Block.Allocated]; omega, holds_inputGraph G⟩, ?_⟩, ?_⟩, Prod.ext hHabs (Prod.ext hTabs rfl)⟩ - · simp only [Dictionary.Memory.framed_footprint, AdjacencyList.Memory.framed_footprint] + · refine ⟨?_, hfit⟩ + simp only [Dictionary.Memory.framed_footprint, AdjacencyList.Memory.framed_footprint] rw [Finset.disjoint_left] intro a ha hb simp only [Block.mem_footprint, Block.Owns, AdjacencyList.Memory.Layout.footprint, inputGraph, Finset.mem_union] at ha hb omega - · simp only [Memory.Framed.prod_footprint, BinaryHeap.Memory.framed_footprint, + · refine ⟨?_, hfit⟩ + simp only [Memory.Framed.prod_footprint, BinaryHeap.Memory.framed_footprint, Dictionary.Memory.framed_footprint, AdjacencyList.Memory.framed_footprint] rw [Finset.disjoint_left] intro a ha hb @@ -300,6 +304,7 @@ theorem run_triple (G : ListInstance) {w : ℕ} have hA : (inputGraph G.n G.m).Valid G.n := ⟨rfl⟩ set M := framed hH hT hA G.adj with hM obtain ⟨hinv, habs⟩ := inv_input G hH hT hA + (hfit.of_le (by simp only [PriorityQueue.WordRAM.BinaryHeap.space]; nlinarith)) obtain ⟨hvalid, hdist⟩ := dijkstra_correct (K := K) (V := K + 1) G le_rfl (by omega) rw [← habs] at hvalid hdist obtain ⟨hvE, -, hstate, -⟩ := M.simulates_client (dijkstra G.source) hinv hvalid diff --git a/Complexity/Algorithms/Lean/Karger/Contraction.lean b/Complexity/Algorithms/Lean/Karger/Contraction.lean index 92b7827b9a..4a198db794 100644 --- a/Complexity/Algorithms/Lean/Karger/Contraction.lean +++ b/Complexity/Algorithms/Lean/Karger/Contraction.lean @@ -41,11 +41,12 @@ less than it (`minCut_le_of_mem_support_karger`). Every call it makes is admissi `telescope_survival_step`), used unchanged, and the composition of the stages is `Probability.PMF.toOuterMeasure_bind_ge_mul_ennreal`. -The word-RAM implementation proves the same bound on machine states, interleaved with register -steps (`Cslib.Algorithms.WordRAM.Karger.contractDownTo_spec`). Here no register, address or -instruction count appears. An implementation of `spec` over the memory oracle is a separate, -deterministic hop, and `Refinement.toRandomized` with `RandomizedRefinement.withCoins` carries the -law of the client through it. +No register, address or instruction count appears here. The word-RAM loop +`Cslib.Algorithms.WordRAM.Karger.contractDownTo` simulates `contractTimes`: the graph it holds has +the law of the client's final state (`Cslib.Algorithms.WordRAM.Karger.contractDownTo_law`), so its +survival bound is `survives_contractTimes`. An implementation of `spec` over the memory oracle is a +separate, deterministic hop, and `Refinement.toRandomized` with `RandomizedRefinement.withCoins` +carries the law of the client through it. ## Main definitions @@ -56,6 +57,8 @@ law of the client through it. ## Main results +* `run_contractStep_bind`, `run_contractStep_bind_of_eq_zero`: the run of one contraction, the + step that an implementation simulates. * `survives_contractTimes`: the survival bound. * `two_div_le_toOuterMeasure_karger`: Karger's success probability. * `isContractionOf_of_mem_support_contractTimes`, `minCut_le_of_mem_support_karger`: every @@ -181,7 +184,7 @@ noncomputable def karger : ProbOracleComp Op.Result ℕ := do /-- One contraction of a graph of positive weight draws a uniform offset below the weight and contracts the pair sampled there. -/ -private theorem run_contractStep_bind {α : Type} (p : ProbOracleComp Op.Result α) {m : ℕ} +theorem run_contractStep_bind {α : Type} (p : ProbOracleComp Op.Result α) {m : ℕ} (W : Fin (m + 1) → Fin (m + 1) → ℕ) (hS : totalDoubledWeight W ≠ 0) : spec.toRandomized.withCoins.run (contractStep >>= fun _ => p) ⟨m + 1, W⟩ = (ProbComp.unifOracle (totalDoubledWeight W - 1)).bind fun r => @@ -197,7 +200,7 @@ private theorem run_contractStep_bind {α : Type} (p : ProbOracleComp Op.Result rfl /-- One contraction of a weightless graph contracts its first and last supervertices. -/ -private theorem run_contractStep_bind_of_eq_zero {α : Type} (p : ProbOracleComp Op.Result α) +theorem run_contractStep_bind_of_eq_zero {α : Type} (p : ProbOracleComp Op.Result α) {m : ℕ} (W : Fin (m + 1) → Fin (m + 1) → ℕ) (hS : totalDoubledWeight W = 0) : spec.toRandomized.withCoins.run (contractStep >>= fun _ => p) ⟨m + 1, W⟩ = spec.toRandomized.withCoins.run p ⟨m, contractMatrix W 0 (Fin.last m)⟩ := by diff --git a/Complexity/Algorithms/WordRAM/Karger/Contract.lean b/Complexity/Algorithms/WordRAM/Karger/Contract.lean index 429d0e1a02..7f52b17c88 100644 --- a/Complexity/Algorithms/WordRAM/Karger/Contract.lean +++ b/Complexity/Algorithms/WordRAM/Karger/Contract.lean @@ -8,10 +8,10 @@ module -- upstream: candidate public import Complexity.Init -public import Complexity.Algorithms.WordRAM.Karger.Graph +public import Complexity.Algorithms.Lean.Karger.Contraction public import Complexity.Computability.WordRAM.Heap public import Complexity.Computability.WordRAM.Notation -public import Complexity.Computability.WordRAM.Randomized.Structured +public import Complexity.Computability.WordRAM.Randomized.Law /-! # Workspace-relocatable randomized contraction on the word RAM @@ -33,6 +33,16 @@ yielding `36 * (k ^ 2 - t ^ 2) + 4` worst-case instructions and at most `k - t` `k` down to `t`, with survival probability at least `(t * (t - 1)) / (k * (k - 1))` for any fixed minimum cut of a connected multigraph. +The probability is not proved on machine states. `contractDownTo` simulates Karger's algorithm as +a client of the contraction structure `Cslib.Algorithms.Lean.Karger.spec`: the graph the machine +holds (`heldGraph`) has the law of `Cslib.Algorithms.Lean.Karger.contractTimes` +(`contractDownTo_law`). Each step's `rand` call draws the offset uniformly below the total weight, +as the client's coin does, and `postRandStep_exec` contracts the pair sampled there. The survival +bound and the contraction invariant are the specification's +(`Cslib.Algorithms.Lean.Karger.survives_contractTimes`, +`Cslib.Algorithms.Lean.Karger.isContractionOf_of_mem_support_contractTimes`), carried through that +law. + ## Source statements and notation mapping * **Matrix contraction and survival bound (paraphrase):** @@ -68,6 +78,8 @@ minimum cut of a connected multigraph. `Cslib.Algorithms.WordRAM.Karger.ContractState`: relocatable memory layout and word-bound invariants for an active `k × k` supervertex adjacency matrix with row stride `stride` and row degree array at `dBase`. +* `Cslib.Algorithms.WordRAM.Karger.heldGraph`: the graph a machine state holds, as a state of + `Cslib.Algorithms.Lean.Karger.spec`. * `Cslib.Algorithms.WordRAM.Karger.computeDegreesAndTotal`, `Cslib.Algorithms.WordRAM.Karger.computeDegreesAndTotalAt`: deterministic `O(k ^ 2)` initializer populating `D[0..k)` and `totS`. @@ -80,10 +92,13 @@ minimum cut of a connected multigraph. * `Cslib.Algorithms.WordRAM.Karger.computeDegreesAndTotal_exec`: `computeDegreesAndTotal` populates `HoldsWorkspace` and `totS = totalDoubledWeight W` within `6 * k ^ 2 + 12 * k + 6` instructions, modifying only `Finset.Ico dBase (dBase + k)`. +* `Cslib.Algorithms.WordRAM.Karger.contractDownTo_law`: `contractDownTo` simulates `k - t` + contractions of the specification: `ExecRandLaw` with `IsQueryBounded (k - t)`, worst-case step + bound `36 * (k ^ 2 - t ^ 2) + 4`, `Modifies` frame, and the law of `heldGraph`. * `Cslib.Algorithms.WordRAM.Karger.contractDownTo_spec`: joint certificate of `ExecRand`, `IsQueryBounded (k - t)`, worst-case step bound `36 * (k ^ 2 - t ^ 2) + 4`, `Modifies` frame, - contraction invariant `IsContractionOf`, and telescoping cut-survival probability lower bound - `((t * (t - 1) : ℕ) : ℝ≥0∞) / (k * (k - 1))`. + contraction invariant `IsContractionOf`, and cut-survival probability lower bound + `((t * (t - 1) : ℕ) : ℝ≥0∞) / (k * (k - 1))`, the last two from the specification. ## References @@ -170,6 +185,27 @@ structure ContractState (w wb db str k t : ℕ) (W : Fin k → Fin k → ℕ) (x fits_totS : Fits w (totalDoubledWeight W) workspace : HoldsWorkspace x.mem wb db str W +/-- The graph that a machine state holds in the workspace at `wb` with row stride `str`: `activeK` +supervertices, with the weight matrix read from memory. It abstracts a `ContractState` to a state +of the contraction structure `Lean.Karger.spec`. -/ +def heldGraph (wb str : ℕ) (x : Data 16) : Lean.Karger.Graph := + ⟨x.regs Reg.activeK, fun i j => x.mem (wb + i.val * str + j.val)⟩ + +/-- A state holding `W` on `k` supervertices holds the graph `⟨k, W⟩`. -/ +theorem ContractState.heldGraph_eq {w wb db str k t : ℕ} {W : Fin k → Fin k → ℕ} {x : Data 16} + (hst : ContractState w wb db str k t W x) : heldGraph wb str x = ⟨k, W⟩ := by + unfold heldGraph + rw [hst.regs_activeK] + exact congrArg _ (funext₂ hst.workspace.1) + +/-- The weight matrix of a state is the weight of the graph it holds. -/ +private theorem ContractState.eq_of_heldGraph_eq {w wb db str k t : ℕ} {W W' : Fin k → Fin k → ℕ} + {x : Data 16} (hst : ContractState w wb db str k t W x) (h : heldGraph wb str x = ⟨k, W'⟩) : + W = W' := by + have h' := hst.heldGraph_eq.symm.trans h + simp only [Lean.Karger.Graph.mk.injEq, heq_eq_eq, true_and] at h' + exact h' + theorem matAddr_lt_end {wb str k : ℕ} (hstr : k ≤ str) (i j : Fin k) : wb + i.val * str + j.val < wb + str * k := by have hi : i.val + 1 ≤ k := i.isLt @@ -2466,14 +2502,7 @@ theorem postRandStep_exec {w wb db str m t r_val : ℕ} workspace := hws_m } -/-! #### `PMF.toOuterMeasure` helpers for step-count maps and `contractDownTo_spec` -/ - -private theorem eval_map_snd_toOuterMeasure {α : Type} (m : ProbComp (α × ℕ)) - (g : α × ℕ → ℕ) (P : α → Prop) : - (((fun z => (z.1, g z)) <$> m).eval).toOuterMeasure {z | P z.1} = - m.eval.toOuterMeasure {z | P z.1} := by - rw [ProbComp.eval_map, PMF.toOuterMeasure_map_apply] - rfl +/-! #### Simulation of the contraction structure and `contractDownTo_spec` -/ private theorem step_budget_succ {t m n_post z₂ : ℕ} (ht : 2 ≤ t) (hm : t ≤ m) (hn : n_post ≤ 45 * (m + 1) + 22) (hz : z₂ ≤ 36 * (m ^ 2 - t ^ 2) + 2) : @@ -2497,87 +2526,78 @@ def SurvivalPost {n : ℕ} (W₀ : Fin n → Fin n → ℕ) (wb db str t : ℕ) y.regs totS = totalDoubledWeight W' ∧ pullbackCut part' B' = C_star -private theorem contractLoop_spec {n w wb db str t steps : ℕ} {W₀ : Fin n → Fin n → ℕ} - {W : Fin (t + steps) → Fin (t + steps) → ℕ} {part : Fin n → Fin (t + steps)} {x : Data 16} - (ht : 2 ≤ t) (hC : IsContractionOf W₀ part W) - (h0 : x.regs zero = 0) (h1 : x.regs one = 1) - (hst : ContractState w wb db str (t + steps) t W x) : - ∃ m : ProbComp (Data 16 × ℕ), - ExecRand w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] x m ∧ - m.IsQueryBounded steps ∧ - (∀ z ∈ m.support, - z.2 ≤ 36 * ((t + steps) ^ 2 - t ^ 2) + 2 ∧ - Modifies (workspaceFootprint wb db str (t + steps)) x.mem z.1.mem ∧ - ∃ (W' : Fin t → Fin t → ℕ) (part' : Fin n → Fin t), - IsContractionOf W₀ part' W' ∧ - ContractState w wb db str t t W' z.1) ∧ - (∀ B : Finset (Fin (t + steps)), - 0 < minCut W₀ → IsNonTrivialCut B → - cutWeight W₀ (pullbackCut part B) = minCut W₀ → - (((t * (t - 1) : ℕ) : ℝ≥0∞) / (((t + steps) * (t + steps - 1) : ℕ) : ℝ≥0∞)) ≤ - m.eval.toOuterMeasure {z | SurvivalPost W₀ wb db str t (pullbackCut part B) z.1}) := by - induction steps generalizing x with +/-- **The contraction loop refines the contraction structure.** From a state holding a multigraph +`W` on `t + s` supervertices, the loop runs within `36 ((t + s)² - t²) + 2` instructions and `s` +`rand` calls, writes only the workspace and ends holding a multigraph on `t` supervertices. The +graph it holds has the law of `s` contractions of `⟨t + s, W⟩` in `Lean.Karger.spec`: each +positive-weight step draws the offset uniformly below the total weight, as the client +`Lean.Karger.contractStep` does, and `postRandStep` contracts the pair sampled there. -/ +private theorem contractLoop_law {w wb db str t s : ℕ} {W : Fin (t + s) → Fin (t + s) → ℕ} + {x : Data 16} (ht : 2 ≤ t) (hW : IsMultigraph W) (h0 : x.regs zero = 0) + (h1 : x.regs one = 1) (hst : ContractState w wb db str (t + s) t W x) : + ExecRandLaw w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] x + (fun y => Modifies (workspaceFootprint wb db str (t + s)) x.mem y.mem ∧ + ∃ W' : Fin t → Fin t → ℕ, IsMultigraph W' ∧ ContractState w wb db str t t W' y) + (36 * ((t + s) ^ 2 - t ^ 2) + 2) s (heldGraph wb str) + ((Lean.Karger.spec.toRandomized.withCoins.run (Lean.Karger.contractTimes s) + ⟨t + s, W⟩).map Prod.snd) := by + induction s generalizing x with | zero => - have hk_eq : t + 0 = t := Nat.add_zero t have hnc : ¬ (Cond.lt targetT activeK).Holds x := by simp [hst.regs_targetT, hst.regs_activeK] - refine ⟨pure (x, 2), ExecRand.loop_exit hnc, .pure _ 0, ?_, ?_⟩ - · intro z hz - cases OracleComp.eq_of_mem_supportWith_pure hz - refine ⟨by simp, Modifies.refl _ _, ?_⟩ - cases hk_eq - exact ⟨W, part, hC, hst⟩ - · intro B _ _ _ - simp only [Nat.add_zero, ProbComp.eval_pure, PMF.toOuterMeasure_pure_apply] - have ht_pos : 0 < t * (t - 1) := Nat.mul_pos (by omega) (by omega) - have hne0 : (((t * (t - 1) : ℕ) : ℝ≥0∞)) ≠ 0 := by exact_mod_cast ht_pos.ne' - have htop : (((t * (t - 1) : ℕ) : ℝ≥0∞)) ≠ ⊤ := ENNReal.natCast_ne_top _ - rw [ENNReal.div_self hne0 htop] - have hmem : (x, 2) ∈ {z : Data 16 × ℕ | - SurvivalPost W₀ wb db str t (pullbackCut part B) z.1} := by - cases hk_eq - exact ⟨W, part, B, hC, hst.workspace, hst.regs_totS, rfl⟩ - simp [hmem] + refine ((ExecRandLaw.loop_exit hnc ⟨Modifies.refl _ _, W, hW, hst⟩).congr_law ?_).mono + (fun _ h => h) (Nat.le_add_left _ _) le_rfl + rw [hst.heldGraph_eq] + exact (PMF.pure_map Prod.snd ((), (⟨t + 0, W⟩ : Lean.Karger.Graph))).symm | succ s ih => - let m_cur := t + s - have hm_def : m_cur = t + s := rfl - have hm_ge : 2 ≤ m_cur := by omega + let κ (G : Lean.Karger.Graph) : PMF Lean.Karger.Graph := + (Lean.Karger.spec.toRandomized.withCoins.run (Lean.Karger.contractTimes s) G).map Prod.snd have hc_loop : (Cond.lt targetT activeK).Holds x := by simp only [Cond.holds_lt, hst.regs_targetT, hst.regs_activeK] omega + -- After one contraction the machine holds a multigraph on `t + s` supervertices, from which + -- the rest of the loop has the law of the rest of the client. + let P (y : Data 16) : Prop := + Modifies (workspaceFootprint wb db str (t + s + 1)) x.mem y.mem ∧ y.regs zero = 0 ∧ + y.regs one = 1 ∧ ∃ W' : Fin (t + s) → Fin (t + s) → ℕ, + IsMultigraph W' ∧ ContractState w wb db str (t + s) t W' y + have hrest : ∀ y, P y → ExecRandLaw w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] y + (fun z => Modifies (workspaceFootprint wb db str (t + (s + 1))) x.mem z.mem ∧ + ∃ W' : Fin t → Fin t → ℕ, IsMultigraph W' ∧ ContractState w wb db str t t W' z) + (36 * ((t + s) ^ 2 - t ^ 2) + 2) s (heldGraph wb str) (κ (heldGraph wb str y)) := by + rintro y ⟨hmod, hy0, hy1, W', hW', hst'⟩ + rw [hst'.heldGraph_eq] + exact (ih hW' hy0 hy1 hst').mono (fun z ⟨hmz, hz⟩ => ⟨modifies_trans_subset hmod hmz + Finset.Subset.rfl (workspaceFootprint_mono (Nat.le_succ _)), hz⟩) le_rfl le_rfl + have hbudget := step_budget_succ (n_post := 45 * (t + s + 1) + 22) ht (Nat.le_add_right t s) + le_rfl le_rfl by_cases hS0 : totalDoubledWeight W = 0 - · -- Zero-weight branch: `totS = 0`, deterministic merge of `(0, Fin.last m_cur)` in `0` calls. + · -- Zero weight: `contractDownTo` drops the last supervertex, which is the specification's + -- contraction of `0` and the last supervertex of a weightless graph. have hcond_z : (Cond.eq totS zero).Holds x := by simp [hst.regs_totS, hS0, h0] - have hm_fit : Fits w m_cur := hst.fits_dEnd.of_le (by omega) - let x_next := x.set activeK m_cur - have hsub1 : (t + (s + 1)) - 1 = m_cur := by omega + have hm_fit : Fits w (t + s) := hst.fits_dEnd.of_le (by omega) + let x_next := x.set activeK (t + s) + have hsub1 : t + (s + 1) - 1 = t + s := by omega have hop : (Op.bin .sub activeK activeK one).eval w x = some x_next := by simp only [Op.eval_bin, BinOp.eval, hst.regs_activeK, h1, hsub1] exact Data.put_of_fits hm_fit - have hstep_det : ExecRand w contractStep x (pure (x_next, 2)) := by - unfold contractStep - simpa only [map_pure] using ExecRand.branch_pos hcond_z (ExecRand.op hop) - let u₀ : Fin (m_cur + 1) := ⟨0, by omega⟩ - let v₀ : Fin (m_cur + 1) := Fin.last m_cur - have huv₀ : u₀ ≠ v₀ := by - intro h - have := congrArg Fin.val h - change 0 = m_cur at this - omega - have hW_zero : ∀ a b : Fin (m_cur + 1), W a b = 0 := fun a b => by + have hW_zero : ∀ a b : Fin (t + s + 1), W a b = 0 := fun a b => by have := entry_le_totalDoubledWeight W a b omega - have hcm_zero : ∀ i j : Fin m_cur, contractMatrix W u₀ v₀ i j = 0 := fun i j => by - unfold contractMatrix mergePair - simp [hW_zero] - have hdeg_cm_zero : ∀ i : Fin m_cur, rowDeg (contractMatrix W u₀ v₀) i = 0 := fun i => by + have hcm_zero : ∀ i j : Fin (t + s), contractMatrix W 0 (Fin.last (t + s)) i j = 0 := + fun i j => by + unfold contractMatrix mergePair + simp [hW_zero] + have hdeg_cm_zero : ∀ i : Fin (t + s), + rowDeg (contractMatrix W 0 (Fin.last (t + s))) i = 0 := fun i => by unfold rowDeg simp [hcm_zero] - have htot_cm_zero : totalDoubledWeight (contractMatrix W u₀ v₀) = 0 := by + have htot_cm_zero : totalDoubledWeight (contractMatrix W 0 (Fin.last (t + s))) = 0 := by unfold totalDoubledWeight simp [hdeg_cm_zero] - have hws_next : HoldsWorkspace x_next.mem wb db str (contractMatrix W u₀ v₀) := by + have hws_next : + HoldsWorkspace x_next.mem wb db str (contractMatrix W 0 (Fin.last (t + s))) := by refine ⟨fun i j => ?_, fun i => ?_⟩ · have hw1 : x.mem (wb + i.val * str + j.val) = W i.castSucc j.castSucc := hst.workspace.1 i.castSucc j.castSucc @@ -2589,8 +2609,9 @@ private theorem contractLoop_spec {n w wb db str t steps : ℕ} {W₀ : Fin n rw [hw2, hdeg_cm_zero] unfold rowDeg simp [hW_zero] - have hmul_le : str * m_cur ≤ str * (t + (s + 1)) := Nat.mul_le_mul_left str (by omega) - have hst_next : ContractState w wb db str m_cur t (contractMatrix W u₀ v₀) x_next := { + have hmul_le : str * (t + s) ≤ str * (t + (s + 1)) := Nat.mul_le_mul_left str (by omega) + have hst_next : + ContractState w wb db str (t + s) t (contractMatrix W 0 (Fin.last (t + s))) x_next := { regs_wBase := by simpa +decide [x_next, Function.update_apply] using hst.regs_wBase regs_dBase := by simpa +decide [x_next, Function.update_apply] using hst.regs_dBase regs_stride := by simpa +decide [x_next, Function.update_apply] using hst.regs_stride @@ -2607,82 +2628,38 @@ private theorem contractLoop_spec {n w wb db str t steps : ℕ} {W₀ : Fin n fits_totS := by rw [htot_cm_zero]; exact fits_zero w workspace := hws_next } - have hC_next : IsContractionOf W₀ (contractPart part u₀ v₀ huv₀) - (contractMatrix W u₀ v₀) := isContractionOf_contract hC huv₀ - obtain ⟨m_tail, hm_tail, hq_tail, hsup_tail, _⟩ := ih hC_next - (by simpa +decide [x_next, Function.update_apply] using h0) - (by simpa +decide [x_next, Function.update_apply] using h1) - hst_next - have hiter := ExecRand.loop_iter hc_loop hstep_det (ml := fun _ => m_tail) fun z hz => by - cases OracleComp.eq_of_mem_supportWith_pure hz - exact hm_tail - refine ⟨_, hiter, ?_, ?_, ?_⟩ - · rw [pure_bind] - exact (hq_tail.bind fun _ => .pure _ 0).mono (by omega) - · intro z hz - obtain ⟨z₁, hz₁, hrest⟩ := OracleComp.mem_supportWith_bind_iff.mp hz - cases OracleComp.eq_of_mem_supportWith_pure hz₁ - obtain ⟨z₂, hz₂, hfinal⟩ := OracleComp.mem_supportWith_bind_iff.mp hrest - cases OracleComp.eq_of_mem_supportWith_pure hfinal - rcases hsup_tail z₂ hz₂ with ⟨htime₂, hmod₂, W', part', hC', hst'⟩ - refine ⟨?_, ?_, W', part', hC', hst'⟩ - · have hbud := step_budget_succ ht (by omega : t ≤ m_cur) (Nat.zero_le _) htime₂ - change 2 + z₂.2 + 2 ≤ 36 * ((m_cur + 1) ^ 2 - t ^ 2) + 2 - omega - · exact modifies_trans_subset (Modifies.refl _ x.mem) hmod₂ - Finset.Subset.rfl (workspaceFootprint_mono (Nat.le_succ m_cur)) - · -- Vacuous when `0 < minCut W₀` since `0 < minCut W₀ ≤ minCut W` forces `0 < totS`. - intro B hmin_pos _ _ - have hminW : 0 < minCut W := - lt_of_lt_of_le hmin_pos - (minCut_le_of_isContractionOf (by rw [Fintype.card_fin]; omega) hC) - have hS_pos := totalDoubledWeight_pos_of_minCut_pos (by rw [Fintype.card_fin]; omega) - hC.multigraph hminW - omega - · -- Positive-weight branch: `0 < totalDoubledWeight W`. - have hS_pos : 0 < totalDoubledWeight W := Nat.pos_of_ne_zero hS0 - let S := totalDoubledWeight W - have hS_def : S = totalDoubledWeight W := rfl + have hb : ExecRandLaw w contractStep x P 2 0 (heldGraph wb str) + (PMF.pure (heldGraph wb str x_next)) := by + unfold contractStep + exact ExecRandLaw.branch_pos hcond_z (ExecRandLaw.of_execWithin (ExecWithin.op hop) + ⟨Modifies.refl _ _, by simpa +decide [x_next, Function.update_apply] using h0, + by simpa +decide [x_next, Function.update_apply] using h1, _, + isMultigraph_contractMatrix hW _ _, hst_next⟩) + refine ((ExecRandLaw.loop_iter hc_loop hb hrest).congr_law ?_).mono (fun _ h => h) + (le_trans (by omega) hbudget) (by omega) + rw [PMF.pure_bind, hst_next.heldGraph_eq] + exact (congrArg (PMF.map Prod.snd) (Lean.Karger.run_contractStep_bind_of_eq_zero (m := t + s) + (Lean.Karger.contractTimes s) W hS0)).symm + · -- Positive weight: one `rand` call draws the offset uniformly below the total weight, and + -- `postRandStep` contracts the pair sampled there. have hcond_nz : ¬ (Cond.eq totS zero).Holds x := by simp [hst.regs_totS, h0, hS0] - have hSm1_fit : Fits w (S - 1) := hst.fits_totS.of_le (by omega) - let x_sub := x.set val1 (S - 1) + have hSm1_fit : Fits w (totalDoubledWeight W - 1) := hst.fits_totS.of_le (by omega) + let x_sub := x.set val1 (totalDoubledWeight W - 1) have hop_sub : (Op.bin .sub val1 totS one).eval w x = some x_sub := by simp only [Op.eval_bin, BinOp.eval, hst.regs_totS, h1] exact Data.put_of_fits hSm1_fit - have hfit_rand : Fits w (x_sub.regs val1) := by simpa [x_sub] using hSm1_fit - have hper_sample : ∀ k : Fin (x_sub.regs val1 + 1), - ∃ (u v : Fin (m_cur + 1)) (huv : u ≠ v) (y_post : Data 16) (n_post : ℕ) - (m_rec : ProbComp (Data 16 × ℕ)), - IsSampledPair W k.val u v ∧ - n_post ≤ 45 * (m_cur + 1) + 22 ∧ - Exec w postRandStep (x_sub.set rem k.val) y_post n_post ∧ - Modifies (workspaceFootprint wb db str (m_cur + 1)) x.mem y_post.mem ∧ - ContractState w wb db str m_cur t (contractMatrix W u v) y_post ∧ - ExecRand w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] y_post m_rec ∧ - m_rec.IsQueryBounded s ∧ - (∀ z ∈ m_rec.support, - z.2 ≤ 36 * (m_cur ^ 2 - t ^ 2) + 2 ∧ - Modifies (workspaceFootprint wb db str m_cur) y_post.mem z.1.mem ∧ - ∃ (W' : Fin t → Fin t → ℕ) (part' : Fin n → Fin t), - IsContractionOf W₀ part' W' ∧ - ContractState w wb db str t t W' z.1) ∧ - (∀ B' : Finset (Fin m_cur), - 0 < minCut W₀ → IsNonTrivialCut B' → - cutWeight W₀ (pullbackCut (contractPart part u v huv) B') = minCut W₀ → - (((t * (t - 1) : ℕ) : ℝ≥0∞) / ((m_cur * (m_cur - 1) : ℕ) : ℝ≥0∞)) ≤ - m_rec.eval.toOuterMeasure - {z | SurvivalPost W₀ wb db str t - (pullbackCut (contractPart part u v huv) B') z.1}) := by + have hN : x_sub.regs val1 = totalDoubledWeight W - 1 := by simp [x_sub] + have hpost : ∀ k : Fin (x_sub.regs val1 + 1), ∃ y, + ExecWithin w postRandStep (x_sub.set rem k.val) y (45 * (t + s + 1) + 22) ∧ P y ∧ + heldGraph wb str y = Lean.Karger.contractGraph ⟨t + s + 1, W⟩ + (Lean.Karger.sampledPair W k).1 (Lean.Karger.sampledPair W k).2 := by intro k - have hk_lt : k.val < S := by - have hk_bound := k.isLt - simp only [x_sub, Data.set_regs, Function.update_self] at hk_bound - omega - obtain ⟨u, v, hsamp⟩ := exists_isSampledPair W hk_lt - have huv : u ≠ v := isSampledPair_ne hC.multigraph hsamp - obtain ⟨y_post, ⟨n_post, hn_post, he_post⟩, hmod_post, hst_post, hy0, hy1⟩ := - postRandStep_exec (x := x_sub.set rem k.val) (t := t) hm_ge hC.multigraph hsamp + obtain ⟨u, v, hsamp⟩ := exists_isSampledPair W (show k.val < totalDoubledWeight W by + have := k.isLt + omega) + obtain ⟨y, hy, hmod, hst', hy0, hy1⟩ := + postRandStep_exec (x := x_sub.set rem k.val) (m := t + s) (t := t) (by omega) hW hsamp (by simpa +decide [x_sub, Function.update_apply] using h0) (by simpa +decide [x_sub, Function.update_apply] using h1) (by simpa +decide [x_sub, Function.update_apply] using hst.regs_wBase) @@ -2697,205 +2674,60 @@ private theorem contractLoop_spec {n w wb db str t steps : ℕ} {W₀ : Fin n (by simp +decide) hst.le_stride hst.disjoint_blocks hst.fits_wEnd hst.fits_dEnd hst.fits_totS hst.workspace - obtain ⟨m_rec, hm_rec, hq_rec, hsup_rec, hsurv_rec⟩ := - ih (isContractionOf_contract hC huv) hy0 hy1 hst_post - exact ⟨u, v, huv, y_post, n_post, m_rec, hsamp, hn_post, he_post, hmod_post, hst_post, - hm_rec, hq_rec, hsup_rec, hsurv_rec⟩ - -- Assemble `ExecRand` for `contractStep` via `codeComp`. - let m_post (d : Data 16) := codeComp w postRandStep d - have hrand_post : ExecRand w ram[rem ← rand val1; ⟪postRandStep⟫] x_sub - (do - let z₁ ← (do - let k ← ProbComp.unifFin (x_sub.regs val1) - pure (x_sub.set rem k.val, 1)) - let z₂ ← m_post z₁.1 - pure (z₂.1, z₁.2 + z₂.2)) := by - refine ExecRand.seq (ExecRand.rand hfit_rand) fun z₁ hz₁ => ?_ - obtain ⟨k, -, hk_eq'⟩ := OracleComp.mem_supportWith_bind_iff.mp hz₁ - cases OracleComp.eq_of_mem_supportWith_pure hk_eq' - obtain ⟨_, _, _, y_post, n_post, _, _, _, he_post, _, _, _, _, _, _⟩ := hper_sample k - dsimp only [m_post] - rw [he_post.execRand.codeComp_eq] - exact he_post.execRand - have hsub_rand_post := (Exec.op hop_sub).seqRand hrand_post - have hstep_rand : ExecRand w contractStep x - ((fun z => (z.1, z.2 + 2)) <$> ((fun z => (z.1, 1 + z.2)) <$> (do - let z₁ ← (do - let k ← ProbComp.unifFin (x_sub.regs val1) - pure (x_sub.set rem k.val, 1)) - let z₂ ← m_post z₁.1 - pure (z₂.1, z₁.2 + z₂.2)))) := - ExecRand.branch_neg hcond_nz hsub_rand_post - let m_loop_rec (d : Data 16) := - codeComp w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] d - let mb := (fun z : Data 16 × ℕ => (z.1, z.2 + 2)) <$> ((fun z => (z.1, 1 + z.2)) <$> (do - let z₁ ← (do - let k ← ProbComp.unifFin (x_sub.regs val1) - pure (x_sub.set rem k.val, 1)) - let z₂ ← m_post z₁.1 - pure (z₂.1, z₁.2 + z₂.2))) - have hmb_support : ∀ z ∈ mb.support, ∃ k : Fin (x_sub.regs val1 + 1), - ∃ (u v : Fin (m_cur + 1)) (huv : u ≠ v) (y_post : Data 16) (n_post : ℕ) - (m_rec : ProbComp (Data 16 × ℕ)), - z = (y_post, (1 + (1 + n_post)) + 2) ∧ - IsSampledPair W k.val u v ∧ - n_post ≤ 45 * (m_cur + 1) + 22 ∧ - Modifies (workspaceFootprint wb db str (m_cur + 1)) x.mem y_post.mem ∧ - m_loop_rec y_post = m_rec ∧ - ExecRand w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] y_post m_rec ∧ - m_rec.IsQueryBounded s ∧ - (∀ z' ∈ m_rec.support, - z'.2 ≤ 36 * (m_cur ^ 2 - t ^ 2) + 2 ∧ - Modifies (workspaceFootprint wb db str m_cur) y_post.mem z'.1.mem ∧ - ∃ (W' : Fin t → Fin t → ℕ) (part' : Fin n → Fin t), - IsContractionOf W₀ part' W' ∧ - ContractState w wb db str t t W' z'.1) := by - intro z hz - obtain ⟨za, hza, rfl⟩ := OracleComp.mem_supportWith_map_iff.mp hz - obtain ⟨zb, hzb, rfl⟩ := OracleComp.mem_supportWith_map_iff.mp hza - obtain ⟨z₁, hz₁, hrest⟩ := OracleComp.mem_supportWith_bind_iff.mp hzb - obtain ⟨k, -, hk_pure⟩ := OracleComp.mem_supportWith_bind_iff.mp hz₁ - cases OracleComp.eq_of_mem_supportWith_pure hk_pure - obtain ⟨u, v, huv, y_post, n_post, m_rec, hsamp, hn_post, he_post, hmod_post, _, - hm_rec, hq_rec, hsup_rec, _⟩ := hper_sample k - obtain ⟨z₂, hz₂, hzb_pure⟩ := OracleComp.mem_supportWith_bind_iff.mp hrest - cases OracleComp.eq_of_mem_supportWith_pure hzb_pure - dsimp only [m_post] at hz₂ - rw [he_post.execRand.codeComp_eq] at hz₂ - cases OracleComp.eq_of_mem_supportWith_pure hz₂ - have hml_eq : m_loop_rec y_post = m_rec := hm_rec.codeComp_eq - exact ⟨k, u, v, huv, y_post, n_post, m_rec, rfl, hsamp, hn_post, hmod_post, - hml_eq, hm_rec, hq_rec, hsup_rec⟩ - have hiter : ExecRand w ram[while targetT < activeK do [ ⟪contractStep⟫ ]] x - (do - let z₁ ← mb - let z₂ ← m_loop_rec z₁.1 - pure (z₂.1, z₁.2 + z₂.2 + 2)) := by - refine ExecRand.loop_iter hc_loop hstep_rand fun z₁ hz₁ => ?_ - obtain ⟨_, _, _, _, _, _, m_rec, rfl, _, _, _, hml_eq, hm_rec, _, _⟩ := hmb_support z₁ hz₁ - rw [hml_eq] - exact hm_rec - have hmb_qb : mb.IsQueryBounded 1 := by - dsimp only [mb] - simp only [OracleComp.IsQueryBounded, OracleComp.isCostBounded_map_iff] - have hrand_qb : (do - let k ← ProbComp.unifFin (x_sub.regs val1) - pure (x_sub.set rem k.val, 1)).IsQueryBounded 1 := by - simpa only [Nat.add_zero] using - (ProbComp.isQueryBounded_unifFin (x_sub.regs val1)).bind fun _ => .pure _ 0 - have hpost_qb : ∀ z₁ ∈ (do - let k ← ProbComp.unifFin (x_sub.regs val1) - pure (x_sub.set rem k.val, 1)).support, - (m_post z₁.1 >>= fun z₂ => pure (z₂.1, z₁.2 + z₂.2)).IsQueryBounded 0 := by - intro z₁ hz₁ - obtain ⟨k, -, hk_p⟩ := OracleComp.mem_supportWith_bind_iff.mp hz₁ - cases OracleComp.eq_of_mem_supportWith_pure hk_p - obtain ⟨_, _, _, _, _, _, _, _, he_post, _, _, _, _, _, _⟩ := hper_sample k - dsimp only [m_post] - rw [he_post.execRand.codeComp_eq, pure_bind] - exact .pure _ 0 - simpa only [Nat.add_zero] using - OracleComp.IsCostBounded.bind_on_support hrand_qb hpost_qb - refine ⟨_, hiter, ?_, ?_, ?_⟩ - · have htot_qb : (1 : ℕ) + s = s + 1 := Nat.add_comm 1 s - rw [← htot_qb] - refine OracleComp.IsCostBounded.bind_on_support hmb_qb fun z₁ hz₁ => ?_ - obtain ⟨_, _, _, _, _, _, m_rec, rfl, _, _, _, hml_eq, _, hq_rec, _⟩ := hmb_support z₁ hz₁ - rw [hml_eq] - simpa only [Nat.add_zero] using hq_rec.bind fun _ => .pure _ 0 - · intro z hz - obtain ⟨z₁, hz₁, hrest⟩ := OracleComp.mem_supportWith_bind_iff.mp hz - obtain ⟨k, u, v, huv, y_post, n_post, m_rec, rfl, _, hn_post, hmod_post, - hml_eq, _, _, hsup_rec⟩ := hmb_support z₁ hz₁ - rw [hml_eq] at hrest - obtain ⟨z₂, hz₂, hfinal⟩ := OracleComp.mem_supportWith_bind_iff.mp hrest - cases OracleComp.eq_of_mem_supportWith_pure hfinal - rcases hsup_rec z₂ hz₂ with ⟨htime₂, hmod₂, W', part', hC', hst'⟩ - refine ⟨?_, ?_, W', part', hC', hst'⟩ - · exact step_budget_succ ht (by omega : t ≤ m_cur) hn_post htime₂ - · exact modifies_trans_subset hmod_post hmod₂ Finset.Subset.rfl - (workspaceFootprint_mono (Nat.le_succ m_cur)) - · -- Telescoping survival probability bound. - intro B hmin_pos hB_nt hB_min - let C_star := pullbackCut part B - let E : Set (Data 16 × ℕ) := {z | SurvivalPost W₀ wb db str t C_star z.1} - have hN_eq : x_sub.regs val1 + 1 = S := by - simp only [x_sub, Data.set_regs, Function.update_self] - omega - have hm_simp : (do - let z₁ ← mb - let z₂ ← m_loop_rec z₁.1 - pure (z₂.1, z₁.2 + z₂.2 + 2)) = (do - let k ← ProbComp.unifFin (x_sub.regs val1) - let zp ← m_post (x_sub.set rem k.val) - let z₂ ← m_loop_rec zp.1 - pure (z₂.1, ((1 + (1 + zp.2)) + 2) + z₂.2 + 2)) := by - dsimp only [mb] - simp only [← bind_pure_comp, bind_assoc, pure_bind] - rw [hm_simp, ProbComp.eval_bind] - let castFin : Fin (x_sub.regs val1 + 1) ≃ Fin (totalDoubledWeight W) := finCongr hN_eq - let survSet : Set (Fin (x_sub.regs val1 + 1)) := - {k | SampleSurvives W B (castFin k)} - have hdeg_bound : (m_cur + 1) * cutWeight W B ≤ totalDoubledWeight W := by - have hcw_eq : cutWeight W B = minCut W₀ := by - rw [← cutWeight_pullbackCut hC B, hB_min] - rw [hcw_eq] - have hmul := mul_minCut_le_totalDoubledWeight (by rw [Fintype.card_fin]; omega) - hC.multigraph - rw [Fintype.card_fin] at hmul - exact (Nat.mul_le_mul_left (m_cur + 1) - (minCut_le_of_isContractionOf (by rw [Fintype.card_fin]; omega) hC)).trans hmul - have hstep_prob : (((m_cur - 1 : ℕ) : ℝ≥0∞) / (m_cur + 1 : ℕ)) ≤ - (ProbComp.unifFin (x_sub.regs val1)).eval.toOuterMeasure survSet := by - rw [ProbComp.eval_unifFin] - let _ : Nonempty (Fin (x_sub.regs val1 + 1)) := ⟨⟨0, by omega⟩⟩ - let _ : Nonempty (Fin (totalDoubledWeight W)) := ⟨⟨0, hS_pos⟩⟩ - have hmap_u : Cslib.Probability.PMF.uniformOfFintype (Fin (totalDoubledWeight W)) = - (Cslib.Probability.PMF.uniformOfFintype - (Fin (x_sub.regs val1 + 1))).map castFin := - (Cslib.Probability.PMF.uniformOfFintype_map_equiv castFin).symm - have h1_step := step_survival_prob_ge (by omega : 2 ≤ m_cur + 1) hC.multigraph - hS_pos hdeg_bound - have hsub_m : m_cur + 1 - 2 = m_cur - 1 := by omega - rw [hsub_m, hmap_u, PMF.toOuterMeasure_map_apply] at h1_step - exact h1_step - have hsub_ms : t + (s + 1) - 1 = m_cur := by omega - have hm_add : t + (s + 1) = m_cur + 1 := rfl - have htele : (((m_cur - 1 : ℕ) : ℝ≥0∞) / (m_cur + 1 : ℕ)) * - (((t * (t - 1) : ℕ) : ℝ≥0∞) / ((m_cur * (m_cur - 1) : ℕ) : ℝ≥0∞)) = - (((t * (t - 1) : ℕ) : ℝ≥0∞) / (((t + (s + 1)) * (t + (s + 1) - 1) : ℕ) : ℝ≥0∞)) := by - rw [hsub_ms, hm_add] - exact telescope_survival_step ht (by omega : t ≤ m_cur) - rw [← htele] - refine toOuterMeasure_bind_ge_mul_ennreal _ _ survSet E hstep_prob ?_ - intro k _ hk_surv - obtain ⟨u, v, huv, y_post, n_post, m_rec, hsamp, _, he_post, _, _, - hm_rec, _, _, hsurv_rec⟩ := hper_sample k - have hmp_eq : m_post (x_sub.set rem k.val) = pure (y_post, n_post) := - he_post.execRand.codeComp_eq - have hml_eq : m_loop_rec y_post = m_rec := hm_rec.codeComp_eq - have hcont_eq : (do - let zp ← m_post (x_sub.set rem k.val) - let z₂ ← m_loop_rec zp.1 - pure (z₂.1, ((1 + (1 + zp.2)) + 2) + z₂.2 + 2)) = - ((fun z₂ => (z₂.1, ((1 + (1 + n_post)) + 2) + z₂.2 + 2)) <$> m_rec) := by - rw [hmp_eq, pure_bind, hml_eq, ← bind_pure_comp] - rw [hcont_eq, eval_map_snd_toOuterMeasure] - rcases hk_surv with ⟨u', v', hsamp', hsame'⟩ - have hcast_val : (castFin k).val = k.val := rfl - rw [hcast_val] at hsamp' - rcases isSampledPair_unique W hsamp hsamp' with ⟨rfl, rfl⟩ - let B' := contractCut v B - have hpb_eq : pullbackCut (contractPart part u v huv) B' = C_star := - pullbackCut_contractCut part huv hsame' - have hC_star_nt : IsNonTrivialCut C_star := - isNonTrivialCut_pullbackCut hC.surj hB_nt - have hB'_nt : IsNonTrivialCut B' := - isNonTrivialCut_of_pullbackCut (contractPart part u v huv) (hpb_eq ▸ hC_star_nt) - have hB'_min : cutWeight W₀ (pullbackCut (contractPart part u v huv) B') = minCut W₀ := by - rw [hpb_eq] - exact hB_min - simpa only [hpb_eq] using hsurv_rec B' hmin_pos hB'_nt hB'_min + refine ⟨y, hy, ⟨hmod, hy0, hy1, _, isMultigraph_contractMatrix hW u v, hst'⟩, ?_⟩ + rw [hst'.heldGraph_eq, Lean.Karger.sampledPair_eq hsamp, Lean.Karger.contractGraph_fin] + choose y hy using hpost + have hb : ExecRandLaw w contractStep x P (1 + (1 + (45 * (t + s + 1) + 22)) + 2) 1 + (heldGraph wb str) ((Probability.PMF.uniformOfFintype (Fin (x_sub.regs val1 + 1))).map + fun k => heldGraph wb str (y k)) := by + unfold contractStep + exact ExecRandLaw.branch_neg hcond_nz (ExecRandLaw.seq_det (ExecWithin.op hop_sub) + (ExecRandLaw.rand_seq (by rw [hN]; exact hSm1_fit) (fun k => (hy k).1) + fun k => (hy k).2.1)) + refine ((ExecRandLaw.loop_iter hc_loop hb hrest).congr_law ?_).mono (fun _ h => h) + hbudget (by omega) + have hlaw : ∀ k, κ (heldGraph wb str (y k)) = κ (Lean.Karger.contractGraph ⟨t + s + 1, W⟩ + (Lean.Karger.sampledPair W k).1 (Lean.Karger.sampledPair W k).2) := + fun k => by rw [(hy k).2.2] + rw [PMF.bind_map, Function.comp_def, funext hlaw, hN] + exact (PMF.map_bind _ _ _).symm.trans (congrArg (PMF.map Prod.snd) + (Lean.Karger.run_contractStep_bind (m := t + s) (Lean.Karger.contractTimes s) W hS0).symm) + +/-- **`contractDownTo` refines the contraction structure.** From a state holding a multigraph `W` +on `k ≥ t ≥ 2` supervertices, `contractDownTo` runs within `36 (k² - t²) + 4` instructions and +`k - t` `rand` calls, writes only the workspace and ends holding a multigraph on `t` supervertices. +The graph it holds (`heldGraph`) has the law of `k - t` contractions of `⟨k, W⟩` by the client +`Lean.Karger.contractTimes` of `Lean.Karger.spec`. -/ +theorem contractDownTo_law {w wb db str k t : ℕ} {W : Fin k → Fin k → ℕ} {x : Data 16} + (ht : 2 ≤ t) (htk : t ≤ k) (hW : IsMultigraph W) (hst : ContractState w wb db str k t W x) : + ExecRandLaw w contractDownTo x + (fun y => Modifies (workspaceFootprint wb db str k) x.mem y.mem ∧ + ∃ W' : Fin t → Fin t → ℕ, IsMultigraph W' ∧ ContractState w wb db str t t W' y) + (36 * (k ^ 2 - t ^ 2) + 4) (k - t) (heldGraph wb str) + ((Lean.Karger.spec.toRandomized.withCoins.run (Lean.Karger.contractTimes (k - t)) + ⟨k, W⟩).map Prod.snd) := by + obtain ⟨s, rfl⟩ : ∃ s, k = t + s := ⟨k - t, by omega⟩ + rw [Nat.add_sub_cancel_left] + have h1_fit : Fits w 1 := hst.fits_dEnd.of_le (by omega) + let x₁ := (x.set zero 0).set one 1 + have hst₁ : ContractState w wb db str (t + s) t W x₁ := { + regs_wBase := by simpa +decide [x₁, Function.update_apply] using hst.regs_wBase + regs_dBase := by simpa +decide [x₁, Function.update_apply] using hst.regs_dBase + regs_stride := by simpa +decide [x₁, Function.update_apply] using hst.regs_stride + regs_activeK := by simpa +decide [x₁, Function.update_apply] using hst.regs_activeK + regs_targetT := by simpa +decide [x₁, Function.update_apply] using hst.regs_targetT + regs_totS := by simpa +decide [x₁, Function.update_apply] using hst.regs_totS + le_stride := hst.le_stride + disjoint_blocks := hst.disjoint_blocks + fits_wEnd := hst.fits_wEnd + fits_dEnd := hst.fits_dEnd + fits_totS := hst.fits_totS + workspace := hst.workspace + } + have hloop := contractLoop_law ht hW (by simp +decide [x₁]) (by simp +decide [x₁]) hst₁ + unfold contractDownTo + exact (ExecRandLaw.seq_det (ExecWithin.const (fits_zero w)) + (ExecRandLaw.seq_det (ExecWithin.const h1_fit) hloop)).mono (fun _ h => h) (by omega) le_rfl /-- **Master specification for `contractDownTo` (`Code .standard 16`).** Starting from any `ContractState w wb db str k t W x` (`2 ≤ t ≤ k`) where `W` is a contraction of @@ -2906,7 +2738,12 @@ Starting from any `ContractState w wb db str k t W x` (`2 ≤ t ≤ k`) where `W `workspaceFootprint wb db str k` and leaving a valid `t`-supervertex `ContractState` that is a contraction of `W₀`, and 4. preserves any fixed minimum cut `pullbackCut part B` of a connected multigraph (`0 < minCut W₀`) - with probability at least `(t * (t - 1)) / (k * (k - 1))`. -/ + with probability at least `(t * (t - 1)) / (k * (k - 1))`. + +The first three parts and the law of the held graph are `contractDownTo_law`. The contraction in +part 3 and the bound in part 4 are the specification's +(`Lean.Karger.isContractionOf_of_mem_support_contractTimes`, `Lean.Karger.survives_contractTimes`), +carried through that law. -/ theorem contractDownTo_spec {n w wb db str k t : ℕ} {W₀ : Fin n → Fin n → ℕ} {W : Fin k → Fin k → ℕ} {part : Fin n → Fin k} {x : Data 16} (ht : 2 ≤ t) (htk : t ≤ k) (hC : IsContractionOf W₀ part W) @@ -2925,55 +2762,32 @@ theorem contractDownTo_spec {n w wb db str k t : ℕ} {W₀ : Fin n → Fin n cutWeight W₀ (pullbackCut part B) = minCut W₀ → (((t * (t - 1) : ℕ) : ℝ≥0∞) / ((k * (k - 1) : ℕ) : ℝ≥0∞)) ≤ m.eval.toOuterMeasure {z | SurvivalPost W₀ wb db str t (pullbackCut part B) z.1}) := by - have hk_split : t + (k - t) = k := Nat.add_sub_of_le htk - revert W part hst - rw [← hk_split] - intro W part hC hst - have h1_fit : Fits w 1 := hst.fits_dEnd.of_le (by omega) - let x₁ := (x.set zero 0).set one 1 - have e0 : Exec w (Code.op (.const zero 0)) x (x.set zero 0) 1 := - Exec.const (B := .standard) (d := zero) (x := x) (fits_zero w) - have e1 : Exec w (Code.op (.const one 1)) (x.set zero 0) x₁ 1 := - Exec.const (B := .standard) (d := one) (x := x.set zero 0) h1_fit - have hst₁ : ContractState w wb db str (t + (k - t)) t W x₁ := { - regs_wBase := by simpa +decide [x₁, Function.update_apply] using hst.regs_wBase - regs_dBase := by simpa +decide [x₁, Function.update_apply] using hst.regs_dBase - regs_stride := by simpa +decide [x₁, Function.update_apply] using hst.regs_stride - regs_activeK := by simpa +decide [x₁, Function.update_apply] using hst.regs_activeK - regs_targetT := by simpa +decide [x₁, Function.update_apply] using hst.regs_targetT - regs_totS := by simpa +decide [x₁, Function.update_apply] using hst.regs_totS - le_stride := hst.le_stride - disjoint_blocks := hst.disjoint_blocks - fits_wEnd := hst.fits_wEnd - fits_dEnd := hst.fits_dEnd - fits_totS := hst.fits_totS - workspace := hst.workspace - } - obtain ⟨m_loop, hm_loop, hq_loop, hsup_loop, hsurv_loop⟩ := - contractLoop_spec ht hC (by simp +decide [x₁]) - (by simp +decide [x₁]) hst₁ - have hfull : ExecRand w contractDownTo x ((fun z => (z.1, 2 + z.2)) <$> m_loop) := by - unfold contractDownTo - have he12 := e1.seqRand hm_loop - have he012 := e0.seqRand he12 - have hmap_assoc : ((fun z : Data 16 × ℕ => (z.1, 1 + z.2)) <$> - ((fun z : Data 16 × ℕ => (z.1, 1 + z.2)) <$> m_loop)) = - ((fun z : Data 16 × ℕ => (z.1, 2 + z.2)) <$> m_loop) := by - rw [Functor.map_map] - refine congrArg (· <$> m_loop) (funext fun z => Prod.ext rfl (by omega)) - rwa [hmap_assoc] at he012 - have hsub_cancel : t + (k - t) - t = k - t := by omega - refine ⟨(fun z => (z.1, 2 + z.2)) <$> m_loop, hfull, ?_, ?_, ?_⟩ - · rw [hsub_cancel] - simp only [OracleComp.IsQueryBounded, OracleComp.isCostBounded_map_iff] - exact hq_loop - · intro z hz - obtain ⟨z₀, hz₀, rfl⟩ := OracleComp.mem_supportWith_map_iff.mp hz - rcases hsup_loop z₀ hz₀ with ⟨ht0, hmod0, W', part', hC', hst'⟩ - exact ⟨by omega, hmod0, W', part', hC', hst'⟩ - · intro B hmin_pos hB_nt hB_min - rw [eval_map_snd_toOuterMeasure] - exact hsurv_loop B hmin_pos hB_nt hB_min + obtain ⟨m, hm, hq, hsup, hlaw⟩ := contractDownTo_law ht htk hC.multigraph hst + obtain ⟨s, rfl⟩ : ∃ s, k = t + s := ⟨k - t, by omega⟩ + rw [Nat.add_sub_cancel_left, ProbComp.eval_map] at hlaw + refine ⟨m, hm, hq, fun z hz => ?_, fun B hmin hB hBmin => ?_⟩ + · obtain ⟨⟨hmod, W', -, hst'⟩, hT⟩ := hsup z hz + have hz' : heldGraph wb str z.1 ∈ ((Lean.Karger.spec.toRandomized.withCoins.run + (Lean.Karger.contractTimes s) ⟨t + s, W⟩).map Prod.snd).support := by + rw [← hlaw, PMF.mem_support_map_iff] + exact ⟨z, by rwa [ProbComp.support_eval], rfl⟩ + obtain ⟨y, hy, hyz⟩ := (PMF.mem_support_map_iff _ _ _).mp hz' + obtain ⟨W'', part', hy', hC'⟩ := + Lean.Karger.isContractionOf_of_mem_support_contractTimes (by omega) s hC hy + obtain rfl := hst'.eq_of_heldGraph_eq (hyz.symm.trans hy') + exact ⟨hT, hmod, W', part', hC', hst'⟩ + · calc _ ≤ _ := Lean.Karger.survives_contractTimes ht hmin s hC hB hBmin + _ = (m.eval.map fun z => heldGraph wb str z.1).toOuterMeasure + {G | Lean.Karger.Survives W₀ (pullbackCut part B) t G} := by + rw [hlaw, PMF.toOuterMeasure_map_apply] + rfl + _ ≤ _ := by + rw [PMF.toOuterMeasure_map_apply] + refine PMF.toOuterMeasure_mono _ fun z ⟨⟨W'', part', B', hG, hC', hpb⟩, hz⟩ => ?_ + rw [ProbComp.support_eval] at hz + obtain ⟨⟨-, W', -, hst'⟩, -⟩ := hsup z hz + obtain rfl := hst'.eq_of_heldGraph_eq hG + exact ⟨W', part', B', hC', hst'.workspace, hst'.regs_totS, hpb⟩ /-- At `t = 2`, any state satisfying `SurvivalPost W₀ wb db str 2 C_star y` where `C_star` is a non-trivial cut attaining `minCut W₀` stores `minCut W₀` in `y.mem (wb + 1)`. -/ @@ -2982,20 +2796,10 @@ theorem survivalPost_two_mem_eq {n : ℕ} {W₀ : Fin n → Fin n → ℕ} {wb d (hnt : IsNonTrivialCut C_star) (hmin : cutWeight W₀ C_star = minCut W₀) (hsurv : SurvivalPost W₀ wb db str 2 C_star y) : y.mem (wb + 1) = minCut W₀ := by - rcases hsurv with ⟨W', part', B', hC', hws', _, hpb'⟩ - have hB'_nt : IsNonTrivialCut B' := - isNonTrivialCut_of_pullbackCut part' (hpb' ▸ hnt) - rw [isNonTrivialCut_iff_card, Fintype.card_fin] at hB'_nt - have hcard1 : B'.card = 1 := by omega - rcases Finset.card_eq_one.mp hcard1 with ⟨b, rfl⟩ - have hcell : y.mem (wb + 1) = W' 0 1 := by - simpa using hws'.1 0 1 - rw [hcell, ← hmin, ← hpb', cutWeight_pullbackCut hC'] - have hb : b = 0 ∨ b = 1 := by omega - rcases hb with rfl | rfl - · exact (cutWeight_two_singleton_zero hC'.multigraph).symm - · have hcompl : ({(1 : Fin 2)} : Finset (Fin 2)) = Finset.univ \ {0} := by decide - rw [hcompl, cutWeight_compl hC'.multigraph, cutWeight_two_singleton_zero hC'.multigraph] + obtain ⟨W', part', B', hC', hws', -, hpb'⟩ := hsurv + have hB' : IsNonTrivialCut B' := isNonTrivialCut_of_pullbackCut part' (hpb' ▸ hnt) + rw [show y.mem (wb + 1) = W' 0 1 by simpa using hws'.1 0 1, + ← cutWeight_fin_two hC'.multigraph hB', ← cutWeight_pullbackCut hC', hpb', hmin] /-! ### Register-embedding (`Code.rename`) wrappers for callers with `r ≥ 16` -/ diff --git a/Complexity/Computability/Complexity/Classes/Promise/Time.lean b/Complexity/Computability/Complexity/Classes/Promise/Time.lean index c3bfe88d4f..fa2cc61177 100644 --- a/Complexity/Computability/Complexity/Classes/Promise/Time.lean +++ b/Complexity/Computability/Complexity/Classes/Promise/Time.lean @@ -19,9 +19,13 @@ the output is `[true]` with probability at least `2/3`, and on no-instances it i probability at least `2/3`. No probability gap or answer is required outside the promise. This is the library's time-indexed native-machine convention, extending `BPTIME` to partial -promises. It does not define the class through bounded-error total completions. A strict-majority -completion belongs to `PPTIME` at the same caller-supplied clock, with ties rejecting; this is not -a bounded-error completion in `BPTIME`. +promises: a decision problem is in `PromiseBPTIME` exactly when it is in `BPTIME`. It does not +define the class through bounded-error total completions. A strict-majority completion belongs to +`PPTIME` at the same caller-supplied clock, with ties rejecting; this is not a bounded-error +completion in `BPTIME`. + +The characterization by sample-and-verify and coin replay at the same clock, up to constant +factors, is in `Complexity.Computability.Complexity.Classes.Promise.Time.Verifier`. ## Main definitions @@ -30,7 +34,11 @@ a bounded-error completion in `BPTIME`. ## Main results +* `Turing.MultiTapePTM.solvesPromiseWithBoundedErrorInTime_ofSet_iff`, + `ofSet_mem_PromiseBPTIME`: on decision problems, the notions are + `Turing.MultiTapePTM.DecidesWithBoundedErrorInTime` and `BPTIME`. * `PromiseBPTIME_mono`: increasing the time bound preserves membership. +* `mem_PromiseBPTIME_of_subset`: shrinking either side of the promise preserves membership. * `promiseClass_BPTIME_subset_PromiseBPTIME`: total bounded-error completions give witnesses. * `PromiseBPTIME_subset_promiseClass_PPTIME`: a strict-majority completion at the same time scale. -/ @@ -65,6 +73,29 @@ theorem SolvesPromiseWithBoundedErrorInTime.mono · rw [machine.eval_runClosed_eq_of_halted _ (ht a) hhalt] exact ⟨hyes, hno⟩ +/-- A machine solving a promise problem solves every promise problem with fewer yes-instances and +fewer no-instances. -/ +theorem SolvesPromiseWithBoundedErrorInTime.of_subset + {machine : MultiTapePTM k Bool State} {enc : α ↪ List Bool} {Q Q' : PromiseProblem α} + {t : α → ℕ} (h : machine.SolvesPromiseWithBoundedErrorInTime enc Q t) + (hyes : Q'.yes ⊆ Q.yes) (hno : Q'.no ⊆ Q.no) : + machine.SolvesPromiseWithBoundedErrorInTime enc Q' t := fun a => + let ⟨hhalt, hQyes, hQno⟩ := h a + ⟨hhalt, fun ha => hQyes (hyes ha), fun ha => hQno (hno ha)⟩ + +/-- On a decision problem, solving with bounded error is deciding with bounded error. -/ +theorem solvesPromiseWithBoundedErrorInTime_ofSet_iff {machine : MultiTapePTM k Bool State} + {enc : α ↪ List Bool} {A : Set α} {t : α → ℕ} : + machine.SolvesPromiseWithBoundedErrorInTime enc (PromiseProblem.ofSet A) t ↔ + machine.DecidesWithBoundedErrorInTime enc A t := by + refine forall_congr' fun a => and_congr_right fun _ => ?_ + by_cases ha : a ∈ A + · have hno : a ∉ (PromiseProblem.ofSet A).no := fun h => h ha + simp only [MultiTapeTM.indicator, ha, ite_true] + exact ⟨fun h => h.1 ha, fun h => ⟨fun _ => h, fun h' => absurd h' hno⟩⟩ + · simp only [MultiTapeTM.indicator, ha, ite_false] + exact ⟨fun h => h.2 ha, fun h => ⟨fun h' => absurd h' ha, fun _ => h⟩⟩ + end Turing.MultiTapePTM namespace Cslib.Complexity @@ -88,6 +119,21 @@ theorem PromiseBPTIME_mono {T₁ T₂ : ℕ → ℕ} (h : ∀ n, T₁ n ≤ T₂ exact ⟨c₁, c₂, k, State, hfinite, machine, hQ.mono fun a => Nat.add_le_add_right (Nat.mul_le_mul_left _ (h _)) _⟩ +/-- A promise problem with fewer yes-instances and fewer no-instances than one in `PromiseBPTIME` +is in `PromiseBPTIME`. -/ +theorem mem_PromiseBPTIME_of_subset {Q Q' : PromiseProblem α} (hQ : Q ∈ PromiseBPTIME enc T) + (hyes : Q'.yes ⊆ Q.yes) (hno : Q'.no ⊆ Q.no) : Q' ∈ PromiseBPTIME enc T := + let ⟨c₁, c₂, k, State, hfinite, machine, hQ⟩ := hQ + ⟨c₁, c₂, k, State, hfinite, machine, hQ.of_subset hyes hno⟩ + +/-- A decision problem, as a promise problem, is in `PromiseBPTIME` exactly when it is in +`BPTIME`. -/ +@[simp] +theorem ofSet_mem_PromiseBPTIME {A : Set α} : + PromiseProblem.ofSet A ∈ PromiseBPTIME enc T ↔ A ∈ BPTIME enc T := by + simp only [PromiseBPTIME, BPTIME, Set.mem_ofPred_eq, + MultiTapePTM.solvesPromiseWithBoundedErrorInTime_ofSet_iff] + /-- A bounded-error total completion supplies a native bounded-error promise solver. -/ theorem promiseClass_BPTIME_subset_PromiseBPTIME : promiseClass (BPTIME enc T) ⊆ PromiseBPTIME enc T := by diff --git a/Complexity/Computability/Complexity/Classes/Promise/Time/Verifier.lean b/Complexity/Computability/Complexity/Classes/Promise/Time/Verifier.lean new file mode 100644 index 0000000000..dded27da8b --- /dev/null +++ b/Complexity/Computability/Complexity/Classes/Promise/Time/Verifier.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +-- upstream: candidate + +public import Complexity.Computability.Complexity.AcceptCount +public import Complexity.Computability.Complexity.Classes.Promise.Time +import Complexity.Computability.Complexity.Classes.Time.SampleVerify +import Complexity.Computability.Machines.Turing.MultiTape.Internal.EqualityPrimitives +import Complexity.Computability.Machines.Turing.MultiTape.Internal.OCombinators +import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.CoinTape +import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.ReplayInput +import Complexity.Foundations.Analysis.ENNRealFraction + +/-! +# Verifier characterization of `PromiseBPTIME` within explicit time + +Promise problems [Goldreich][Goldreich2006] in `Cslib.Complexity.PromiseBPTIME enc t` are +characterized by deterministic verifiers reading random strings, keeping the time bound up to +constant factors: + +* **Sample and verify** (`Cslib.Complexity.mem_PromiseBPTIME_of_verifier`). If a verifier `V` is + computable within time `T (a, w)` on encoded pairs, the length `ℓ a` of the random string is + computable in unary within `Tℓ a`, and `(enc a).length + Tℓ a + T (a, w)` is within + `O(t (enc a).length)`, then a promise problem is in `PromiseBPTIME enc t` when at least two + thirds of the strings of length `ℓ a` are accepted on its yes-instances and rejected on its + no-instances. The machine is `Cslib.Complexity.exists_machine_sampleVerify`. +* **Coin replay** (`Cslib.Complexity.exists_verifier_of_mem_PromiseBPTIME`). A promise problem in + `PromiseBPTIME enc t` has a verifier computable in linear time on encoded pairs: replay the + coins on the machine and test whether the output is `[true]`. Every random-string length of at + least `c * t (enc a).length + c` works, since a halted run ignores further coins. + +The polynomial characterization of `PromiseBPP` +(`Cslib.Complexity.mem_PromiseBPP_iff_exists_isPPTOn`) loses the polynomial degree; these +explicit-time forms are what a time hierarchy for promise problems needs. Such a hierarchy is +known without advice, by delayed diagonalization [He][He2025], while the hierarchy for `BPTIME` +itself is open. + +## Main results + +* `Cslib.Complexity.mem_PromiseBPTIME_of_verifier`: sample and verify within explicit time. +* `Cslib.Complexity.exists_verifier_of_mem_PromiseBPTIME`: a linear-time coin-replay verifier. + +## References + +* [O. Goldreich, *On promise problems: a survey*][Goldreich2006] +* [S. He, *A note on a hierarchy theorem for promise-BPTIME*][He2025] +-/ + +public section + +namespace Cslib.Complexity + +open _root_.Turing _root_.Turing.MultiTapeTM +open scoped ENNReal + +variable {α : Type} {enc : α ↪ List Bool} + +/-- The probability that the verdict on a uniformly random string of length `n` is `b` is the +fraction of the strings with that verdict. -/ +private theorem uniformList_map_verdict_apply (V : α × List Bool → Bool) (a : α) (n : ℕ) + (b : Bool) : ((BitString.uniformList n).map fun w => [V (a, w)]) [b] = + (acceptCount (fun p => V p == b) a n : ℝ≥0∞) / 2 ^ n := by + rw [BitString.uniformList_map_apply] + simp only [acceptCount, List.cons.injEq, and_true, beq_iff_eq] + +/-- **Sample and verify, within explicit time.** If a verifier `V` is computable within time +`T (a, w)` on encoded pairs, and the length `ℓ a` of the random string is computable in unary +within time `Tℓ a`, with `(enc a).length + Tℓ a + T (a, w) ≤ C * t (enc a).length + C` for every +string `w` of length `ℓ a`, then a promise problem is in `PromiseBPTIME enc t` when `V` accepts at +least two thirds of the strings of length `ℓ a` together with each yes-instance `a`, and rejects at +least two thirds of them together with each no-instance. -/ +theorem mem_PromiseBPTIME_of_verifier {Q : PromiseProblem α} {V : α × List Bool → Bool} + {ℓ : α → ℕ} {t : ℕ → ℕ} {Tℓ Sℓ : α → ℕ} {T S : α × List Bool → ℕ} {C : ℕ} + (hℓ : ComputableInO ℓ enc encUnary Tℓ Sℓ) + (hV : ComputableInO V (encPair enc encBits) encBool T S) + (ht : ∀ a w, w.length = ℓ a → (enc a).length + Tℓ a + T (a, w) ≤ C * t (enc a).length + C) + (hyes : ∀ a ∈ Q.yes, 2 * 2 ^ ℓ a ≤ 3 * acceptCount V a (ℓ a)) + (hno : ∀ a ∈ Q.no, 2 * 2 ^ ℓ a ≤ 3 * acceptCount (fun p => !V p) a (ℓ a)) : + Q ∈ PromiseBPTIME enc t := by + obtain ⟨c₁, c₂, k, State, hfinite, machine, hmachine⟩ := exists_machine_sampleVerify hℓ hV ht + refine ⟨c₁, c₂, k, State, hfinite, machine, fun a => ⟨(hmachine a).1, fun ha => ?_, fun ha => ?_⟩⟩ + · rw [(hmachine a).2, uniformList_map_verdict_apply, + ENNReal.two_div_three_le_natCast_div_two_pow_iff] + simpa only [beq_true] using hyes a ha + · rw [(hmachine a).2, uniformList_map_verdict_apply, + ENNReal.two_div_three_le_natCast_div_two_pow_iff] + simpa only [beq_false] using hno a ha + +/-- **A linear-time verifier for promise-problem probabilistic time.** A promise problem in +`PromiseBPTIME enc t` has a verifier computable in linear time on encoded pairs. For a constant +`c`, every random-string length `L ≥ c * t (enc a).length + c` works: the verifier accepts at least +two thirds of the strings of length `L` together with each yes-instance, and rejects at least two +thirds of them together with each no-instance. The verifier replays the coins on the machine and +tests whether the output is `[true]`. -/ +theorem exists_verifier_of_mem_PromiseBPTIME {Q : PromiseProblem α} {t : ℕ → ℕ} + (hQ : Q ∈ PromiseBPTIME enc t) : + ∃ (V : α × List Bool → Bool) (c : ℕ), + ComputableInO V (encPair enc encBits) encBool (fun p => (encPair enc encBits p).length) + (fun p => (encPair enc encBits p).length) ∧ + ∀ a L, c * t (enc a).length + c ≤ L → + (a ∈ Q.yes → 2 * 2 ^ L ≤ 3 * acceptCount V a L) ∧ + (a ∈ Q.no → 2 * 2 ^ L ≤ 3 * acceptCount (fun p => !V p) a L) := by + obtain ⟨c₁, c₂, k, State, hfinite, machine, hQ⟩ := hQ + let V : α × List Bool → Bool := fun p => decide (machine.runClosedCoins p.2 (enc p.1) = [true]) + refine ⟨V, c₁ + c₂, ?_, fun a L hL => ?_⟩ + · -- replay the coins, then compare the output with `[true]` + have hswap : ComputableInO (fun p : α × List Bool => (p.2, enc p.1)) (encPair enc encBits) + (encPair encBits encBits) + (fun p => (encPair enc encBits p).length + + ((encPair enc encBits p).length + (enc p.1).length)) + (fun p => (encPair enc encBits p).length + + ((encPair enc encBits p).length + (enc p.1).length)) := + (ComputableInO.snd enc encBits).prod + ((ComputableInO.of_eq (f := fun x : α => enc x) (encIn := enc) (encMid := encBits) + fun _ => rfl).comp (ComputableInO.fst enc encBits)) + have hrun := (ComputableInO.of_linear + (MultiTapePTM.computableInDegree_runClosedCoins machine)).comp hswap + obtain ⟨cr, hcr⟩ := hrun.length_le_time + have heq := ComputableInO.eqWords.comp ((ComputableInO.const (encIn := encPair enc encBits) + (encMid := encBits) [true]).prod hrun) + have hfun : ((fun p : List Bool × List Bool => decide (p.1 = p.2)) ∘ + fun p : α × List Bool => ([true], ((fun q : List Bool × List Bool => + machine.runClosedCoins q.1 q.2) ∘ fun p : α × List Bool => (p.2, enc p.1)) p)) = V := by + funext p + simp [V, eq_comm] + rw [hfun] at heq + -- every part is linear in the encoded pair, including the replayed output + have hbound (p : α × List Bool) : + (encPair enc encBits p).length + ((encPair enc encBits p).length + + ((encPair enc encBits p).length + (enc p.1).length) + + (encPair encBits encBits (p.2, enc p.1)).length) + + 2 * ((machine.runClosedCoins p.2 (enc p.1)).length + 2) ≤ + (9 + 10 * cr) * ((encPair enc encBits p).length + 1) := by + have hc := hcr p + simp only [Function.comp_apply, encBits_apply] at hc + have hle : (enc p.1).length ≤ (encPair enc encBits p).length := by + simp only [encPair_apply, List.length_append, length_frame, encBits_apply] + omega + have hsw : (encPair encBits encBits (p.2, enc p.1)).length ≤ + 2 * (encPair enc encBits p).length := by + simp only [encPair_apply, List.length_append, length_frame, encBits_apply] + omega + generalize (encPair enc encBits p).length = N at * + generalize (machine.runClosedCoins p.2 (enc p.1)).length = R at * + generalize (encPair encBits encBits (p.2, enc p.1)).length = W at * + have hR : R ≤ cr * (5 * N + 1) := hc.trans (Nat.mul_le_mul_left cr (by omega)) + nlinarith + refine heq.mono (9 + 10 * cr) (fun p => ?_) fun p => ?_ + · have := hbound p + simp only [Function.comp_apply, List.length_singleton] at this ⊢ + nlinarith + · have := hbound p + simp only [Function.comp_apply, List.length_singleton] at this ⊢ + omega + · -- at `L` coins, the halted run is distributed as the replays + obtain ⟨hhalt, hyes, hno⟩ := hQ a + have hT : c₁ * t (enc a).length + c₂ ≤ L := + le_trans (by nlinarith) hL + have heval : ProbComp.eval (machine.runClosed L (enc a)) = + (BitString.uniformList L).map fun w => machine.runClosedCoins w (enc a) := by + rw [MultiTapePTM.eval_runClosed_eq_map_coins] + rw [← machine.eval_runClosed_eq_of_halted _ hT hhalt, heval, + BitString.uniformList_map_apply, ENNReal.two_div_three_le_natCast_div_two_pow_iff] at hyes hno + refine ⟨fun ha => ?_, fun ha => ?_⟩ + · simpa only [acceptCount, V, decide_eq_true_eq] using hyes ha + · refine (hno ha).trans (Nat.mul_le_mul_left 3 (Finset.card_le_card fun w hw => ?_)) + simp only [Finset.mem_filter, Finset.mem_univ, true_and, V, Bool.not_eq_true', + decide_eq_false_iff_not] at hw ⊢ + rw [hw] + simp + +end Cslib.Complexity diff --git a/Complexity/Computability/Complexity/Classes/Time.lean b/Complexity/Computability/Complexity/Classes/Time.lean index 57c0226098..73831d7901 100644 --- a/Complexity/Computability/Complexity/Classes/Time.lean +++ b/Complexity/Computability/Complexity/Classes/Time.lean @@ -20,6 +20,7 @@ import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.ReplayIn import Complexity.Computability.Probabilistic.PPT.Capture import Complexity.Computability.Probabilistic.PPT.Clock import Complexity.Computability.Probabilistic.Sampling +import Complexity.Foundations.Analysis.ENNRealFraction import Complexity.Probability.PMF.Map import Mathlib.Data.Set.Finite.List @@ -370,25 +371,6 @@ theorem mem_NP_iff_exists_mem_NTIME {α : Type} {enc : α ↪ List Bool} {A : Se open Cslib.Probability open scoped ENNReal -/-- A probability of at least `2 / 3` is a fraction of at least two thirds. -/ -private theorem two_thirds_le_div_iff {c n : ℕ} : - (2 / 3 : ℝ≥0∞) ≤ c / 2 ^ n ↔ 2 * 2 ^ n ≤ 3 * c := by - rw [ENNReal.le_div_iff_mul_le (Or.inl (pow_ne_zero _ two_ne_zero)) - (Or.inl (ENNReal.pow_ne_top ENNReal.ofNat_ne_top)), div_eq_mul_inv, mul_right_comm, - ← div_eq_mul_inv, ENNReal.div_le_iff (by norm_num) (by norm_num)] - constructor - · intro h - have : ((2 * 2 ^ n : ℕ) : ℝ≥0∞) ≤ ((3 * c : ℕ) : ℝ≥0∞) := by - push_cast - rw [mul_comm (3 : ℝ≥0∞)] - exact h - exact_mod_cast this - · intro h - have : ((2 * 2 ^ n : ℕ) : ℝ≥0∞) ≤ ((3 * c : ℕ) : ℝ≥0∞) := by exact_mod_cast h - push_cast at this - rw [mul_comm (c : ℝ≥0∞)] - exact this - /-- An injective map keeps the probability of the image of a value. -/ private theorem map_apply_of_injective {β γ : Type} {p : PMF β} {f : β → γ} (hf : Function.Injective f) (b : β) : p.map f (f b) = p b := by @@ -428,7 +410,7 @@ theorem mem_BPP_iff_exists_mem_BPTIME {α : Type} {enc : α ↪ List Bool} {A : map_apply_of_injective encBool.injective] simp only [program, ProbComp.eval_map, BitString.eval_sampleList] rw [BitString.uniformList_map_apply] - exact two_thirds_le_div_iff.mpr (hA.two_mul_le a) + exact ENNReal.two_div_three_le_natCast_div_two_pow_iff.mpr (hA.two_mul_le a) · rintro ⟨d, c₁, c₂, k, State, hfinite, machine, hA⟩ -- replay the coins refine ⟨Polynomial.C c₁ * Polynomial.X ^ d + Polynomial.C c₂, @@ -444,7 +426,7 @@ theorem mem_BPP_iff_exists_mem_BPTIME {α : Type} {enc : α ↪ List Bool} {A : simp have hprob := (hA a).2 rw [MultiTapePTM.eval_runClosed_eq_map_coins, BitString.uniformList_map_apply, - two_thirds_le_div_iff] at hprob + ENNReal.two_div_three_le_natCast_div_two_pow_iff] at hprob dsimp only [DecidesWithBoundedError, PromiseProblem.SolvesWithBoundedError, BoundedErrorAt] rw [heval] constructor diff --git a/Complexity/Computability/Complexity/Classes/Time/SampleVerify.lean b/Complexity/Computability/Complexity/Classes/Time/SampleVerify.lean new file mode 100644 index 0000000000..f21a52592d --- /dev/null +++ b/Complexity/Computability/Complexity/Classes/Time/SampleVerify.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +-- upstream: candidate + +public import Complexity.Computability.Machines.Turing.MultiTape.Complexity.BigO +public import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.Closed +public import Complexity.Probability.BitString +import Complexity.Computability.Machines.Turing.MultiTape.Internal.OCombinators +import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.Composition +import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.Deterministic +import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.PairSampler +import Complexity.Computability.Machines.Turing.MultiTape.Run +import Complexity.Probability.PMF.Bind + +/-! +# Sampling a random string and running a verifier, within explicit time + +A fair-coin machine can draw a uniformly random string `w` of length `ℓ a` and output the verdict +`V (a, w)` of a deterministic verifier on the pair `(a, w)`, within the time it takes to write +`ℓ a` in unary and to run the verifier, up to constant factors +(`Cslib.Complexity.exists_machine_sampleVerify`). The machine is a closed fair-coin composition: + +* a deterministic machine writes `frame (enc a)` followed by `ℓ a` ones; +* the fixed sampler `Turing.MultiTapePTM.pairSampler` copies the framed instance and replaces the + ones by fair coins; +* a deterministic machine runs the verifier. + +Every run halts within the clock, and the output is distributed as `[V (a, w)]` for `w` uniform of +length `ℓ a`. Read nondeterministically, the machine guesses and verifies a certificate +(`Cslib.Complexity.setOf_exists_mem_NTIME`); read probabilistically, it samples and verifies +(`Cslib.Complexity.mem_PromiseBPTIME_of_verifier`). Unlike the polynomial compiler of PPT +programs (`Cslib.Probability.IsPPTOn.exists_halting_machine`), the clock keeps the time bound up to +constant factors. + +## Main results + +* `Cslib.Complexity.exists_machine_sampleVerify`: the sample-and-verify machine within explicit + time, with its output distribution. +-/ + +public section + +namespace Cslib.Complexity + +open _root_.Turing _root_.Turing.MultiTapeTM + +variable {α : Type} {enc : α ↪ List Bool} + +/-- **Sample and verify, within explicit time.** If a verifier `V` is computable within time +`T (a, w)` on encoded pairs, and the length `ℓ a` of the random string is computable in unary +within time `Tℓ a`, and `(enc a).length + Tℓ a + T (a, w) ≤ C * t (enc a).length + C` for every +string `w` of length `ℓ a`, then a fair-coin machine with a binary alphabet and finitely many +states halts on every run within time `c₁ * t (enc a).length + c₂` and outputs `[V (a, w)]` for a +uniformly random `w` of length `ℓ a`. -/ +theorem exists_machine_sampleVerify {V : α × List Bool → Bool} {ℓ : α → ℕ} {t : ℕ → ℕ} + {Tℓ Sℓ : α → ℕ} {T S : α × List Bool → ℕ} {C : ℕ} + (hℓ : ComputableInO ℓ enc encUnary Tℓ Sℓ) + (hV : ComputableInO V (encPair enc encBits) encBool T S) + (ht : ∀ a w, w.length = ℓ a → (enc a).length + Tℓ a + T (a, w) ≤ C * t (enc a).length + C) : + ∃ (c₁ c₂ k : ℕ) (State : Type) (_ : Finite State) (machine : MultiTapePTM k Bool State), + ∀ a, (∀ final ∈ (ProbComp.eval (machine.runClosedConfigFrom (c₁ * t (enc a).length + c₂) + (machine.initialConfig (enc a)))).support, final.tapes.state = none) ∧ + ProbComp.eval (machine.runClosed (c₁ * t (enc a).length + c₂) (enc a)) = + (BitString.uniformList (ℓ a)).map fun w => [V (a, w)] := by + -- the deterministic preparation and the verifier, as machines + obtain ⟨c₁, ⟨k₁, Q₁, _, tm₁, h₁⟩, -⟩ := + (ComputableInO.of_eq (f := fun a : α => a) (encIn := enc) (encMid := enc) fun _ => rfl).prod hℓ + obtain ⟨c₃, ⟨k₃, Q₃, _, tm₃, h₃⟩, -⟩ := hV + let L (a : α) : ℕ := ℓ a + let u (a : α) : List Bool := frame (enc a) ++ List.replicate (L a) true + let t₁ (a : α) : ℕ := c₁ * ((enc a).length + Tℓ a + 1) + let t₂ (a : α) : ℕ := (u a).length + 1 + let t₃ (a : α) : ℕ := c₃ * (C * t (enc a).length + C + 1) + have hrun₁ (a : α) := (h₁ a).runFrom_of_le (le_refl (t₁ a)) + have hlen₁ (a : α) : (u a).length ≤ t₁ a := (h₁ a).length_output_le + -- the first phase writes the framed instance and the unary length of the random string + let M₁ : MultiTapePTM k₁ Bool Q₁ := MultiTapePTM.ofDeterministic tm₁ + have hfirst₁ (a : α) : ∀ final ∈ (ProbComp.eval + (M₁.runClosedConfigFrom (t₁ a) (M₁.initialConfig (enc a)))).support, + final.tapes.state = none := by + intro final hfinal + rw [MultiTapePTM.eval_runClosedConfigFrom_ofDeterministic, PMF.mem_support_pure_iff] at hfinal + subst hfinal + exact (hrun₁ a).1 + have hout₁ (a : α) : ProbComp.eval (M₁.runClosed (t₁ a) (enc a)) = PMF.pure (u a) := by + rw [MultiTapePTM.eval_runClosed_ofDeterministic, (hrun₁ a).2] + rfl + -- the sampler copies the framed instance and draws the random string + have hsecond₁ (a : α) : ∀ word ∈ (ProbComp.eval (M₁.runClosed (t₁ a) (enc a))).support, + ∀ final ∈ (ProbComp.eval (MultiTapePTM.pairSampler.runClosedConfigFrom (t₂ a) + (MultiTapePTM.pairSampler.initialConfig word))).support, final.tapes.state = none := by + intro word hword + rw [hout₁ a, PMF.mem_support_pure_iff] at hword + subst hword + exact MultiTapePTM.pairSampler_halted (enc a) (List.replicate (L a) true) + let P₁₂ := MultiTapePTM.pairSampler.comp M₁ false + let t₁₂ (a : α) : ℕ := t₁ a + (t₁ a + 4 + t₂ a) + have heval₁₂ (a : α) : ProbComp.eval (P₁₂.runClosed (t₁₂ a) (enc a)) = + (BitString.uniformList (L a)).map (frame (enc a) ++ ·) := by + rw [MultiTapePTM.eval_comp M₁ MultiTapePTM.pairSampler false (enc a) (t₁ a) (t₂ a) + (hfirst₁ a) (hsecond₁ a), hout₁ a, Probability.PMF.monad_bind_eq_bind, PMF.pure_bind] + simpa only [List.length_replicate, u] using + MultiTapePTM.eval_pairSampler (enc a) (List.replicate (L a) true) + have hhalt₁₂ (a : α) := MultiTapePTM.comp_halted M₁ MultiTapePTM.pairSampler false (enc a) + (t₁ a) (t₂ a) (hfirst₁ a) (hsecond₁ a) + -- the verifier runs on every sampled pair within the uniform clock `t₃` + let M₃ : MultiTapePTM k₃ Bool Q₃ := MultiTapePTM.ofDeterministic tm₃ + have hrun₃ (a : α) (w : List Bool) (hw : w.length = L a) := + (h₃ (a, w)).runFrom_of_le (J := t₃ a) (Nat.mul_le_mul_left c₃ (by + have := ht a w hw + omega)) + have hword (a : α) {word : List Bool} + (hword : word ∈ (ProbComp.eval (P₁₂.runClosed (t₁₂ a) (enc a))).support) : + ∃ w : List Bool, w.length = L a ∧ word = encPair enc encBits (a, w) := by + rw [heval₁₂ a] at hword + obtain ⟨w, hw, rfl⟩ := (PMF.mem_support_map_iff _ _ _).mp hword + exact ⟨w, BitString.mem_support_uniformList_iff.mp hw, rfl⟩ + have hsecond₂ (a : α) : ∀ word ∈ (ProbComp.eval (P₁₂.runClosed (t₁₂ a) (enc a))).support, + ∀ final ∈ (ProbComp.eval (M₃.runClosedConfigFrom (t₃ a) (M₃.initialConfig word))).support, + final.tapes.state = none := by + intro word hw final hfinal + obtain ⟨w, hwlen, rfl⟩ := hword a hw + rw [MultiTapePTM.eval_runClosedConfigFrom_ofDeterministic, PMF.mem_support_pure_iff] at hfinal + subst hfinal + exact (hrun₃ a w hwlen).1 + let P := M₃.comp P₁₂ false + let total (a : α) : ℕ := t₁₂ a + (t₁₂ a + 4 + t₃ a) + have hhalt (a : α) := MultiTapePTM.comp_halted P₁₂ M₃ false (enc a) (t₁₂ a) (t₃ a) (hhalt₁₂ a) + (hsecond₂ a) + -- the output is the verdict on a uniformly random string + have heval (a : α) : ProbComp.eval (P.runClosed (total a) (enc a)) = + (BitString.uniformList (ℓ a)).map fun w => [V (a, w)] := by + rw [MultiTapePTM.eval_comp P₁₂ M₃ false (enc a) (t₁₂ a) (t₃ a) (hhalt₁₂ a) (hsecond₂ a), + Probability.PMF.monad_bind_eq_bind, heval₁₂ a, PMF.bind_map, ← PMF.bind_pure_comp] + refine Probability.PMF.bind_congr_on_support _ _ _ fun w hw => ?_ + have hwlen : w.length = L a := BitString.mem_support_uniformList_iff.mp hw + simp only [Function.comp_apply] + rw [MultiTapePTM.eval_runClosed_ofDeterministic] + exact congrArg PMF.pure (hrun₃ a w hwlen).2 + -- the composed clock is within `O(t)` + have hle (a : α) : total a ≤ (6 * c₁ + c₃) * C * t (enc a).length + + ((6 * c₁ + c₃) * (C + 1) + 14) := by + set X := C * t (enc a).length + C + 1 + have hX₁ : t₁ a ≤ c₁ * X := Nat.mul_le_mul_left c₁ (by + have := ht a (List.replicate (L a) false) (List.length_replicate ..) + omega) + have htotal : total a ≤ 6 * t₁ a + 14 + t₃ a := by + have := hlen₁ a + simp only [total, t₁₂, t₂] + omega + have hX₃ : t₃ a = c₃ * X := rfl + calc total a ≤ 6 * (c₁ * X) + 14 + c₃ * X := by + have := Nat.mul_le_mul_left 6 hX₁ + rw [hX₃] at htotal + omega + _ = (6 * c₁ + c₃) * C * t (enc a).length + ((6 * c₁ + c₃) * (C + 1) + 14) := by + simp only [X] + ring + refine ⟨(6 * c₁ + c₃) * C, (6 * c₁ + c₃) * (C + 1) + 14, _, _, inferInstance, P, fun a => ?_⟩ + refine ⟨?_, ?_⟩ + · rw [P.eval_runClosedConfigFrom_eq_of_halted _ (hle a) (hhalt a)] + exact hhalt a + · rw [P.eval_runClosed_eq_of_halted _ (hle a) (hhalt a)] + exact heval a + +end Cslib.Complexity diff --git a/Complexity/Computability/Complexity/Classes/Time/Verifier.lean b/Complexity/Computability/Complexity/Classes/Time/Verifier.lean index bf32dd203c..73a333cbee 100644 --- a/Complexity/Computability/Complexity/Classes/Time/Verifier.lean +++ b/Complexity/Computability/Complexity/Classes/Time/Verifier.lean @@ -9,15 +9,12 @@ module public import Complexity.Computability.Complexity.Classes.Time import Complexity.Computability.Complexity.Classes.NP.Nondeterministic +import Complexity.Computability.Complexity.Classes.Time.SampleVerify import Complexity.Computability.Machines.Turing.MultiTape.Internal.EqualityPrimitives import Complexity.Computability.Machines.Turing.MultiTape.Internal.OCombinators import Complexity.Computability.Machines.Turing.MultiTape.Internal.ResourceFacts -import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.Composition -import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.PairSampler import Complexity.Computability.Machines.Turing.MultiTape.Probabilistic.ReplayInput -import Complexity.Computability.Machines.Turing.MultiTape.Run import Complexity.Probability.BitString -import Complexity.Probability.PMF.Bind /-! # Nondeterministic time through verifiers, with explicit bounds @@ -33,14 +30,12 @@ two directions here keep it. `{a | ∃ w, w.length = ℓ a ∧ V (a, w) = true}` lies in `NTIME enc t` whenever `(enc a).length + Tℓ a + T (a, w)` is within `O(t (enc a).length)` on certificates of that length. The certificate length may depend on the instance, not only on its encoded length. - The machine is the nondeterministic reading of a closed fair-coin composition: - - a deterministic machine writes `frame (enc a)` followed by `ℓ` ones; - - the fixed sampler `Turing.MultiTapePTM.pairSampler` copies the framed instance and replaces - the ones by fair coins; - - a deterministic machine runs the verifier. - - Its computation paths are exactly the coin replays, so it accepts exactly when some - certificate is accepted, and every branch halts within the composed clock. + The machine is the nondeterministic reading of the sample-and-verify machine + (`Cslib.Complexity.exists_machine_sampleVerify`), a closed fair-coin composition that writes + `frame (enc a)` followed by `ℓ` ones, replaces the ones by fair coins with the fixed sampler + `Turing.MultiTapePTM.pairSampler`, and runs the verifier. Its computation paths are exactly the + coin replays, so it accepts exactly when some certificate is accepted, and every branch halts + within the clock. * **Verifiers from nondeterministic time** (`Cslib.Complexity.exists_verifier_of_mem_NTIME`). A problem in `NTIME enc t` has a verifier that is computable in linear time on encoded pairs: check that the certificate, read as coins of the choice table @@ -81,116 +76,25 @@ theorem setOf_exists_mem_NTIME {V : α × List Bool → Bool} {ℓ : α → ℕ} (hV : ComputableInO V (encPair enc encBits) encBool T S) (ht : ∀ a w, w.length = ℓ a → (enc a).length + Tℓ a + T (a, w) ≤ C * t (enc a).length + C) : {a | ∃ w : List Bool, w.length = ℓ a ∧ V (a, w) = true} ∈ NTIME enc t := by - -- the deterministic preparation and the verifier, as machines - obtain ⟨c₁, ⟨k₁, Q₁, _, tm₁, h₁⟩, -⟩ := - (ComputableInO.of_eq (f := fun a : α => a) (encIn := enc) (encMid := enc) fun _ => rfl).prod hℓ - obtain ⟨c₃, ⟨k₃, Q₃, _, tm₃, h₃⟩, -⟩ := hV - let L (a : α) : ℕ := ℓ a - let u (a : α) : List Bool := frame (enc a) ++ List.replicate (L a) true - let t₁ (a : α) : ℕ := c₁ * ((enc a).length + Tℓ a + 1) - let t₂ (a : α) : ℕ := (u a).length + 1 - let t₃ (a : α) : ℕ := c₃ * (C * t (enc a).length + C + 1) - have hrun₁ (a : α) := (h₁ a).runFrom_of_le (le_refl (t₁ a)) - have hlen₁ (a : α) : (u a).length ≤ t₁ a := (h₁ a).length_output_le - -- the first phase writes the framed instance and the unary certificate length - let M₁ : MultiTapePTM k₁ Bool Q₁ := MultiTapePTM.ofDeterministic tm₁ - have hfirst₁ (a : α) : ∀ final ∈ (ProbComp.eval - (M₁.runClosedConfigFrom (t₁ a) (M₁.initialConfig (enc a)))).support, - final.tapes.state = none := by - intro final hfinal - rw [MultiTapePTM.eval_runClosedConfigFrom_ofDeterministic, PMF.mem_support_pure_iff] at hfinal - subst hfinal - exact (hrun₁ a).1 - have hout₁ (a : α) : ProbComp.eval (M₁.runClosed (t₁ a) (enc a)) = PMF.pure (u a) := by - rw [MultiTapePTM.eval_runClosed_ofDeterministic, (hrun₁ a).2] - rfl - -- the sampler copies the framed instance and guesses the certificate - have hsecond₁ (a : α) : ∀ word ∈ (ProbComp.eval (M₁.runClosed (t₁ a) (enc a))).support, - ∀ final ∈ (ProbComp.eval (MultiTapePTM.pairSampler.runClosedConfigFrom (t₂ a) - (MultiTapePTM.pairSampler.initialConfig word))).support, final.tapes.state = none := by - intro word hword - rw [hout₁ a, PMF.mem_support_pure_iff] at hword - subst hword - exact MultiTapePTM.pairSampler_halted (enc a) (List.replicate (L a) true) - let P₁₂ := MultiTapePTM.pairSampler.comp M₁ false - let t₁₂ (a : α) : ℕ := t₁ a + (t₁ a + 4 + t₂ a) - have heval₁₂ (a : α) : ProbComp.eval (P₁₂.runClosed (t₁₂ a) (enc a)) = - (BitString.uniformList (L a)).map (frame (enc a) ++ ·) := by - rw [MultiTapePTM.eval_comp M₁ MultiTapePTM.pairSampler false (enc a) (t₁ a) (t₂ a) - (hfirst₁ a) (hsecond₁ a), hout₁ a, Probability.PMF.monad_bind_eq_bind, PMF.pure_bind] - simpa only [List.length_replicate, u] using - MultiTapePTM.eval_pairSampler (enc a) (List.replicate (L a) true) - have hhalt₁₂ (a : α) := MultiTapePTM.comp_halted M₁ MultiTapePTM.pairSampler false (enc a) - (t₁ a) (t₂ a) (hfirst₁ a) (hsecond₁ a) - -- the verifier runs on every guessed pair within the uniform clock `t₃` - let M₃ : MultiTapePTM k₃ Bool Q₃ := MultiTapePTM.ofDeterministic tm₃ - have hrun₃ (a : α) (w : List Bool) (hw : w.length = L a) := - (h₃ (a, w)).runFrom_of_le (J := t₃ a) (Nat.mul_le_mul_left c₃ (by - have := ht a w hw - omega)) - have hword (a : α) {word : List Bool} - (hword : word ∈ (ProbComp.eval (P₁₂.runClosed (t₁₂ a) (enc a))).support) : - ∃ w : List Bool, w.length = L a ∧ word = encPair enc encBits (a, w) := by - rw [heval₁₂ a] at hword - obtain ⟨w, hw, rfl⟩ := (PMF.mem_support_map_iff _ _ _).mp hword - exact ⟨w, BitString.mem_support_uniformList_iff.mp hw, rfl⟩ - have hsecond₂ (a : α) : ∀ word ∈ (ProbComp.eval (P₁₂.runClosed (t₁₂ a) (enc a))).support, - ∀ final ∈ (ProbComp.eval (M₃.runClosedConfigFrom (t₃ a) (M₃.initialConfig word))).support, - final.tapes.state = none := by - intro word hw final hfinal - obtain ⟨w, hwlen, rfl⟩ := hword a hw - rw [MultiTapePTM.eval_runClosedConfigFrom_ofDeterministic, PMF.mem_support_pure_iff] at hfinal - subst hfinal - exact (hrun₃ a w hwlen).1 - let P := M₃.comp P₁₂ false - let total (a : α) : ℕ := t₁₂ a + (t₁₂ a + 4 + t₃ a) - -- the nondeterministic reading decides the problem - have hdec : P.toNTM.DecidesInTime enc - {a | ∃ w : List Bool, w.length = ℓ a ∧ V (a, w) = true} total := by - intro a - have htime : P.toNTM.RunsInTime (enc a) (total a) := P.runsInTime_toNTM - (MultiTapePTM.comp_halted P₁₂ M₃ false (enc a) (t₁₂ a) (t₃ a) (hhalt₁₂ a) (hsecond₂ a)) - refine ⟨htime, ?_⟩ - rw [MultiTapeNTM.accepts_iff_exists_time_eq htime, - P.exists_computationPath_toNTM_iff (P := fun cfg => cfg.output = [true])] - have hiff : (∃ final ∈ (ProbComp.eval (P.runClosedConfigFrom (total a) - (P.initialConfig (enc a)))).support, final.tapes.output = [true]) ↔ - [true] ∈ (ProbComp.eval (P.runClosed (total a) (enc a))).support := by - rw [MultiTapePTM.runClosed_eq_map, ProbComp.eval_map, PMF.mem_support_map_iff] - rw [hiff, MultiTapePTM.eval_comp P₁₂ M₃ false (enc a) (t₁₂ a) (t₃ a) (hhalt₁₂ a) - (hsecond₂ a), Probability.PMF.monad_bind_eq_bind, PMF.mem_support_bind_iff] - constructor - · rintro ⟨w, hw, hV⟩ - refine ⟨encPair enc encBits (a, w), ?_, ?_⟩ - · rw [heval₁₂ a] - exact (PMF.mem_support_map_iff _ _ _).mpr - ⟨w, BitString.mem_support_uniformList_iff.mpr hw, rfl⟩ - · rw [MultiTapePTM.eval_runClosed_ofDeterministic, (hrun₃ a w hw).2, PMF.mem_support_pure_iff] - simp [hV] - · rintro ⟨word, hw, hacc⟩ - obtain ⟨w, hwlen, rfl⟩ := hword a hw - rw [MultiTapePTM.eval_runClosed_ofDeterministic, (hrun₃ a w hwlen).2, - PMF.mem_support_pure_iff] at hacc - exact ⟨w, hwlen, by simpa using hacc⟩ - -- the composed clock is within `O(t)` - refine ⟨(6 * c₁ + c₃) * C, (6 * c₁ + c₃) * (C + 1) + 14, _, _, inferInstance, P.toNTM, - hdec.mono fun a => ?_⟩ - set X := C * t (enc a).length + C + 1 - have hX₁ : t₁ a ≤ c₁ * X := Nat.mul_le_mul_left c₁ (by - have := ht a (List.replicate (L a) false) (List.length_replicate ..) - omega) - have htotal : total a ≤ 6 * t₁ a + 14 + t₃ a := by - have := hlen₁ a - simp only [total, t₁₂, t₂] - omega - have hX₃ : t₃ a = c₃ * X := rfl - calc total a ≤ 6 * (c₁ * X) + 14 + c₃ * X := by - have := Nat.mul_le_mul_left 6 hX₁ - rw [hX₃] at htotal - omega - _ = (6 * c₁ + c₃) * C * t (enc a).length + ((6 * c₁ + c₃) * (C + 1) + 14) := by - simp only [X] - ring + obtain ⟨c₁, c₂, k, State, hfinite, machine, hmachine⟩ := exists_machine_sampleVerify hℓ hV ht + refine ⟨c₁, c₂, k, State, hfinite, machine.toNTM, fun a => ?_⟩ + -- the nondeterministic reading accepts exactly when some sampled string is accepted + have htime : machine.toNTM.RunsInTime (enc a) (c₁ * t (enc a).length + c₂) := + machine.runsInTime_toNTM (hmachine a).1 + refine ⟨htime, ?_⟩ + rw [MultiTapeNTM.accepts_iff_exists_time_eq htime, + machine.exists_computationPath_toNTM_iff (P := fun cfg => cfg.output = [true])] + set T := c₁ * t (enc a).length + c₂ + have hiff : (∃ final ∈ (ProbComp.eval (machine.runClosedConfigFrom T + (machine.initialConfig (enc a)))).support, final.tapes.output = [true]) ↔ + [true] ∈ (ProbComp.eval (machine.runClosed T (enc a))).support := by + rw [MultiTapePTM.runClosed_eq_map, ProbComp.eval_map, PMF.mem_support_map_iff] + rw [hiff, (hmachine a).2, PMF.mem_support_map_iff] + constructor + · rintro ⟨w, hw, hVw⟩ + exact ⟨w, BitString.mem_support_uniformList_iff.mpr hw, by rw [hVw]⟩ + · rintro ⟨w, hw, hVw⟩ + exact ⟨w, BitString.mem_support_uniformList_iff.mp hw, by simpa using hVw⟩ /-- **A linear-time verifier for nondeterministic time.** A problem in `NTIME enc t` has a verifier computable in linear time on encoded pairs. For a constant `c`, every certificate length diff --git a/Complexity/Computability/WordRAM/Randomized/Law.lean b/Complexity/Computability/WordRAM/Randomized/Law.lean index 73141137b0..da5b674dff 100644 --- a/Complexity/Computability/WordRAM/Randomized/Law.lean +++ b/Complexity/Computability/WordRAM/Randomized/Law.lean @@ -56,7 +56,7 @@ variable {B : Basis} {r : ℕ} {α β : Type} /-- `ExecRandLaw w c x P T R f μ`: at word size `w`, running `c` from `x` terminates cleanly on every path, makes at most `R` `rand` calls on every path, every supported outcome `(y, n)` satisfies `P y` and `n ≤ T`, and the observation `f y` of the final data has law `μ`. -/ -def ExecRandLaw (w : ℕ) (c : Code B r) (x : Data r) (P : Data r → Prop) (T R : ℕ) +@[expose] def ExecRandLaw (w : ℕ) (c : Code B r) (x : Data r) (P : Data r → Prop) (T R : ℕ) (f : Data r → α) (μ : PMF α) : Prop := ∃ m, ExecRand w c x m ∧ m.IsQueryBounded R ∧ (∀ z ∈ m.support, P z.1 ∧ z.2 ≤ T) ∧ ((fun z => f z.1) <$> m).eval = μ diff --git a/Complexity/DataStructure/AdjacencyList/Memory.lean b/Complexity/DataStructure/AdjacencyList/Memory.lean index 04c3ae9a8f..f87b81bddc 100644 --- a/Complexity/DataStructure/AdjacencyList/Memory.lean +++ b/Complexity/DataStructure/AdjacencyList/Memory.lean @@ -210,6 +210,10 @@ def framed (hL : L.Valid n) : Memory.Framed (AdjacencyList.spec n) w := obtain ⟨-, -, -, hs'⟩ := ops_run (w := w) hL hs o hv change ((Memory.spec w).clientState _ (ops L o)).mem b = _ rw [hs']) + (fun o hs hv => by + obtain ⟨-, -, -, hs'⟩ := ops_run (w := w) hL hs o hv + change ((Memory.spec w).clientState _ (ops L o)).frontier = _ + rw [hs']) /-- The footprint of the arrays is their two fields. -/ @[simp] theorem framed_footprint (hL : L.Valid n) (s : Memory.State) : diff --git a/Complexity/DataStructure/Dictionary/Memory.lean b/Complexity/DataStructure/Dictionary/Memory.lean index 433b139bc6..9d175ebd81 100644 --- a/Complexity/DataStructure/Dictionary/Memory.lean +++ b/Complexity/DataStructure/Dictionary/Memory.lean @@ -164,6 +164,9 @@ def framed (hT : Valid T w U V) : Memory.Framed (Dictionary.spec U V n_max) w := (fun o hs hv b _ hb => by obtain ⟨-, -, -, -, -, h⟩ := ops_run hT hs o hv exact h b hb) + (fun o hs hv => by + obtain ⟨-, -, -, -, h, -⟩ := ops_run hT hs o hv + exact h) /-- The footprint of a table is its field. -/ @[simp] theorem framed_footprint (hT : Valid T w U V) (s : Memory.State) : diff --git a/Complexity/DataStructure/Memory/Alloc.lean b/Complexity/DataStructure/Memory/Alloc.lean new file mode 100644 index 0000000000..1d2d11b11c --- /dev/null +++ b/Complexity/DataStructure/Memory/Alloc.lean @@ -0,0 +1,584 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +-- upstream: candidate + +public import Complexity.DataStructure.Memory.Frame +public import Complexity.Foundations.Analysis.Asymptotics.CostBound + +/-! +# Allocating data structures over the memory oracle + +A program that uses data structures over `Memory.spec w` first allocates their storage, then runs +a client of their specification through their methods. A `Memory.Allocator D w` packages the +first half for a specification `D`: + +* the allocation program, which returns a handle such as a layout of named fields; +* the methods, given the handle; +* the abstract state the allocation sets up, the room it needs, and a bound on its cost; +* for each memory with that room, the framed refinement it sets up (`Allocator.framed`), with the + proof that the allocation sets it up (`Memory.Allocates`). + +The structure's footprint lies in fresh cells, which the allocation and later operations take +from the frontier, and in the allocated cells `Allocator.owned` that it takes over. A structure +allocated from scratch takes over none. One that the input already holds, such as a graph given +as adjacency arrays, takes over the cells holding it, and its precondition `Allocator.Pre` says +that they do. `Allocator.resident` is the allocator of a framed structure already in memory, +whose allocation does nothing. + +`Allocator.run` allocates and then runs a client. `Allocator.run_correct` and +`Allocator.run_cost` hold for every allocator and every client: a client admissible for the +specification issues only admissible memory operations, answers as the specification does, and +costs at most the allocation's cost, the potential once allocated, and the upper charges of its +operations. A certificate `Allocator.Amortized` carries the cost side. `Allocator.run_cost_isBigO` +exports a constant per-operation charge as `O(m)` in the number `m` of operations. + +Allocators combine as their structures do. + +* `Allocator.prod` allocates two structures one after the other, and sets up their product over + one memory (`Memory.Framed.prod`). Its room is the sum of the rooms, so it reserves both + structures' growth. Iterated, `A₁.prod (A₂.prod A₃)` allocates the three structures of a client + such as Dijkstra's algorithm, which runs over `product PQ (product Dict Adj)`. +* `Allocator.comp` puts a refinement on top, such as a queue over the pair of its stacks, with + `Memory.Framed.comp`. + +Certificates combine along with them (`Allocator.Amortized.prod`, `Allocator.Amortized.comp`, +`Allocator.Amortized.resident`). An allocation changes no allocated cell, and being admissible, +no cell beyond its new frontier either (`Memory.mem_clientState_of_frontier_le`). So it keeps the +other structures' preconditions, such as that the memory beyond the frontier is zero, and the +cells they take over (`Allocator.pre_fresh`, `Allocator.owned_fresh`). The product's +precondition (`Allocator.ProdPre`) asks in addition that the cells the two structures take over +be disjoint. So `A₁.prod (A₂.prod A₃)` may combine structures allocated from scratch with +structures that the input holds. + +## Main definitions + +* `Memory.Allocates`: what an allocation program establishes for the structure it sets up. +* `Memory.Allocator`: an allocation program, the methods it sets up, and their framed refinement. +* `Memory.Allocator.run`: allocate, then run a client. +* `Memory.Allocator.prod`, `Memory.Allocator.comp`: products and refinements on top. +* `Memory.Allocator.ProdPre`: the precondition of a product. +* `Memory.Allocator.resident`: a structure already in memory. +* `Memory.Allocator.Amortized`: an amortized cost certificate of an allocator. + +## Main results + +* `Memory.Allocator.run_correct`: the run is admissible and answers as the specification. +* `Memory.Allocator.run_cost`, `Memory.Allocator.run_cost_le`: its memory cost. +* `Memory.Allocator.run_cost_isBigO`: the cost as `O(m)` for constant per-operation charges. +* `Memory.Allocator.Amortized.prod`, `Memory.Allocator.Amortized.comp`, + `Memory.Allocator.Amortized.resident`: certificates combine, and carry over to structures + already in memory. +-/ + +@[expose] public section + +namespace Cslib.DataStructure.Memory + +open Cslib.WordRAM + +variable {w : ℕ} + +/-- What running the allocation program `alloc` from the memory `s` establishes for the framed +refinement `M`: its operations are admissible and cost at most `cost`, it changes no allocated +cell, and it sets up `M` with the methods of the handle it returns, holding at the abstract state +`init`. The footprint lies in the allocated cells `owned` that the structure takes over and in +fresh cells, and the frontier plus `M`'s room is at most `room` beyond the old frontier. -/ +structure Allocates {D : StateTransitionSpec.{0, 0, 0}} {H : Type} (alloc : Prog H) + (methods : H → Methods D (spec w)) (init : D.State) (owned : Finset ℕ) (room cost : ℕ) + (s : State) (M : Framed D w) : Prop where + /-- The allocation's operations are admissible. -/ + validHistory : (spec w).ValidHistory s ((spec w).clientHistory s alloc) + /-- The allocation costs at most `cost`. -/ + cost_le : (spec w).totalCost charge s ((spec w).clientHistory s alloc) ≤ cost + /-- The allocation changes no allocated cell. -/ + mem_eq : ∀ a < s.frontier, ((spec w).clientState s alloc).mem a = s.mem a + /-- The structure runs the methods of the returned handle. -/ + methods_eq : M.methods = methods ((spec w).clientResult s alloc) + /-- The structure holds after the allocation. -/ + inv : M.inv ((spec w).clientState s alloc) + /-- It represents `init`. -/ + abs_eq : M.abs ((spec w).clientState s alloc) = init + /-- Its footprint lies in the cells it takes over and in fresh cells. -/ + of_mem_footprint : ∀ a ∈ M.footprint ((spec w).clientState s alloc), a ∈ owned ∨ s.frontier ≤ a + /-- The allocation and the structure's reserved room take at most `room` cells. -/ + room_le : ((spec w).clientState s alloc).frontier + M.room ((spec w).clientState s alloc) ≤ + s.frontier + room + +/-- **Allocators.** A memory program `alloc` that allocates a structure implementing `D`, and +the structure's methods, given the handle that `alloc` returns. From a memory satisfying `Pre` in +which `room` cells beyond the frontier fit a word, the allocation sets up the framed refinement +`framed s`, which represents `init`, at a memory cost of at most `cost`. Its footprint lies in +fresh cells and in the allocated cells `owned s` that it takes over, such as an input that holds +the structure already. -/ +structure Allocator (D : StateTransitionSpec.{0, 0, 0}) (w : ℕ) where + /-- What the allocation returns, such as a layout of named fields. -/ + Handle : Type + /-- The allocation program. -/ + alloc : Prog Handle + /-- The structure's methods, given the handle. -/ + methods : Handle → Methods D (spec w) + /-- The abstract state the allocation sets up. -/ + init : D.State + /-- The cells the allocation takes and the room it reserves for growth. -/ + room : ℕ + /-- A bound on the memory cost of the allocation. -/ + cost : ℕ + /-- What the allocation needs of the memory besides room, such as the structure it takes + over. -/ + Pre : State → Prop := fun _ => True + /-- The allocated cells that the structure takes over instead of allocating them. -/ + owned : State → Finset ℕ := fun _ => ∅ + /-- The cells taken over are allocated. -/ + owned_lt : ∀ {s a}, Pre s → a ∈ owned s → a < s.frontier := by intros; simp_all + /-- Runs that keep every allocated cell and every cell beyond the new frontier and leave the + room fitting, such as other allocations, keep the precondition. -/ + pre_fresh : ∀ {s s' : State}, Pre s → (∀ a < s.frontier, s'.mem a = s.mem a) → + (∀ a, s'.frontier ≤ a → s'.mem a = s.mem a) → s.frontier ≤ s'.frontier → + Fits w (s'.frontier + room) → Pre s' := by intros; trivial + /-- Such runs keep the cells taken over. -/ + owned_fresh : ∀ {s s' : State}, Pre s → (∀ a < s.frontier, s'.mem a = s.mem a) → + (∀ a, s'.frontier ≤ a → s'.mem a = s.mem a) → s.frontier ≤ s'.frontier → + Fits w (s'.frontier + room) → owned s' = owned s := by intros; rfl + /-- The framed refinement that allocating from `s` sets up. -/ + framed : (s : State) → Pre s → Fits w (s.frontier + room) → Framed D w + /-- Allocating from `s` sets it up. -/ + allocates : ∀ s (hs : Pre s) (hroom : Fits w (s.frontier + room)), + Allocates alloc methods init (owned s) room cost s (framed s hs hroom) + +namespace Allocator + +variable {D D₁ D₂ E : StateTransitionSpec.{0, 0, 0}} + +/-! ## Runs -/ + +section Run + +variable (A : Allocator D w) + +/-- Allocate the structure, then run a client of its specification through its methods. -/ +def run {β : Type} (p : D.Client β) : Prog β := A.alloc >>= fun h => link (A.methods h) p + +/-- The history of a run: the allocation's, then the linked client's. -/ +theorem clientHistory_run {β : Type} (p : D.Client β) (s : State) : + (spec w).clientHistory s (A.run p) = (spec w).clientHistory s A.alloc ++ + (spec w).clientHistory ((spec w).clientState s A.alloc) + (link (A.methods ((spec w).clientResult s A.alloc)) p) := + (spec w).clientHistory_bind _ _ s + +/-- The answer of a run is the linked client's. -/ +theorem clientResult_run {β : Type} (p : D.Client β) (s : State) : + (spec w).clientResult s (A.run p) = + (spec w).clientResult ((spec w).clientState s A.alloc) + (link (A.methods ((spec w).clientResult s A.alloc)) p) := + (spec w).clientResult_bind _ _ s + +/-- A run ends where the linked client ends. -/ +theorem clientState_run {β : Type} (p : D.Client β) (s : State) : + (spec w).clientState s (A.run p) = + (spec w).clientState ((spec w).clientState s A.alloc) + (link (A.methods ((spec w).clientResult s A.alloc)) p) := + (spec w).clientState_bind _ _ s + +variable {fD : (s : D.State) → (o : D.Op) → D.State × D.Result o} [D.HasStepFn fD] + +/-- **Correctness of a run.** From a memory with the allocator's precondition and room, a client +admissible for the specification issues only admissible memory operations and answers as the +specification does from `A.init`; the structure then holds at the specified final state. -/ +theorem run_correct {β : Type} (p : D.Client β) {s : State} (hs : A.Pre s) + (hroom : Fits w (s.frontier + A.room)) (hv : D.ValidHistory A.init (D.clientHistory A.init p)) : + (spec w).ValidHistory s ((spec w).clientHistory s (A.run p)) ∧ + (spec w).clientResult s (A.run p) = D.clientResult A.init p ∧ + (A.framed s hs hroom).inv ((spec w).clientState s (A.run p)) ∧ + (A.framed s hs hroom).abs ((spec w).clientState s (A.run p)) = D.clientState A.init p := by + have hA := A.allocates s hs hroom + obtain ⟨hvE, hres, habs, hinv⟩ := + (A.framed s hs hroom).simulates_client p hA.inv (by rw [hA.abs_eq]; exact hv) + rw [hA.methods_eq] at hvE hres habs hinv + rw [hA.abs_eq] at hres habs + rw [clientHistory_run, clientResult_run, clientState_run, + StateTransitionSpec.validHistory_append, StateTransitionSpec.run_runClient] + exact ⟨⟨hA.validHistory, hvE⟩, hres, hinv, habs⟩ + +end Run + +/-! ## Cost certificates -/ + +/-- **An amortized cost certificate of an allocator.** From every memory it can allocate from, +the structure it sets up is amortized against `upper` with a potential that reads only its +footprint and is at most `Φ₀` once allocated. -/ +def Amortized (A : Allocator D w) (upper : D.State → D.Op → ℕ) (Φ₀ : ℕ) : Prop := + ∀ s (hs : A.Pre s) (hroom : Fits w (s.frontier + A.room)), ∃ Φ : State → ℕ, + (A.framed s hs hroom).Amortized charge upper Φ ∧ (A.framed s hs hroom).Local Φ ∧ + Φ ((spec w).clientState s A.alloc) ≤ Φ₀ + +section Cost + +variable {A : Allocator D w} {fD : (s : D.State) → (o : D.Op) → D.State × D.Result o} + [D.HasStepFn fD] + +/-- **The cost of a run.** A client admissible for the specification costs at most the +allocation's cost, the potential once allocated, and the upper charges of its operations. -/ +theorem run_cost {upper : D.State → D.Op → ℕ} {Φ₀ : ℕ} (hA : A.Amortized upper Φ₀) {β : Type} + (p : D.Client β) {s : State} (hs : A.Pre s) (hroom : Fits w (s.frontier + A.room)) + (hv : D.ValidHistory A.init (D.clientHistory A.init p)) : + (spec w).totalCost charge s ((spec w).clientHistory s (A.run p)) ≤ + A.cost + Φ₀ + D.totalCost upper A.init (D.clientHistory A.init p) := by + have hal := A.allocates s hs hroom + obtain ⟨Φ, hc, -, hΦ⟩ := hA s hs hroom + have h := hc.client p hal.inv (by rw [hal.abs_eq]; exact hv) + rw [hal.methods_eq, hal.abs_eq] at h + rw [clientHistory_run, StateTransitionSpec.totalCost_append, StateTransitionSpec.run_runClient] + have := hal.cost_le + omega + +/-- The cost of a run for a constant charge `K` per operation: at most the allocation's cost, +the potential once allocated, and `K` per operation. -/ +theorem run_cost_le {K Φ₀ : ℕ} (hA : A.Amortized (fun _ _ => K) Φ₀) {β : Type} + (p : D.Client β) {s : State} (hs : A.Pre s) (hroom : Fits w (s.frontier + A.room)) + (hv : D.ValidHistory A.init (D.clientHistory A.init p)) : + (spec w).totalCost charge s ((spec w).clientHistory s (A.run p)) ≤ + A.cost + Φ₀ + K * (D.clientHistory A.init p).length := by + have h := run_cost hA p hs hroom hv + rw [StateTransitionSpec.totalCost_const, Nat.mul_comm] at h + exact h + +/-- **The exported form.** For a constant charge per operation, the memory cost of a run is +`O(m)` in the number `m` of operations, over admissible clients. -/ +theorem run_cost_isBigO {K Φ₀ : ℕ} (hA : A.Amortized (fun _ _ => K) Φ₀) {β : Type} {s : State} + (hs : A.Pre s) (hroom : Fits w (s.frontier + A.room)) : + CostIsBigO Filter.atTop (fun m : ℕ => (m : ℝ)) + (fun p : {p : D.Client β // D.ValidHistory A.init (D.clientHistory A.init p)} => + (D.clientHistory A.init p.1).length) + (fun p => (spec w).totalCost charge s ((spec w).clientHistory s (A.run p.1))) := + CostIsBigO.of_le_add_mul (A.cost + Φ₀) K fun p => run_cost_le hA p.1 hs hroom p.2 + +end Cost + +/-! ## Refinements on top -/ + +/-- **A refinement on top of an allocated structure.** The same allocation sets up the +composite `Memory.Framed.comp R M`, whose methods link `R`'s methods through the structure's, +provided `R`'s invariant holds of the allocated abstract state. -/ +def comp (R : Refinement D E) (A : Allocator E w) (hinit : R.inv A.init) : Allocator D w where + Handle := A.Handle + alloc := A.alloc + methods h o := link (A.methods h) (R.methods o) + init := R.abs A.init + room := A.room + cost := A.cost + Pre := A.Pre + owned := A.owned + owned_lt := A.owned_lt + pre_fresh := A.pre_fresh + owned_fresh := A.owned_fresh + framed s hs hroom := Framed.comp R (A.framed s hs hroom) + allocates s hs hroom := + have h := A.allocates s hs hroom + { validHistory := h.validHistory + cost_le := h.cost_le + mem_eq := h.mem_eq + methods_eq := by rw [Framed.comp_methods, h.methods_eq] + inv := ⟨h.inv, by rw [h.abs_eq]; exact hinit⟩ + abs_eq := by rw [Framed.comp_abs, h.abs_eq] + of_mem_footprint := h.of_mem_footprint + room_le := h.room_le } + +/-- **Potentials stack through a refinement on top.** A certificate of `R` against the middle +charges and one of the allocator against them give a certificate of the composite, with `R`'s +potential at the allocated state added. -/ +theorem Amortized.comp {R : Refinement D E} {A : Allocator E w} {hinit : R.inv A.init} + {middle : E.State → E.Op → ℕ} {upper : D.State → D.Op → ℕ} {Φ : E.State → ℕ} {Ψ₀ : ℕ} + (hR : R.Amortized middle upper Φ) (hA : A.Amortized middle Ψ₀) : + (A.comp R hinit).Amortized upper (Φ A.init + Ψ₀) := by + intro s hs hroom + obtain ⟨Ψ, hc, hl, hΨ⟩ := hA s hs hroom + have hal := A.allocates s hs hroom + refine ⟨fun s' => Φ ((A.framed s hs hroom).abs s') + Ψ s', Framed.amortized_comp hR hc, + Framed.Local.add (Framed.Local.comp (Framed.Local.comp_abs _ Φ)) (Framed.Local.comp hl), ?_⟩ + change Φ ((A.framed s hs hroom).abs ((spec w).clientState s A.alloc)) + + Ψ ((spec w).clientState s A.alloc) ≤ Φ A.init + Ψ₀ + rw [hal.abs_eq] + omega + +/-! ## Products -/ + +section Prod + +variable (A₁ : Allocator D₁ w) (A₂ : Allocator D₂ w) + +/-- Allocate both structures, one after the other. -/ +def allocPair : Prog (A₁.Handle × A₂.Handle) := do + let h₁ ← A₁.alloc + let h₂ ← A₂.alloc + pure (h₁, h₂) + +/-- Both allocations' histories, one after the other. -/ +theorem clientHistory_allocPair (s : State) : + (spec w).clientHistory s (allocPair A₁ A₂) = (spec w).clientHistory s A₁.alloc ++ + (spec w).clientHistory ((spec w).clientState s A₁.alloc) A₂.alloc := by + rw [allocPair, (spec w).clientHistory_bind, (spec w).clientHistory_bind] + exact congrArg (_ ++ ·) (List.append_nil _) + +/-- The memory after both allocations. -/ +theorem clientState_allocPair (s : State) : + (spec w).clientState s (allocPair A₁ A₂) = + (spec w).clientState ((spec w).clientState s A₁.alloc) A₂.alloc := by + rw [allocPair, (spec w).clientState_bind, (spec w).clientState_bind] + rfl + +/-- Both handles. -/ +theorem clientResult_allocPair (s : State) : + (spec w).clientResult s (allocPair A₁ A₂) = + ((spec w).clientResult s A₁.alloc, + (spec w).clientResult ((spec w).clientState s A₁.alloc) A₂.alloc) := by + rw [allocPair, (spec w).clientResult_bind, (spec w).clientResult_bind] + rfl + +variable {A₁} + +/-- After allocating the first structure, room for both leaves room for the second. -/ +theorem room_after {s : State} (hs₁ : A₁.Pre s) {r : ℕ} + (hroom : Fits w (s.frontier + (A₁.room + r))) : + Fits w (((spec w).clientState s A₁.alloc).frontier + r) := + hroom.of_le (by + have := (A₁.allocates s hs₁ (hroom.of_le (by omega))).room_le + omega) + +/-- After allocating the first structure, the second one's precondition still holds. -/ +theorem pre_after {s : State} (hs₁ : A₁.Pre s) + (hroom : Fits w (s.frontier + (A₁.room + A₂.room))) (hs₂ : A₂.Pre s) : + A₂.Pre ((spec w).clientState s A₁.alloc) := + have h₁ := A₁.allocates s hs₁ (hroom.of_le (by omega)) + A₂.pre_fresh hs₂ h₁.mem_eq (fun _ => mem_clientState_of_frontier_le s _ h₁.validHistory) + (frontier_le_clientState s _) (room_after hs₁ hroom) + +/-- After allocating the first structure, the second one takes over the same cells. -/ +theorem owned_after {s : State} (hs₁ : A₁.Pre s) + (hroom : Fits w (s.frontier + (A₁.room + A₂.room))) (hs₂ : A₂.Pre s) : + A₂.owned ((spec w).clientState s A₁.alloc) = A₂.owned s := + have h₁ := A₁.allocates s hs₁ (hroom.of_le (by omega)) + A₂.owned_fresh hs₂ h₁.mem_eq (fun _ => mem_clientState_of_frontier_le s _ h₁.validHistory) + (frontier_le_clientState s _) (room_after hs₁ hroom) + +variable (A₁) + +/-- The precondition of a product of allocators: both preconditions, and the cells that the two +structures take over are disjoint. -/ +structure ProdPre (s : State) : Prop where + /-- The first allocator's precondition. -/ + left : A₁.Pre s + /-- The second allocator's precondition. -/ + right : A₂.Pre s + /-- The two structures take over disjoint cells. -/ + disjoint : Disjoint (A₁.owned s) (A₂.owned s) + +/-- **Products of allocators.** Allocate the two structures one after the other, and set up +their product over one memory. The room and the cost add, and the product takes over the cells +that either structure takes over. -/ +def prod : Allocator (product D₁ D₂) w where + Handle := A₁.Handle × A₂.Handle + alloc := allocPair A₁ A₂ + methods := fun (h₁, h₂) => Methods.prod (A₁.methods h₁) (A₂.methods h₂) + init := (A₁.init, A₂.init) + room := A₁.room + A₂.room + cost := A₁.cost + A₂.cost + Pre := ProdPre A₁ A₂ + owned s := A₁.owned s ∪ A₂.owned s + owned_lt hs ha := (Finset.mem_union.mp ha).elim (A₁.owned_lt hs.left) (A₂.owned_lt hs.right) + pre_fresh hs hmem habove hf hr := + have hr₁ := hr.of_le (Nat.add_le_add_left (Nat.le_add_right A₁.room A₂.room) _) + have hr₂ := hr.of_le (Nat.add_le_add_left (Nat.le_add_left A₂.room A₁.room) _) + { left := A₁.pre_fresh hs.left hmem habove hf hr₁ + right := A₂.pre_fresh hs.right hmem habove hf hr₂ + disjoint := by + rw [A₁.owned_fresh hs.left hmem habove hf hr₁, A₂.owned_fresh hs.right hmem habove hf hr₂] + exact hs.disjoint } + owned_fresh hs hmem habove hf hr := by + rw [A₁.owned_fresh hs.left hmem habove hf + (hr.of_le (Nat.add_le_add_left (Nat.le_add_right A₁.room A₂.room) _)), + A₂.owned_fresh hs.right hmem habove hf + (hr.of_le (Nat.add_le_add_left (Nat.le_add_left A₂.room A₁.room) _))] + framed s hs hroom := + (A₁.framed s hs.left (hroom.of_le (by omega))).prod + (A₂.framed ((spec w).clientState s A₁.alloc) (pre_after A₂ hs.left hroom hs.right) + (room_after hs.left hroom)) + allocates s hs hroom := by + -- The two allocations, from `s` to `s₁` and from `s₁` to `s₂`. + obtain ⟨hs₁, hs₂, hd⟩ := hs + have hroom₁ : Fits w (s.frontier + A₁.room) := hroom.of_le (by omega) + have h₁ := A₁.allocates s hs₁ hroom₁ + have h₂ := A₂.allocates _ (pre_after A₂ hs₁ hroom hs₂) (room_after hs₁ hroom) + have ho₂ := owned_after A₂ hs₁ hroom hs₂ + have hf₁ := frontier_le_clientState (w := w) s A₁.alloc + have hfit := h₁.room_le + have hfit₂ := h₂.room_le + -- The second footprint lies in cells taken over, which are allocated and apart from the + -- first structure's, and in cells fresh after the first allocation. + obtain ⟨hinv, habs, hfp, hr⟩ := Framed.prod_of_fresh h₁.inv h₂.mem_eq + (frontier_le_clientState _ _) h₂.inv + (Finset.disjoint_left.mpr fun a ha ha' => by + have hlt := (A₁.framed s hs₁ hroom₁).lt_frontier h₁.inv ha + rcases h₂.of_mem_footprint a ha' with ha' | ha' + · rw [ho₂] at ha' + have := A₂.owned_lt hs₂ ha' + rcases h₁.of_mem_footprint a ha with ha | ha + · exact Finset.disjoint_left.mp hd ha ha' + · omega + · omega) + (hroom.of_le (by omega)) + refine + { validHistory := ?_, cost_le := ?_, mem_eq := ?_, methods_eq := ?_, inv := ?_, + abs_eq := ?_, of_mem_footprint := ?_, room_le := ?_ } + · rw [clientHistory_allocPair, StateTransitionSpec.validHistory_append, + StateTransitionSpec.run_runClient] + exact ⟨h₁.validHistory, h₂.validHistory⟩ + · rw [clientHistory_allocPair, StateTransitionSpec.totalCost_append, + StateTransitionSpec.run_runClient] + have := h₁.cost_le + have := h₂.cost_le + omega + · intro a ha + rw [clientState_allocPair, h₂.mem_eq a (ha.trans_le hf₁), h₁.mem_eq a ha] + · rw [clientResult_allocPair, Framed.prod_methods, h₁.methods_eq, h₂.methods_eq] + · rw [clientState_allocPair] + exact hinv + · rw [clientState_allocPair, habs, h₁.abs_eq, h₂.abs_eq] + · intro a ha + rw [clientState_allocPair, hfp] at ha + rcases Finset.mem_union.mp ha with ha | ha + · exact (h₁.of_mem_footprint a ha).imp_left (Finset.mem_union_left _) + · rcases h₂.of_mem_footprint a ha with ha | ha + · rw [ho₂] at ha + exact .inl (Finset.mem_union_right _ ha) + · exact .inr (hf₁.trans ha) + · rw [clientState_allocPair, hr] + omega + +/-- The product's methods run each side's methods with its own handle. -/ +@[simp] theorem prod_methods (h₁ : A₁.Handle) (h₂ : A₂.Handle) : + (A₁.prod A₂).methods (h₁, h₂) = Methods.prod (A₁.methods h₁) (A₂.methods h₂) := rfl + +/-- The product sets up both abstract states. -/ +@[simp] theorem prod_init : (A₁.prod A₂).init = (A₁.init, A₂.init) := rfl + +/-- The product's room is the sum of the rooms. -/ +@[simp] theorem prod_room : (A₁.prod A₂).room = A₁.room + A₂.room := rfl + +/-- The product's allocation costs at most the sum of the costs. -/ +@[simp] theorem prod_cost : (A₁.prod A₂).cost = A₁.cost + A₂.cost := rfl + +/-- The product takes over the cells that either structure takes over. -/ +@[simp] theorem prod_owned (s : State) : + (A₁.prod A₂).owned s = A₁.owned s ∪ A₂.owned s := rfl + +/-- The product's precondition. -/ +theorem prod_pre_iff (s : State) : (A₁.prod A₂).Pre s ↔ ProdPre A₁ A₂ s := Iff.rfl + +variable {A₁ A₂} + +/-- **Certificates add across a product of allocators**: the charges componentwise, the +potentials once allocated by sum. -/ +theorem Amortized.prod {upper₁ : D₁.State → D₁.Op → ℕ} {upper₂ : D₂.State → D₂.Op → ℕ} + {Φ₁ Φ₂ : ℕ} (hA₁ : A₁.Amortized upper₁ Φ₁) (hA₂ : A₂.Amortized upper₂ Φ₂) : + (A₁.prod A₂).Amortized (productCharge upper₁ upper₂) (Φ₁ + Φ₂) := by + intro s hs hroom + obtain ⟨hs₁, hs₂, -⟩ := hs + have hroom₁ : Fits w (s.frontier + A₁.room) := hroom.of_le (by simp only [prod_room]; omega) + have hs₂' := pre_after A₂ hs₁ hroom hs₂ + have hroom₂ := room_after hs₁ hroom + obtain ⟨Ψ₁, hc₁, hl₁, hΨ₁⟩ := hA₁ s hs₁ hroom₁ + obtain ⟨Ψ₂, hc₂, hl₂, hΨ₂⟩ := hA₂ _ hs₂' hroom₂ + refine ⟨fun s' => Ψ₁ s' + Ψ₂ s', Framed.amortized_prod hc₁ hc₂ hl₁ hl₂, + Framed.Local.add hl₁.prod_left hl₂.prod_right, ?_⟩ + -- The first potential is unchanged by the second allocation. + have h₁ := A₁.allocates s hs₁ hroom₁ + have h₂ := A₂.allocates _ hs₂' hroom₂ + have hfit := h₁.room_le + have hfit₂ := h₂.room_le + have hkeep := hl₁ h₁.inv + (fun a ha => h₂.mem_eq a ((A₁.framed s hs₁ hroom₁).lt_frontier h₁.inv ha)) + (frontier_le_clientState _ _) (hroom.of_le (by simp only [prod_room]; omega)) + change Ψ₁ ((spec w).clientState s (allocPair A₁ A₂)) + + Ψ₂ ((spec w).clientState s (allocPair A₁ A₂)) ≤ Φ₁ + Φ₂ + rw [clientState_allocPair, hkeep] + omega + +end Prod + +/-! ## Structures already in memory -/ + +section Resident + +variable (M : Framed D w) (init : D.State) (room : ℕ) + +/-- **A structure already in memory**, such as a graph that the input holds as adjacency arrays. +Its allocation does nothing. It takes over the footprint of `M`, and needs `M` to hold, to +represent `init` and to have at most `room` cells of room. -/ +def resident : Allocator D w where + Handle := Unit + alloc := pure () + methods _ := M.methods + init := init + room := room + cost := 0 + Pre s := M.inv s ∧ M.abs s = init ∧ M.room s ≤ room + owned := M.footprint + owned_lt hs ha := M.lt_frontier hs.1 ha + pre_fresh {s _} hs hmem _ hf hr := by + obtain ⟨hinv, habs, hle⟩ := hs + obtain ⟨hinv', habs', -, hroom'⟩ := M.of_fresh hinv hmem hf (hr.of_le (by omega)) + exact ⟨hinv', habs'.trans habs, hroom' ▸ hle⟩ + owned_fresh {s _} hs hmem _ hf hr := by + obtain ⟨hinv, -, hle⟩ := hs + obtain ⟨-, -, hfp, -⟩ := M.of_fresh hinv hmem hf (hr.of_le (by omega)) + exact hfp + framed _ _ _ := M + allocates s hs _ := by + obtain ⟨hinv, habs, hle⟩ := hs + exact + { validHistory := trivial + cost_le := le_rfl + mem_eq := fun _ _ => rfl + methods_eq := rfl + inv := hinv + abs_eq := habs + of_mem_footprint := fun _ ha => .inl ha + room_le := Nat.add_le_add_left hle s.frontier } + +/-- A structure already in memory runs `M`'s methods. -/ +@[simp] theorem resident_methods (h : Unit) : (resident M init room).methods h = M.methods := rfl + +/-- It represents `init`. -/ +@[simp] theorem resident_init : (resident M init room).init = init := rfl + +/-- It takes over `M`'s footprint. -/ +@[simp] theorem resident_owned (s : State) : (resident M init room).owned s = M.footprint s := rfl + +/-- Its allocation costs nothing. -/ +@[simp] theorem resident_cost : (resident M init room).cost = 0 := rfl + +/-- Its precondition: `M` holds, represents `init` and has at most `room` cells of room. -/ +theorem resident_pre_iff (s : State) : + (resident M init room).Pre s ↔ M.inv s ∧ M.abs s = init ∧ M.room s ≤ room := Iff.rfl + +variable {M init room} + +/-- **The certificate of a structure already in memory** is the structure's own: a potential +that reads only its footprint and is at most `Φ₀` wherever the structure represents `init`. -/ +theorem Amortized.resident {upper : D.State → D.Op → ℕ} {Φ : State → ℕ} {Φ₀ : ℕ} + (hc : M.Amortized charge upper Φ) (hl : M.Local Φ) + (hΦ : ∀ s, M.inv s → M.abs s = init → Φ s ≤ Φ₀) : + (resident M init room).Amortized upper Φ₀ := fun s hs _ => by + obtain ⟨hinv, habs, -⟩ := hs + exact ⟨Φ, hc, hl, hΦ s hinv habs⟩ + +end Resident + +end Allocator + +end Cslib.DataStructure.Memory diff --git a/Complexity/DataStructure/Memory/Frame.lean b/Complexity/DataStructure/Memory/Frame.lean index 9c41b35613..9992941dbc 100644 --- a/Complexity/DataStructure/Memory/Frame.lean +++ b/Complexity/DataStructure/Memory/Frame.lean @@ -11,54 +11,66 @@ public import Complexity.DataStructure.Memory.Spec public import Complexity.DataStructure.StateTransition.Refinement /-! -# Footprints, and products of data structures sharing one memory - -A `Memory.Framed D w` is a refinement of `D` over `Memory.spec w` together with a footprint: the -finite set of allocated cells that holds the representation of each memory state. Three -obligations make the footprint honest. - -* `congr`: the invariant, the abstraction and the footprint itself read only the footprint's - cells, and survive a growing frontier. -* `modifies`: a method run changes no allocated cell outside the footprint, and the footprint - grows only into cells that the run allocated. +# Footprints, room, and products of data structures sharing one memory + +A `Memory.Framed D w` is a refinement of `D` over `Memory.spec w` together with a footprint, the +finite set of allocated cells that holds the representation of each memory state, and a room, +the number of cells the structure has reserved for its future allocations. Three obligations make +them honest. + +* `congr`: the invariant, the abstraction, the footprint and the room read only the footprint's + cells, and survive a growing frontier that leaves the reserved room fitting a word. +* `modifies`: a method run changes no allocated cell outside the footprint, the footprint grows + only into cells that the run allocated, and the frontier advances by at most the room the run + gives up. * `lt_frontier`: the footprint is allocated. -Footprints may change from state to state, so that a structure can grow into cells it allocates -inside its operations. A structure laid out in fixed blocks has a constant footprint, and -`Framed.ofStatic` asks for less. Allocating inside an operation also needs room, since -`Memory.valid` asks the new frontier to fit a word. Neither the abstract state nor the structure's -own cells determine the frontier, and the other side of a product moves it, so such a structure -needs a shared budget of room, which this file does not provide. The structures built so far -allocate their storage once, up front. - -Two framed refinements implement the product of their specifications over one shared memory, -as long as their footprints are disjoint (`Framed.prod`). Disjointness is part of the product's -invariant. It holds after each method run because a run of one side writes only its own cells -and fresh ones, and the other side's footprint is allocated, hence not fresh. The product is -framed again, with the union of the footprints, so products iterate: -`(M₁.prod M₂).prod M₃` implements three structures in one memory. A potential that reads only the -footprint (`Framed.Local`) is left unchanged by the other side's methods, so amortized +A structure laid out in fixed blocks has a constant footprint and no room, and `Framed.ofStatic` +asks for less. A structure that allocates inside its operations, such as a growing array, +reserves room for all of its future growth. Its invariant may then ask that the frontier plus its +room fit a word, which is what `Memory.valid` needs of each allocation. That fact is not +preserved by other structures' allocations on its own, so the product keeps it for everybody. + +**Products.** Two framed refinements implement the product of their specifications over one +shared memory (`Framed.prod`). The product's invariant asks that the footprints be disjoint and +that the frontier plus both rooms fit a word. This is the shared room budget: a method run of one +side writes only its own cells and fresh ones, and advances the frontier by at most the room it +gives up, so the other side keeps its cells and its room, and the budget still fits. The product +is framed again, with the union of the footprints and the sum of the rooms, so products iterate: +`(M₁.prod M₂).prod M₃` implements three structures in one memory. A potential that reads only +the footprint (`Framed.Local`) is left unchanged by the other side's methods, so amortized certificates add across the product (`Framed.amortized_prod`), and so do worst-case `Module.ChargeBound`s, as the case of zero potentials. -Allocation is a memory program like any other. A run that leaves every allocated cell unchanged, -such as the allocation of a further structure, preserves a framed refinement (`Framed.of_fresh`), -and `Framed.prod_of_fresh` sets up a product from structures allocated one after the other. +**Composition.** A refinement of `D` over `E` composed with a framed refinement of `E` is framed +by the same footprint and room (`Framed.comp`), since a whole linked client keeps the frame of its +calls (`Framed.modifies_demonic`). So a structure built on others, such as a queue over two +stacks, joins a product like any other. + +**Allocation** is a memory program like any other. A run that leaves every allocated cell +unchanged and leaves the room fitting, such as the allocation of a further structure, preserves a +framed refinement (`Framed.of_fresh`), and `Framed.prod_of_fresh` sets up a product from +structures allocated one after the other. `Memory.Allocator` packages this. ## Main definitions -* `Memory.Framed`: a refinement over memory with a footprint. -* `Memory.Framed.ofStatic`: the constructor for a constant footprint. +* `Memory.Framed`: a refinement over memory with a footprint and a room. +* `Memory.Framed.ofStatic`: the constructor for a constant footprint and no room. * `Memory.Framed.Local`: a function of memory that reads only the footprint. * `Memory.Framed.prod`: two framed refinements with disjoint footprints implement the product. +* `Memory.Framed.comp`: a refinement over a framed refinement is framed. ## Main results -* `Memory.frontier_le_of_clientRun`: a run never lowers the frontier. +* `Memory.frontier_le_of_clientRun`, `Memory.frontier_le_clientState`: a run never lowers the + frontier. * `Memory.mem_run_of_lt_frontier`, `Memory.mem_clientState_of_lt_frontier`: a run changes an allocated cell only by writing it. +* `Memory.mem_run_of_frontier_le`, `Memory.mem_clientState_of_frontier_le`: an admissible run + changes no cell at or above its final frontier. +* `Memory.Framed.modifies_demonic`: a linked client keeps the frame of its calls. * `Memory.Framed.frame`: a method run of one structure leaves a structure with a disjoint - footprint unchanged. + footprint unchanged, and the shared room budget fitting. * `Memory.Framed.prod_methods`: the product's methods are the two sides' methods. * `Memory.Framed.amortized_prod`: potentials and charges add across the product. * `Memory.Framed.of_fresh`, `Memory.Framed.prod_of_fresh`: allocation preserves structures and @@ -75,6 +87,8 @@ explicit finite footprints as in `Cslib.WordRAM.HeapAssertion`; see namespace Cslib.DataStructure.Memory +open Cslib.WordRAM + variable {w : ℕ} /-! ## Runs and allocated cells -/ @@ -87,6 +101,12 @@ theorem frontier_le_of_clientRun {α : Type} {s s' : State} {p : Prog α} {a : rw [← (spec w).run_runClient] exact frontier_le_run s _ +/-- No memory program lowers the frontier. -/ +theorem frontier_le_clientState {α : Type} (s : State) (p : Prog α) : + s.frontier ≤ ((spec w).clientState s p).frontier := by + rw [← (spec w).run_runClient] + exact frontier_le_run s _ + /-- A sequence of operations changes an allocated cell only by writing it. -/ theorem mem_run_of_lt_frontier (s : State) (os : List Op) {a : ℕ} (ha : a < s.frontier) (hw : ∀ v, Op.write a v ∉ os) : ((spec w).run s os).1.mem a = s.mem a := by @@ -105,76 +125,219 @@ theorem mem_clientState_of_lt_frontier {α : Type} (s : State) (p : Prog α) {a rw [← (spec w).run_runClient] exact mem_run_of_lt_frontier s _ ha hw +/-- An admissible sequence of operations changes no cell at or above its final frontier: writes +go below the frontier, and an allocation clears only the block that it hands out. -/ +theorem mem_run_of_frontier_le {s : State} {os : List Op} (hv : (spec w).ValidHistory s os) + {a : ℕ} (ha : ((spec w).run s os).1.frontier ≤ a) : ((spec w).run s os).1.mem a = s.mem a := by + induction os generalizing s with + | nil => rfl + | cons o os ih => + obtain ⟨hvo, hvs⟩ := hv + change ((spec w).run (step s o).1 os).1.frontier ≤ a at ha + change ((spec w).run (step s o).1 os).1.mem a = s.mem a + rw [ih hvs ha] + have hf : (step s o).1.frontier ≤ a := (frontier_le_run _ os).trans ha + cases o with + | read => rfl + | write b v => + have hb : b < s.frontier := hvo.1 + simp only [step_write] at hf + have hab : a ≠ b := by omega + exact Function.update_of_ne hab v s.mem + | alloc k => + simp only [step_alloc] at hf + exact clear_of_not_owns (by simp only [Block.Owns]; omega) + | allocDirty => rfl + +/-- An admissible memory program changes no cell at or above its final frontier. -/ +theorem mem_clientState_of_frontier_le {α : Type} (s : State) (p : Prog α) + (hv : (spec w).ValidHistory s ((spec w).clientHistory s p)) {a : ℕ} + (ha : ((spec w).clientState s p).frontier ≤ a) : + ((spec w).clientState s p).mem a = s.mem a := by + rw [← (spec w).run_runClient] at ha ⊢ + exact mem_run_of_frontier_le hv ha + /-! ## Framed refinements -/ -/-- A refinement of `D` over memory whose representation lives in a footprint of allocated -cells. The invariant, the abstraction and the footprint read only the footprint's cells; a -method run changes no allocated cell outside the footprint; and the footprint grows only into -cells at or above the old frontier, which the run allocated. -/ +/-- A refinement of `D` over memory whose representation lives in a footprint of allocated cells, +with room reserved for its growth. The invariant, the abstraction, the footprint and the room +read only the footprint's cells; a method run changes no allocated cell outside the footprint; +the footprint grows only into cells at or above the old frontier, which the run allocated; and +the frontier advances by at most the room the run gives up. -/ structure Framed (D : StateTransitionSpec.{0, 0, 0}) (w : ℕ) extends Refinement D (spec w) where /-- The cells holding the representation. -/ footprint : State → Finset ℕ + /-- The cells reserved for the structure's future allocations. -/ + room : State → ℕ /-- The footprint is allocated. -/ lt_frontier : ∀ {s a}, inv s → a ∈ footprint s → a < s.frontier - /-- The invariant, the abstraction and the footprint read only the footprint's cells, and - survive a growing frontier. -/ + /-- The invariant, the abstraction, the footprint and the room read only the footprint's + cells, and survive a growing frontier that leaves the room fitting a word. -/ congr : ∀ {s s'}, inv s → (∀ a ∈ footprint s, s'.mem a = s.mem a) → - s.frontier ≤ s'.frontier → inv s' ∧ abs s' = abs s ∧ footprint s' = footprint s - /-- A method run changes no allocated cell outside the footprint, and the footprint grows - only into fresh cells. -/ + s.frontier ≤ s'.frontier → Fits w (s'.frontier + room s) → + inv s' ∧ abs s' = abs s ∧ footprint s' = footprint s ∧ room s' = room s + /-- A method run changes no allocated cell outside the footprint, the footprint grows only + into fresh cells, and the frontier advances by at most the room given up. -/ modifies : ∀ {s} o {a s' tr}, inv s → D.valid (abs s) o → (spec w).ClientRun s (methods o) a s' tr → (∀ b < s.frontier, b ∉ footprint s → s'.mem b = s.mem b) ∧ - ∀ b ∈ footprint s', b ∈ footprint s ∨ s.frontier ≤ b + (∀ b ∈ footprint s', b ∈ footprint s ∨ s.frontier ≤ b) ∧ + s'.frontier + room s' ≤ s.frontier + room s namespace Framed -variable {D D₁ D₂ : StateTransitionSpec.{0, 0, 0}} +variable {D D₁ D₂ E : StateTransitionSpec.{0, 0, 0}} -/-- The constructor for a constant footprint `fp`: the invariant and abstraction read only `fp`, -and each method's final state agrees with its initial state on the allocated cells outside -`fp`. -/ +/-- The constructor for a constant footprint `fp` and no room: the invariant and abstraction read +only `fp`, and each method's final state agrees with its initial state on the allocated cells +outside `fp` and has the same frontier. -/ def ofStatic (M : Refinement D (spec w)) (fp : Finset ℕ) (lt_frontier : ∀ {s a}, M.inv s → a ∈ fp → a < s.frontier) (congr : ∀ {s s'}, M.inv s → (∀ a ∈ fp, s'.mem a = s.mem a) → s.frontier ≤ s'.frontier → M.inv s' ∧ M.abs s' = M.abs s) (modifies : ∀ {s} o, M.inv s → D.valid (M.abs s) o → ∀ b < s.frontier, b ∉ fp → - ((spec w).clientState s (M.methods o)).mem b = s.mem b) : + ((spec w).clientState s (M.methods o)).mem b = s.mem b) + (frontier_eq : ∀ {s} o, M.inv s → D.valid (M.abs s) o → + ((spec w).clientState s (M.methods o)).frontier = s.frontier) : Framed D w where toRefinement := M footprint _ := fp + room _ := 0 lt_frontier := lt_frontier - congr hs h hf := ⟨(congr hs h hf).1, (congr hs h hf).2, rfl⟩ + congr hs h hf _ := ⟨(congr hs h hf).1, (congr hs h hf).2, rfl, rfl⟩ modifies {s} o {a s' tr} hs hv hrun := by obtain ⟨_, _, rfl, _⟩ := ((spec w).clientRun_iff_runClient _ _ _ _ _).mp hrun - exact ⟨modifies o hs hv, fun b hb => .inl hb⟩ + exact ⟨modifies o hs hv, fun b hb => .inl hb, (frontier_eq o hs hv).le⟩ variable (M : Framed D w) /-- A function of memory reads only the footprint: it is unchanged when the footprint's cells -are and the frontier grows. The abstraction is one (`Local.abs`); so are potentials that a -product must keep apart. -/ +are and the frontier grows, leaving the room fitting a word. The abstraction is one +(`Local.abs`), and so is the room (`Local.room`); so are potentials that a product must keep +apart. -/ def Local {β : Type*} (f : State → β) : Prop := ∀ {s s'}, M.inv s → (∀ a ∈ M.footprint s, s'.mem a = s.mem a) → - s.frontier ≤ s'.frontier → f s' = f s + s.frontier ≤ s'.frontier → Fits w (s'.frontier + M.room s) → f s' = f s /-- The abstraction reads only the footprint. -/ -theorem Local.abs : M.Local M.abs := fun hs h hf => (M.congr hs h hf).2.1 +theorem Local.abs : M.Local M.abs := fun hs h hf hr => by + obtain ⟨-, habs, -⟩ := M.congr hs h hf hr + exact habs + +/-- The room reads only the footprint. -/ +theorem Local.room : M.Local M.room := fun hs h hf hr => by + obtain ⟨-, -, -, hroom⟩ := M.congr hs h hf hr + exact hroom /-- A constant reads no cell. -/ -theorem Local.const {β : Type*} (b : β) : M.Local fun _ => b := fun _ _ _ => rfl +theorem Local.const {β : Type*} (b : β) : M.Local fun _ => b := fun _ _ _ _ => rfl /-- Sums of local functions are local. -/ -theorem Local.add {f g : State → ℕ} (hf : M.Local f) (hg : M.Local g) : - M.Local fun s => f s + g s := fun hs h hfr => - congrArg₂ (· + ·) (hf hs h hfr) (hg hs h hfr) +theorem Local.add {M : Framed D w} {f g : State → ℕ} (hf : M.Local f) (hg : M.Local g) : + M.Local fun s => f s + g s := fun hs h hfr hr => + congrArg₂ (· + ·) (hf hs h hfr hr) (hg hs h hfr hr) -/-- A run that leaves every allocated cell unchanged preserves a framed refinement. Allocating -another structure is such a run. -/ +/-- A function of the abstract state is local. -/ +theorem Local.comp_abs {β : Type*} (f : D.State → β) : M.Local fun s => f (M.abs s) := + fun hs h hfr hr => congrArg f (Local.abs M hs h hfr hr) + +/-- A run that leaves every allocated cell unchanged and leaves the room fitting preserves a +framed refinement. Allocating another structure is such a run. -/ theorem of_fresh {s s' : State} (hs : M.inv s) - (hmem : ∀ a < s.frontier, s'.mem a = s.mem a) (hf : s.frontier ≤ s'.frontier) : - M.inv s' ∧ M.abs s' = M.abs s ∧ M.footprint s' = M.footprint s := - M.congr hs (fun a ha => hmem a (M.lt_frontier hs ha)) hf + (hmem : ∀ a < s.frontier, s'.mem a = s.mem a) (hf : s.frontier ≤ s'.frontier) + (hroom : Fits w (s'.frontier + M.room s)) : + M.inv s' ∧ M.abs s' = M.abs s ∧ M.footprint s' = M.footprint s ∧ M.room s' = M.room s := + M.congr hs (fun a ha => hmem a (M.lt_frontier hs ha)) hf hroom + +/-- **The frame of a client.** A run of a linked admissible client changes no cell outside the +footprint that was allocated before it, grows the footprint only into fresh cells, and advances +the frontier by at most the room it gives up, as each method run does. -/ +theorem modifies_demonic {α : Type} (p : D.Client α) {s s' : State} {a : α} + {tr : (spec w).Transcript} (hs : M.inv s) (hv : D.DemonicValid (M.abs s) p) + (hrun : (spec w).ClientRun s (link M.methods p) a s' tr) : + (∀ b < s.frontier, b ∉ M.footprint s → s'.mem b = s.mem b) ∧ + (∀ b ∈ M.footprint s', b ∈ M.footprint s ∨ s.frontier ≤ b) ∧ + s'.frontier + M.room s' ≤ s.frontier + M.room s := by + induction p generalizing s tr with + | pure b => + obtain ⟨-, rfl, -⟩ := ((spec w).clientRun_pure_iff _ _ _ _ _).mp hrun + exact ⟨fun _ _ _ => rfl, fun _ hb => .inl hb, le_rfl⟩ + | liftBind o k ih => + obtain ⟨hv_o, hv_k⟩ := (D.demonicValid_liftBind_iff _ o k).mp hv + have heq : link M.methods (.liftBind o k) = + (M.methods o).bind (fun r => link M.methods (k r)) := rfl + rw [heq] at hrun + obtain ⟨r, s₁, tr₁, tr₂, hrun₁, hrun₂, rfl⟩ := (spec w).clientRun_bind_iff.mp hrun + obtain ⟨hstep, hs₁⟩ := M.correct o hs hv_o hrun₁ + obtain ⟨hmod₁, hgrow₁, hroom₁⟩ := M.modifies o hs hv_o hrun₁ + obtain ⟨hmod₂, hgrow₂, hroom₂⟩ := ih r hs₁ (hv_k _ r hstep) hrun₂ + have hf₁ := frontier_le_of_clientRun hrun₁ + refine ⟨fun b hb hb' => ?_, fun b hb => ?_, by omega⟩ + · have hb₁ : b ∉ M.footprint s₁ := fun h => + (hgrow₁ b h).elim hb' fun h' => absurd hb (Nat.not_lt.mpr h') + rw [hmod₂ b (hb.trans_le hf₁) hb₁, hmod₁ b hb hb'] + · rcases hgrow₂ b hb with h | h + · exact hgrow₁ b h + · exact .inr (hf₁.trans h) + +/-! ## Composition -/ + +/-- **A refinement over a framed refinement is framed**, by the same footprint and room: the +upper invariant and abstraction read the lower state only through its abstraction, and each +upper method is a linked client of the lower methods. -/ +def comp (R : Refinement D E) (M : Framed E w) : Framed D w where + toRefinement := R.comp M.toRefinement + footprint := M.footprint + room := M.room + lt_frontier hs ha := M.lt_frontier hs.1 ha + congr {s _} hs h hf hr := by + obtain ⟨hM, hR⟩ := hs + obtain ⟨hM', habs, hfp, hroom⟩ := M.congr hM h hf hr + refine ⟨⟨hM', ?_⟩, ?_, hfp, hroom⟩ + · rwa [habs] + · change R.abs (M.abs _) = R.abs (M.abs s) + rw [habs] + modifies {_} o {_ _ _} hs hv hrun := + M.modifies_demonic (R.methods o) hs.1 (R.valid o hs.2 hv) hrun + +/-- The composite's methods link the upper methods through the lower ones. -/ +theorem comp_methods (R : Refinement D E) (M : Framed E w) : + (comp R M).methods = fun o => link M.methods (R.methods o) := rfl + +/-- The composite is the composition of the refinements. -/ +theorem comp_toRefinement (R : Refinement D E) (M : Framed E w) : + (comp R M).toRefinement = R.comp M.toRefinement := rfl + +/-- The composite's invariant: the lower invariant, and the upper invariant of the lower +abstraction. -/ +theorem comp_inv_iff (R : Refinement D E) (M : Framed E w) (s : State) : + (comp R M).inv s ↔ M.inv s ∧ R.inv (M.abs s) := Iff.rfl + +/-- The composite represents a memory state by the upper abstraction of the lower one. -/ +@[simp] theorem comp_abs (R : Refinement D E) (M : Framed E w) (s : State) : + (comp R M).abs s = R.abs (M.abs s) := rfl + +/-- The composite's footprint is the lower footprint. -/ +@[simp] theorem comp_footprint (R : Refinement D E) (M : Framed E w) (s : State) : + (comp R M).footprint s = M.footprint s := rfl + +/-- The composite's room is the lower room. -/ +@[simp] theorem comp_room (R : Refinement D E) (M : Framed E w) (s : State) : + (comp R M).room s = M.room s := rfl + +/-- A function local to the lower framed refinement is local to the composite. -/ +theorem Local.comp {R : Refinement D E} {M : Framed E w} {β : Type*} {f : State → β} + (hf : M.Local f) : (comp R M).Local f := fun hs h hfr hr => hf hs.1 h hfr hr + +/-- **Potentials stack across composition** with a framed refinement, as for refinements +(`Refinement.Amortized.comp`). -/ +theorem amortized_comp {R : Refinement D E} {M : Framed E w} {lower : State → Op → ℕ} + {middle : E.State → E.Op → ℕ} {upper : D.State → D.Op → ℕ} {Φ : E.State → ℕ} + {Ψ : State → ℕ} (A : R.Amortized middle upper Φ) (B : M.Amortized lower middle Ψ) : + (comp R M).Amortized lower upper fun s => Φ (M.abs s) + Ψ s := + A.comp B + +/-! ## Frames of disjoint structures -/ variable {M} (N : Framed D₂ w) @@ -186,96 +349,122 @@ theorem agree_of_run {s : State} (o : D.Op) {a : D.Result o} {s' : State} ∀ b ∈ N.footprint s, s'.mem b = s.mem b := fun b hb => (M.modifies o hM hv hrun).1 b (N.lt_frontier hN hb) (Finset.disjoint_right.mp hd hb) +/-- A method run of `M` leaves room for `N` when both rooms fitted before. -/ +theorem room_of_run {s : State} (o : D.Op) {a : D.Result o} {s' : State} + {tr : (spec w).Transcript} (hM : M.inv s) (hv : D.valid (M.abs s) o) + (hrun : (spec w).ClientRun s (M.methods o) a s' tr) {r : ℕ} + (hroom : Fits w (s.frontier + (M.room s + r))) : Fits w (s'.frontier + (M.room s' + r)) := + hroom.of_le (by obtain ⟨-, -, h⟩ := M.modifies o hM hv hrun; omega) + /-- **The frame of a framed refinement.** A method run of `M` leaves a framed refinement with a -disjoint footprint unchanged, and the footprints stay disjoint. -/ +disjoint footprint unchanged, and the footprints disjoint and the shared room budget fitting. -/ theorem frame {s : State} (o : D.Op) {a : D.Result o} {s' : State} {tr : (spec w).Transcript} (hM : M.inv s) (hN : N.inv s) - (hd : Disjoint (M.footprint s) (N.footprint s)) (hv : D.valid (M.abs s) o) + (hd : Disjoint (M.footprint s) (N.footprint s)) + (hroom : Fits w (s.frontier + (M.room s + N.room s))) (hv : D.valid (M.abs s) o) (hrun : (spec w).ClientRun s (M.methods o) a s' tr) : - N.abs s' = N.abs s ∧ N.inv s' ∧ N.footprint s' = N.footprint s ∧ - Disjoint (M.footprint s') (N.footprint s') := by + N.abs s' = N.abs s ∧ N.inv s' ∧ N.footprint s' = N.footprint s ∧ N.room s' = N.room s ∧ + Disjoint (M.footprint s') (N.footprint s') ∧ + Fits w (s'.frontier + (M.room s' + N.room s')) := by have hf := frontier_le_of_clientRun hrun - obtain ⟨hN', habs, hfp⟩ := N.congr hN (agree_of_run N o hM hN hd hv hrun) hf - refine ⟨habs, hN', hfp, Finset.disjoint_left.mpr fun b hb hb' => ?_⟩ + have hroom' := room_of_run o hM hv hrun hroom + obtain ⟨hN', habs, hfp, hr⟩ := N.congr hN (agree_of_run N o hM hN hd hv hrun) hf + (hroom'.of_le (by omega)) + refine ⟨habs, hN', hfp, hr, Finset.disjoint_left.mpr fun b hb hb' => ?_, hr ▸ hroom'⟩ rw [hfp] at hb' - rcases (M.modifies o hM hv hrun).2 b hb with hb | hb + obtain ⟨-, hgrow, -⟩ := M.modifies o hM hv hrun + rcases hgrow b hb with hb | hb · exact Finset.disjoint_left.mp hd hb hb' · exact absurd (N.lt_frontier hN hb') (Nat.not_lt.mpr hb) /-- A method run of `M` leaves unchanged every function that reads only a disjoint footprint. -/ theorem Local.frame {β : Type*} {f : State → β} (hf : N.Local f) {s : State} (o : D.Op) {a : D.Result o} {s' : State} {tr : (spec w).Transcript} (hM : M.inv s) (hN : N.inv s) - (hd : Disjoint (M.footprint s) (N.footprint s)) (hv : D.valid (M.abs s) o) + (hd : Disjoint (M.footprint s) (N.footprint s)) + (hroom : Fits w (s.frontier + (M.room s + N.room s))) (hv : D.valid (M.abs s) o) (hrun : (spec w).ClientRun s (M.methods o) a s' tr) : f s' = f s := hf hN (agree_of_run N o hM hN hd hv hrun) (frontier_le_of_clientRun hrun) + ((room_of_run o hM hv hrun hroom).of_le (by omega)) /-! ## Products -/ variable (M₁ : Framed D₁ w) (M₂ : Framed D₂ w) -/-- A method run of the left side keeps the right side and the disjointness of the footprints. -/ +/-- What keeps two framed refinements apart in one memory: disjoint footprints, and room for +both. -/ +def Apart (s : State) : Prop := + Disjoint (M₁.footprint s) (M₂.footprint s) ∧ Fits w (s.frontier + (M₁.room s + M₂.room s)) + +/-- A method run of the left side keeps the right side and keeps the two apart. -/ theorem prod_frame_left {s : State} (o : D₁.Op) {a : D₁.Result o} {s' : State} - {tr : (spec w).Transcript} (h₁ : M₁.inv s) (h₂ : M₂.inv s) - (hd : Disjoint (M₁.footprint s) (M₂.footprint s)) (hv : D₁.valid (M₁.abs s) o) - (hrun : (spec w).ClientRun s (M₁.methods o) a s' tr) : - M₂.abs s' = M₂.abs s ∧ M₂.inv s' ∧ Disjoint (M₁.footprint s') (M₂.footprint s') := - have h := frame M₂ o h₁ h₂ hd hv hrun - ⟨h.1, h.2.1, h.2.2.2⟩ - -/-- A method run of the right side keeps the left side and the disjointness of the footprints. -/ + {tr : (spec w).Transcript} (h₁ : M₁.inv s) (h₂ : M₂.inv s) (hJ : Apart M₁ M₂ s) + (hv : D₁.valid (M₁.abs s) o) (hrun : (spec w).ClientRun s (M₁.methods o) a s' tr) : + M₂.abs s' = M₂.abs s ∧ M₂.inv s' ∧ Apart M₁ M₂ s' := by + obtain ⟨habs, hinv, -, -, hapart⟩ := frame M₂ o h₁ h₂ hJ.1 hJ.2 hv hrun + exact ⟨habs, hinv, hapart⟩ + +/-- A method run of the right side keeps the left side and keeps the two apart. -/ theorem prod_frame_right {s : State} (o : D₂.Op) {a : D₂.Result o} {s' : State} - {tr : (spec w).Transcript} (h₁ : M₁.inv s) (h₂ : M₂.inv s) - (hd : Disjoint (M₁.footprint s) (M₂.footprint s)) (hv : D₂.valid (M₂.abs s) o) - (hrun : (spec w).ClientRun s (M₂.methods o) a s' tr) : - M₁.abs s' = M₁.abs s ∧ M₁.inv s' ∧ Disjoint (M₁.footprint s') (M₂.footprint s') := - have h := frame M₁ o h₂ h₁ hd.symm hv hrun - ⟨h.1, h.2.1, h.2.2.2.symm⟩ + {tr : (spec w).Transcript} (h₁ : M₁.inv s) (h₂ : M₂.inv s) (hJ : Apart M₁ M₂ s) + (hv : D₂.valid (M₂.abs s) o) (hrun : (spec w).ClientRun s (M₂.methods o) a s' tr) : + M₁.abs s' = M₁.abs s ∧ M₁.inv s' ∧ Apart M₁ M₂ s' := by + obtain ⟨habs, hinv, -, -, hd, hroom⟩ := + frame M₁ o h₂ h₁ hJ.1.symm (by rw [Nat.add_comm (M₂.room s)]; exact hJ.2) hv hrun + exact ⟨habs, hinv, hd.symm, by rw [Nat.add_comm (M₁.room s')]; exact hroom⟩ /-- **Products over one memory.** Two framed refinements implement the product of their -specifications over one memory, with the union of their footprints, while the footprints are -disjoint. Disjointness is part of the product's invariant. -/ +specifications over one memory, with the union of their footprints and the sum of their rooms, +while they are apart: their footprints are disjoint and the frontier plus both rooms fits a word. +Being apart is part of the product's invariant. -/ def prod : Framed (product D₁ D₂) w where - toRefinement := M₁.toRefinement.prod M₂.toRefinement - (fun s => Disjoint (M₁.footprint s) (M₂.footprint s)) + toRefinement := M₁.toRefinement.prod M₂.toRefinement (Apart M₁ M₂) (prod_frame_left M₁ M₂) (prod_frame_right M₁ M₂) footprint s := M₁.footprint s ∪ M₂.footprint s + room s := M₁.room s + M₂.room s lt_frontier {_ _} hs ha := by + obtain ⟨h₁, h₂, -⟩ := hs rcases Finset.mem_union.mp ha with ha | ha - · exact M₁.lt_frontier hs.1 ha - · exact M₂.lt_frontier hs.2.1 ha - congr {_ _} hs h hf := by - obtain ⟨h₁, h₂, hd⟩ := hs - obtain ⟨h₁', habs₁, hfp₁⟩ := M₁.congr h₁ (fun a ha => h a (Finset.mem_union_left _ ha)) hf - obtain ⟨h₂', habs₂, hfp₂⟩ := M₂.congr h₂ (fun a ha => h a (Finset.mem_union_right _ ha)) hf - refine ⟨⟨h₁', h₂', ?_⟩, ?_, ?_⟩ - · change Disjoint (M₁.footprint _) (M₂.footprint _) - rwa [hfp₁, hfp₂] + · exact M₁.lt_frontier h₁ ha + · exact M₂.lt_frontier h₂ ha + congr {_ _} hs h hf hr := by + obtain ⟨h₁, h₂, hd, -⟩ := hs + obtain ⟨h₁', habs₁, hfp₁, hr₁⟩ := M₁.congr h₁ + (fun a ha => h a (Finset.mem_union_left _ ha)) hf (hr.of_le (by omega)) + obtain ⟨h₂', habs₂, hfp₂, hr₂⟩ := M₂.congr h₂ + (fun a ha => h a (Finset.mem_union_right _ ha)) hf (hr.of_le (by omega)) + refine ⟨⟨h₁', h₂', ?_, ?_⟩, ?_, ?_, ?_⟩ + · rwa [hfp₁, hfp₂] + · rwa [hr₁, hr₂] · change (M₁.abs _, M₂.abs _) = (M₁.abs _, M₂.abs _) rw [habs₁, habs₂] · rw [hfp₁, hfp₂] + · rw [hr₁, hr₂] modifies {s} o {a s' tr} hs hv hrun := by - obtain ⟨h₁, h₂, hd⟩ := hs + obtain ⟨h₁, h₂, hd, hroom⟩ := hs cases o with | inl o => - obtain ⟨hmod, hgrow⟩ := M₁.modifies o h₁ hv hrun - obtain ⟨-, -, hfp₂, -⟩ := frame M₂ o h₁ h₂ hd hv hrun + obtain ⟨hmod, hgrow, hr⟩ := M₁.modifies o h₁ hv hrun + obtain ⟨-, -, hfp₂, hr₂, -⟩ := frame M₂ o h₁ h₂ hd hroom hv hrun refine ⟨fun b hb hb' => hmod b hb fun h => hb' (Finset.mem_union_left _ h), - fun b hb => ?_⟩ - change b ∈ M₁.footprint s' ∪ M₂.footprint s' at hb - rw [hfp₂] at hb - rcases Finset.mem_union.mp hb with hb | hb - · exact (hgrow b hb).imp_left (Finset.mem_union_left _) - · exact .inl (Finset.mem_union_right _ hb) + fun b hb => ?_, ?_⟩ + · change b ∈ M₁.footprint s' ∪ M₂.footprint s' at hb + rw [hfp₂] at hb + rcases Finset.mem_union.mp hb with hb | hb + · exact (hgrow b hb).imp_left (Finset.mem_union_left _) + · exact .inl (Finset.mem_union_right _ hb) + · omega | inr o => - obtain ⟨hmod, hgrow⟩ := M₂.modifies o h₂ hv hrun - obtain ⟨-, -, hfp₁, -⟩ := frame M₁ o h₂ h₁ hd.symm hv hrun + obtain ⟨hmod, hgrow, hr⟩ := M₂.modifies o h₂ hv hrun + obtain ⟨-, -, hfp₁, hr₁, -⟩ := frame M₁ o h₂ h₁ hd.symm + (by rw [Nat.add_comm (M₂.room s)]; exact hroom) hv hrun refine ⟨fun b hb hb' => hmod b hb fun h => hb' (Finset.mem_union_right _ h), - fun b hb => ?_⟩ - change b ∈ M₁.footprint s' ∪ M₂.footprint s' at hb - rw [hfp₁] at hb - rcases Finset.mem_union.mp hb with hb | hb - · exact .inl (Finset.mem_union_left _ hb) - · exact (hgrow b hb).imp_left (Finset.mem_union_right _) + fun b hb => ?_, ?_⟩ + · change b ∈ M₁.footprint s' ∪ M₂.footprint s' at hb + rw [hfp₁] at hb + rcases Finset.mem_union.mp hb with hb | hb + · exact .inl (Finset.mem_union_left _ hb) + · exact (hgrow b hb).imp_left (Finset.mem_union_right _) + · omega /-- The product's methods run each side's methods. They do not depend on the proofs. -/ theorem prod_methods : (M₁.prod M₂).methods = Methods.prod M₁.methods M₂.methods := rfl @@ -283,26 +472,30 @@ theorem prod_methods : (M₁.prod M₂).methods = Methods.prod M₁.methods M₂ /-- The product represents each side by its own abstraction. -/ @[simp] theorem prod_abs (s : State) : (M₁.prod M₂).abs s = (M₁.abs s, M₂.abs s) := rfl -/-- The product's invariant: both sides' invariants, and disjoint footprints. -/ +/-- The product's invariant: both sides' invariants, and the two sides apart. -/ theorem prod_inv_iff (s : State) : - (M₁.prod M₂).inv s ↔ - M₁.inv s ∧ M₂.inv s ∧ Disjoint (M₁.footprint s) (M₂.footprint s) := Iff.rfl + (M₁.prod M₂).inv s ↔ M₁.inv s ∧ M₂.inv s ∧ Apart M₁ M₂ s := Iff.rfl /-- The product's footprint is the union of the footprints. -/ @[simp] theorem prod_footprint (s : State) : (M₁.prod M₂).footprint s = M₁.footprint s ∪ M₂.footprint s := rfl +/-- The product's room is the sum of the rooms. -/ +@[simp] theorem prod_room (s : State) : (M₁.prod M₂).room s = M₁.room s + M₂.room s := rfl + variable {M₁ M₂} /-- A function local to the left side is local to the product. -/ theorem Local.prod_left {β : Type*} {f : State → β} (hf : M₁.Local f) : - (M₁.prod M₂).Local f := fun hs h hfr => - hf hs.1 (fun a ha => h a (Finset.mem_union_left _ ha)) hfr + (M₁.prod M₂).Local f := fun ⟨h₁, _, _⟩ h hfr hr => + hf h₁ (fun a ha => h a (Finset.mem_union_left _ ha)) hfr + (hr.of_le (Nat.add_le_add_left (Nat.le_add_right _ _) _)) /-- A function local to the right side is local to the product. -/ theorem Local.prod_right {β : Type*} {f : State → β} (hf : M₂.Local f) : - (M₁.prod M₂).Local f := fun hs h hfr => - hf hs.2.1 (fun a ha => h a (Finset.mem_union_right _ ha)) hfr + (M₁.prod M₂).Local f := fun ⟨_, h₂, _⟩ h hfr hr => + hf h₂ (fun a ha => h a (Finset.mem_union_right _ ha)) hfr + (hr.of_le (Nat.add_le_add_left (Nat.le_add_left _ _) _)) /-- **Potentials add across a product over one memory.** Certificates of the two sides against one lower charge, with potentials that read only their own footprints, give a certificate of @@ -313,21 +506,25 @@ theorem amortized_prod {lower : State → Op → ℕ} {upper₁ : D₁.State → (hΦ₁ : M₁.Local Φ₁) (hΦ₂ : M₂.Local Φ₂) : (M₁.prod M₂).Amortized lower (productCharge upper₁ upper₂) fun s => Φ₁ s + Φ₂ s := Refinement.Amortized.prod (frame₁ := prod_frame_left M₁ M₂) (frame₂ := prod_frame_right M₁ M₂) - A₁ A₂ (fun {_} o {_ _ _} h₁ h₂ hd hv hrun => hΦ₂.frame M₂ o h₁ h₂ hd hv hrun) - (fun {_} o {_ _ _} h₁ h₂ hd hv hrun => hΦ₁.frame M₁ o h₂ h₁ hd.symm hv hrun) + A₁ A₂ (fun {_} o {_ _ _} h₁ h₂ hJ hv hrun => hΦ₂.frame M₂ o h₁ h₂ hJ.1 hJ.2 hv hrun) + (fun {_} o {_ _ _} h₁ h₂ hJ hv hrun => hΦ₁.frame M₁ o h₂ h₁ hJ.1.symm + (by rw [Nat.add_comm (M₂.room _)]; exact hJ.2) hv hrun) /-- Setting up a product from structures allocated one after the other: `M₁` holds at `s`; a -run from `s` to `s'` leaves the cells below `s.frontier` unchanged; and `M₂` holds at `s'` on a -footprint at or above `s.frontier`. Then the product holds at `s'`, with `M₁`'s abstraction +run from `s` to `s'` leaves the cells below `s.frontier` unchanged; `M₂` holds at `s'` on a +footprint disjoint from `M₁`'s, such as one at or above `s.frontier`; and the frontier plus both +rooms fits. Then the product holds at `s'`, with `M₁`'s abstraction, footprint and room unchanged. -/ theorem prod_of_fresh {s s' : State} (h₁ : M₁.inv s) (hmem : ∀ a < s.frontier, s'.mem a = s.mem a) (hf : s.frontier ≤ s'.frontier) - (h₂ : M₂.inv s') (hfp : ∀ a ∈ M₂.footprint s', s.frontier ≤ a) : - (M₁.prod M₂).inv s' ∧ (M₁.prod M₂).abs s' = (M₁.abs s, M₂.abs s') := by - obtain ⟨h₁', habs, hfp₁⟩ := M₁.of_fresh h₁ hmem hf - refine ⟨⟨h₁', h₂, Finset.disjoint_left.mpr fun a ha ha' => ?_⟩, by rw [prod_abs, habs]⟩ - rw [hfp₁] at ha - exact absurd (M₁.lt_frontier h₁ ha) (Nat.not_lt.mpr (hfp a ha')) + (h₂ : M₂.inv s') (hd : Disjoint (M₁.footprint s) (M₂.footprint s')) + (hroom : Fits w (s'.frontier + (M₁.room s + M₂.room s'))) : + (M₁.prod M₂).inv s' ∧ (M₁.prod M₂).abs s' = (M₁.abs s, M₂.abs s') ∧ + (M₁.prod M₂).footprint s' = M₁.footprint s ∪ M₂.footprint s' ∧ + (M₁.prod M₂).room s' = M₁.room s + M₂.room s' := by + obtain ⟨h₁', habs, hfp₁, hr₁⟩ := M₁.of_fresh h₁ hmem hf (hroom.of_le (by omega)) + exact ⟨⟨h₁', h₂, by rwa [hfp₁], by rwa [hr₁]⟩, by rw [prod_abs, habs], + by rw [prod_footprint, hfp₁], by rw [prod_room, hr₁]⟩ end Framed diff --git a/Complexity/DataStructure/PriorityQueue/BinaryHeap/Memory.lean b/Complexity/DataStructure/PriorityQueue/BinaryHeap/Memory.lean index 0cb6b26d3e..82a58259e1 100644 --- a/Complexity/DataStructure/PriorityQueue/BinaryHeap/Memory.lean +++ b/Complexity/DataStructure/PriorityQueue/BinaryHeap/Memory.lean @@ -722,6 +722,13 @@ theorem methods_frame (hL : L.Valid w K) {s : Memory.State} (hs : Inv L s) obtain ⟨-, -, -, -, -, h⟩ := methods_run hL hs o hv exact h +/-- An operation leaves the frontier where it was. -/ +theorem methods_frontier (hL : L.Valid w K) {s : Memory.State} (hs : Inv L s) + (o : IndexedMinPQ.Op n) (hv : IndexedMinPQ.valid K (abs L s) o) : + ((Memory.spec w).clientState s (ops L o)).frontier = s.frontier := by + obtain ⟨-, -, -, -, h, -⟩ := methods_run hL hs o hv + exact h + /-! ## The refinement and its frame -/ /-- The binary heap implements the indexed min-priority queue with keys at most `K`. -/ @@ -764,6 +771,7 @@ def framed (hL : L.Valid w K) : Memory.Framed (indexedMinPQSpec n K) w := .ofStatic (refinement hL) L.footprint (fun hs ha => hs.lt_frontier hL ha) (fun hs h hf => ⟨hs.congr hL h hf, abs_congr h⟩) (fun o hs hv b _ hb => methods_frame hL hs o hv b hb) + (fun o hs hv => methods_frontier hL hs o hv) /-- The footprint of a heap is its layout's cells. -/ @[simp] theorem framed_footprint (hL : L.Valid w K) (s : Memory.State) : diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean new file mode 100644 index 0000000000..2bf7a342ac --- /dev/null +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean @@ -0,0 +1,960 @@ +/- +Copyright (c) 2026 Renfei Zhou, Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Renfei Zhou, Samuel Schlesinger +-/ + +module +-- upstream: candidate + +public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.Basic + +/-! +# Fibonacci-heap `decreaseKey` over a record of named cells + +`decreaseKey n v k` lowers the key of `v`. If `v` would precede its parent, `cut` moves `v` to the +root list, and `cascade` walks up the ancestors: a marked ancestor is cut in turn, the first +unmarked one is marked [Fredman and Tarjan][FredmanTarjan1987] +[Cormen et al., Section 19.3][CLRS2009]. Then `setKey` stores the key and makes `v` the minimum +root if it precedes it. Cutting before storing the key keeps every tree valid throughout, so no +pre-decrease copy of the state is needed, unlike the hand-stepped `cutNode_forest`. + +The proof splits as in `Basic.lean`: + +* program evaluation: `wp_unlink`, `wp_toRoot` and `wp_cut` produce the effect `CutsNode` of one + cut on the raw view (the facts of the hand-stepped `cutNodeCode_raw`); `wp_cascade` runs the + cascade by induction on its fuel, which exceeds the number of marks; `wp_setKey` and + `wp_decreaseKey` assemble the three cases (root, no cut, cut); +* forest mathematics on `RawState n` alone: `cutsNode_cutState` (pointer surgery of one cut), + `CutsNode.cascading` (a cut keeps the forest `Cascading`, the content of `cutNode_forest`), + `Cascading.clear_root` and `Cascading.mark` (the cascade stops), `Cascading.lowerRootKey` and + `FibRawInv.lowerKey_noCut` (storing the key), with the existing `ValidSubtree.exists_cut`, + `ValidSubtree.mark_pending`, `ValidSubtree.lower_key_no_cut` and `CutInv.to_fibRawInv`. + +Each cascading cut costs at most `22` record operations and turns a marked non-root into an +unmarked root, which releases `credit = 24`, so the cascade is paid by the potential and +`decreaseKey` costs at most `104` operations amortized. + +The module adapts Renfei Zhou's native formalization (`WordRAM/FibonacciHeap`, its `Cut.lean`) to +the record level: his cut (`cutNodeCode_raw`, `cutNode_forest`, with its circular-list uniqueness +argument) and cascading-cut development become `cut`, `CutsNode.cascading`, +`IsCircList.tail_unique` and `cascade`, and his forest lemmas are reused unchanged. + +## Main definitions + +* `unlink`, `toRoot`, `cut`, `cascade`, `setKey`, `decreaseKey`: record programs. +* `CutsNode`, `cutState`: the effect of one cut on the raw view. +* `Cascading`: the forest during cascading cuts, with one pending ancestor. + +## Main results + +* `IsCircList.tail_unique`: a circular list is determined by its head. +* `wp_cut`: a cut evaluates to `CutsNode` in at most `20` operations. +* `CutsNode.cascading`: a cut keeps the forest `Cascading`, with the parent pending. +* `wp_cascade`: the cascade costs at most `53` operations plus the potential it releases. +* `wp_decreaseKey`: `decreaseKey` implements `IndexedMinPQ.step` with amortized cost `104`. + +## References + +* [M. L. Fredman and R. E. Tarjan, *Fibonacci Heaps and Their Uses in Improved Network Optimization + Algorithms*][FredmanTarjan1987] +* [T. H. Cormen, C. E. Leiserson, R. L. Rivest and C. Stein, *Introduction to Algorithms*, + Section 19.3][CLRS2009] +-/ + +@[expose] public section + +namespace Cslib.DataStructure.PriorityQueue.FibonacciHeap + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.PriorityQueue +open Cslib.DataStructure.PriorityQueue.WordRAM.FibonacciHeap + +/-! ## Programs -/ + +/-- Unlink `z` from the child list of its parent `p`. -/ +def unlink (z p : ℕ) : Prog Unit := do + let d ← rd (.deg p) + wr (.deg p) (d - 1) + if d - 1 = 0 then + wr (.child p) 0 + else + let r ← rd (.right z) + let l ← rd (.left z) + wr (.left r) l + wr (.right l) r + wr (.child p) (r + 1) + +/-- Make the unlinked node `z` an unmarked root after the minimum root. -/ +def toRoot (z : ℕ) : Prog Unit := do + let m ← rd .minRoot + spliceAfter (m - 1) z + wr (.par z) 0 + let mk ← rd (.mark z) + wr (.mark z) 0 + let c ← rd .numMarked + wr .numMarked (c - mk) + let nr ← rd .numRoots + wr .numRoots (nr + 1) + +/-- Cut `z` from its parent `p`: unlink `z` from `p`'s child list, splice it into the root list +after the minimum root, and clear its parent and mark. -/ +def cut (z p : ℕ) : Prog Unit := do + unlink z p + toRoot z + +/-- Cascading cuts from `z`, which has just lost a child, with at most `fuel` cuts: stop at a +root; mark an unmarked node and stop; cut a marked node and continue with its parent. -/ +def cascade : ℕ → ℕ → Prog Unit + | 0, _ => pure () + | fuel + 1, z => do + let pz ← rd (.par z) + if pz = 0 then pure () + else + let mk ← rd (.mark z) + if mk = 0 then + wr (.mark z) 1 + let c ← rd .numMarked + wr .numMarked (c + 1) + else + cut z (pz - 1) + cascade fuel (pz - 1) + +/-- Store the lowered key `k` of `v`, and make `v` the minimum root if it precedes it. -/ +def setKey (v k : ℕ) : Prog Unit := do + wr (.key v) k + let m ← rd .minRoot + let km ← rd (.key (m - 1)) + if IndexedMinPQ.RawPrioLT (v, k) (m - 1, km) then wr .minRoot (v + 1) + +/-- Lower the key of `v` to `k` on a heap of `n` handles: if `v` now precedes its parent, cut it +and cascade from the parent; then store the key and update the minimum root. -/ +def decreaseKey (n v k : ℕ) : Prog Unit := do + let pv ← rd (.par v) + if pv ≠ 0 then + let kp ← rd (.key (pv - 1)) + if IndexedMinPQ.RawPrioLT (v, k) (pv - 1, kp) then + cut v (pv - 1) + cascade (n + 1) (pv - 1) + setKey v k + +/-- The effect of cutting `cur` from its parent `p` when the root list is `m :: rtail`: the facts +of the hand-stepped `cutNodeCode_raw`, on the raw view. -/ +structure CutsNode {n : ℕ} (st : RawState n) (cur p m : Fin n) (rtail : List (Fin n)) + (st' : RawState n) : Prop where + key : st'.key = st.key + inHeap : st'.inHeap = st.inHeap + cons : st'.cons = st.cons + minRoot : st'.minRoot = st.minRoot + sz : st'.sz = st.sz + numRoots : st'.numRoots = st.numRoots + 1 + numMarked : st'.numMarked = st.numMarked - st.mark cur + mark_cur : st'.mark cur = 0 + mark_ne : ∀ u, u ≠ cur → st'.mark u = st.mark u + deg_p : st'.deg p + 1 = st.deg p + deg_ne : ∀ u, u ≠ p → st'.deg u = st.deg u + par_cur : st'.par cur = 0 + par_ne : ∀ u, u ≠ cur → st'.par u = st.par u + child_ne : ∀ u, u ≠ p → st'.child u = st.child u + child_one : st.deg p = 1 → st'.child p = 0 + child_two : ∀ (h : Fin n) (tail : List (Fin n)), 2 ≤ st.deg p → st.child p = h.val + 1 → + IsCircList st.left st.right (h :: tail) → cur ∈ h :: tail → + ∃ (r : Fin n) (rest : List (Fin n)), st'.child p = r.val + 1 ∧ + IsCircList st'.left st'.right (r :: rest) ∧ (r :: rest).Perm ((h :: tail).erase cur) + roots : IsCircList st'.left st'.right (m :: cur :: rtail) + lr_ne : ∀ u, st.par u ≠ p.val + 1 → st.par u ≠ 0 → + st'.left u = st.left u ∧ st'.right u = st.right u + +/-- The state after a cut, given the sibling pointers `left₁`, `right₁` and `p`'s child pointer +`child₁` after unlinking `cur`, and the old right neighbour `r'` of the minimum root `m`. -/ +def cutState {n : ℕ} (st : RawState n) (cur p m r' : Fin n) (left₁ right₁ : Fin n → ℕ) + (child₁ : ℕ) : RawState n := + { st with + deg := Function.update st.deg p (st.deg p - 1) + child := Function.update st.child p child₁ + left := Function.update (Function.update left₁ cur m.val) r' cur.val + right := Function.update (Function.update right₁ cur r'.val) m cur.val + par := Function.update st.par cur 0 + mark := Function.update st.mark cur 0 + numMarked := st.numMarked - st.mark cur + numRoots := st.numRoots + 1 } + +/-- A circular list is determined by its head: from `first`, the `right` pointers trace it. -/ +theorem ChainLinks.tail_unique {n : ℕ} {left right : Fin n → ℕ} {first : Fin n} : + ∀ {prev : Fin n} {t₁ t₂ : List (Fin n)}, (first :: t₁).Nodup → (first :: t₂).Nodup → + ChainLinks left right first prev t₁ → ChainLinks left right first prev t₂ → t₁ = t₂ + | _, [], [], _, _, _, _ => rfl + | _, [], b :: _, _, hnd₂, hc₁, hc₂ => by + have : b = first := Fin.ext (hc₂.1.symm.trans hc₁.1) + subst this + exact absurd List.mem_cons_self (List.nodup_cons.mp hnd₂).1 + | _, a :: _, [], hnd₁, _, hc₁, hc₂ => by + have : a = first := Fin.ext (hc₁.1.symm.trans hc₂.1) + subst this + exact absurd List.mem_cons_self (List.nodup_cons.mp hnd₁).1 + | _, a :: t₁, b :: t₂, hnd₁, hnd₂, hc₁, hc₂ => by + have : a = b := Fin.ext (hc₁.1.symm.trans hc₂.1) + subst this + have sub : ∀ {t : List (Fin n)}, (first :: a :: t).Nodup → (first :: t).Nodup := fun h => + List.nodup_cons.mpr ⟨fun hm => (List.nodup_cons.mp h).1 (List.mem_cons_of_mem a hm), + (List.nodup_cons.mp (List.nodup_cons.mp h).2).2⟩ + rw [ChainLinks.tail_unique (sub hnd₁) (sub hnd₂) hc₁.2.2 hc₂.2.2] + +/-- A circular list is determined by its head. -/ +theorem IsCircList.tail_unique {n : ℕ} {left right : Fin n → ℕ} {h : Fin n} + {t₁ t₂ : List (Fin n)} (h₁ : IsCircList left right (h :: t₁)) + (h₂ : IsCircList left right (h :: t₂)) : t₁ = t₂ := + ChainLinks.tail_unique h₁.1 h₂.1 h₁.2 h₂.2 + +/-- **The effect of a cut**, from `p`'s child pointer and the sibling pointers after unlinking +`cur` (`hunlink`) and the old right neighbour `r'` of the minimum root `m`. -/ +theorem cutsNode_cutState {n : ℕ} {st : RawState n} {cur p m : Fin n} {rtail : List (Fin n)} + (hdp_pos : 1 ≤ st.deg p) + (hdp2 : 2 ≤ st.deg p → ∃ (h : Fin n) (tail : List (Fin n)), + st.child p = h.val + 1 ∧ IsCircList st.left st.right (h :: tail) ∧ + cur ∈ h :: tail ∧ 2 ≤ (h :: tail).length ∧ ∀ u ∈ h :: tail, st.par u = p.val + 1) + (hcirc_r : IsCircList st.left st.right (m :: rtail)) + (hroots_par0 : ∀ u ∈ m :: rtail, st.par u = 0) (hpar_cur : st.par cur = p.val + 1) + {left₁ right₁ : Fin n → ℕ} {child₁ : ℕ} + (hunlink : (st.deg p = 1 ∧ child₁ = 0 ∧ left₁ = st.left ∧ right₁ = st.right) ∨ + (2 ≤ st.deg p ∧ ∃ r l : Fin n, st.right cur = r.val ∧ st.left cur = l.val ∧ + child₁ = r.val + 1 ∧ left₁ = Function.update st.left r l.val ∧ + right₁ = Function.update st.right l r.val)) + {r' : Fin n} (hr' : right₁ m = r'.val) : + CutsNode st cur p m rtail (cutState st cur p m r' left₁ right₁ child₁) := by + -- Roots have parent `0`, children of `p` have parent `p + 1`. + have hroot_ne : ∀ u ∈ m :: rtail, ∀ x, st.par x = p.val + 1 → x ≠ u := fun u hu x hx e => by + rw [e, hroots_par0 u hu] at hx; omega + have hcur_roots : cur ∉ m :: rtail := fun hc => hroot_ne cur hc cur hpar_cur rfl + -- In both cases, the unlinked pointers agree with the old ones at the roots, and at every node + -- whose parent is not `p`. + have hframe₁ : ∀ x, st.par x ≠ p.val + 1 → left₁ x = st.left x ∧ right₁ x = st.right x := by + rcases hunlink with ⟨_, _, rfl, rfl⟩ | ⟨h2, r, l, hr, hl, _, rfl, rfl⟩ + · exact fun _ _ => ⟨rfl, rfl⟩ + · obtain ⟨h, tail, _, hcirc, hcur, hlen, hpar⟩ := hdp2 h2 + obtain ⟨r₂, l₂, _, hr₂, hl₂, hr₂m, hl₂m, -⟩ := hcirc.remove hcur hlen + obtain rfl : r₂ = r := Fin.ext (hr₂.symm.trans hr) + obtain rfl : l₂ = l := Fin.ext (hl₂.symm.trans hl) + intro x hx + have hxr : x ≠ r₂ := fun e => hx (e ▸ hpar r₂ hr₂m) + have hxl : x ≠ l₂ := fun e => hx (e ▸ hpar l₂ hl₂m) + simp [Function.update_of_ne hxr, Function.update_of_ne hxl] + have hcirc₁ : IsCircList left₁ right₁ (m :: rtail) := + hcirc_r.frame fun x hx => hframe₁ x fun e => hroot_ne x hx x e rfl + have hr'_roots : r' ∈ m :: rtail := by + obtain ⟨r'', hr'', hmem⟩ := hcirc₁.right_head + exact (Fin.ext (hr''.symm.trans hr') : r'' = r') ▸ hmem + have hroots' := hcirc₁.insertAfter hcur_roots hr' + -- Nodes off the root list and off `p`'s children keep their sibling pointers. + have hframe : ∀ x, st.par x ≠ p.val + 1 → st.par x ≠ 0 → + (cutState st cur p m r' left₁ right₁ child₁).left x = st.left x ∧ + (cutState st cur p m r' left₁ right₁ child₁).right x = st.right x := fun x hx hx0 => by + have hxc : x ≠ cur := fun e => hx (e ▸ hpar_cur) + have hxm : x ≠ m := fun e => hx0 (e ▸ hroots_par0 m List.mem_cons_self) + have hxr : x ≠ r' := fun e => hx0 (e ▸ hroots_par0 r' hr'_roots) + simpa [cutState, Function.update_of_ne hxc, Function.update_of_ne hxm, + Function.update_of_ne hxr] using hframe₁ x hx + refine ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, by simp [cutState], + fun u hu => by simp [cutState, hu], by simp [cutState]; omega, + fun u hu => by simp [cutState, hu], by simp [cutState], fun u hu => by simp [cutState, hu], + fun u hu => by simp [cutState, hu], fun h1 => ?_, ?_, hroots', hframe⟩ + · rcases hunlink with ⟨_, rfl, _⟩ | ⟨h2, _⟩ + · simp [cutState] + · omega + · intro h tail h2 hcp hcirc hcur + rcases hunlink with ⟨h1, _⟩ | ⟨-, r, l, hr, hl, rfl, rfl, rfl⟩ + · omega + obtain ⟨h₀, tail₀, hcp₀, hcirc₀, -, hlen₀, hpar₀⟩ := hdp2 h2 + obtain rfl : h₀ = h := Fin.ext (by omega) + obtain rfl := IsCircList.tail_unique hcirc hcirc₀ + obtain ⟨r₂, l₂, rest, hr₂, hl₂, -, -, -, hcirc₂, hperm₂⟩ := hcirc.remove hcur hlen₀ + obtain rfl : r₂ = r := Fin.ext (hr₂.symm.trans hr) + obtain rfl : l₂ = l := Fin.ext (hl₂.symm.trans hl) + refine ⟨r₂, rest, by simp [cutState], hcirc₂.frame fun x hx => ?_, hperm₂⟩ + have hx_er := hperm₂.subset hx + have hxc : x ≠ cur := fun e => by subst e; exact hcirc.1.not_mem_erase hx_er + have hpx := hpar₀ x (List.mem_of_mem_erase hx_er) + simp [cutState, Function.update_of_ne hxc, + Function.update_of_ne (hroot_ne m List.mem_cons_self x hpx), + Function.update_of_ne (hroot_ne r' hr'_roots x hpx)] + +/-! ## Forest mathematics of cascading cuts -/ + +/-- The forest during cascading cuts from `v`: `FibRawInv` with one `pending` ancestor that may +have lost a child, and with the minimum-root comparison waived for `v`. With `v` a root, this is +the existing `CutInv`. -/ +structure Cascading (n K : ℕ) (s : IndexedMinPQ.State n) (st : RawState n) (v m : Fin n) + (pending : Option (Fin n)) (ts : List (FHTree n)) : Prop where + valid : ∀ T ∈ ts, ValidRoot st pending T + nodup : (forestNodes ts).Nodup + dom : ∀ u, u ∈ forestNodes ts ↔ (s u).isSome + inHeap : ∀ u, (st.inHeap u ≠ 0 ↔ (s u).isSome) ∧ st.inHeap u ≤ 1 + keys : ∀ u ku, s u = some ku → st.key u = ku ∧ ku ≤ K + sz : st.sz = (IndexedMinPQ.dom s).card + numRoots : st.numRoots = ts.length + numMarked : st.numMarked = markedCount st + cons : ∀ d ≤ n, st.cons d = 0 + minRoot : st.minRoot = m.val + 1 + roots : ∃ rtail, IsCircList st.left st.right (m :: rtail) ∧ (m :: rtail).Perm (ts.map FHTree.root) + min_le : ∀ T ∈ ts, T.root ≠ v → IndexedMinPQ.PrioLE (m, st.key m) (T.root, st.key T.root) + +/-- With `v` a root, `Cascading` is the existing `CutInv`. -/ +theorem Cascading.cutInv {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} {v m : Fin n} + {pending : Option (Fin n)} {ts : List (FHTree n)} (h : Cascading n K s st v m pending ts) + (hv : ∃ T ∈ ts, T.root = v) : CutInv n K s st v m pending := by + obtain ⟨rtail, hcirc, hperm⟩ := h.roots + exact ⟨ts, h.valid, h.nodup, h.dom, h.inHeap, h.keys, h.sz, h.numRoots, h.numMarked, h.cons, + ⟨rtail, h.minRoot, hcirc, hperm⟩, hv, h.min_le⟩ + +/-- A valid heap is `Cascading` with nothing pending. -/ +theorem cascading_of_fibRawInv {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} {v : Fin n} + (h : FibRawInv n K s st) (hv : (s v).isSome) : + ∃ m ts, Cascading n K s st v m none ts := by + obtain ⟨ts, hts, hnd, hdom, hin, hkeys, hsz, hnr, hnm, hcons, hrl⟩ := h + rcases hrl with ⟨rfl, _⟩ | ⟨m, rtail, hm, hcirc, hperm, hle⟩ + · exact absurd ((hdom v).mpr hv) List.not_mem_nil + · exact ⟨m, ts, ⟨hts, hnd, hdom, hin, hkeys, hsz, hnr, hnm, hcons, hm, ⟨rtail, hcirc, hperm⟩, + fun T hT _ => hle T hT⟩⟩ + +/-- In a valid subtree with distinct nodes, every node has fewer children than the tree has +nodes. -/ +theorem ValidSubtree.deg_lt_length {n : ℕ} {st : RawState n} {pending : Option (Fin n)} + {T : FHTree n} (hT : ValidSubtree st pending T) (hnd : T.nodes.Nodup) {x : Fin n} + (hx : x ∈ T.nodes) : st.deg x < T.nodes.length := by + induction hT with + | @mk u cs _ _ hdeg _ _ _ _ _ ih => + have hlen : (FHTree.node u cs).nodes.length = (forestNodes cs).length + 1 := by + simp [FHTree.nodes] + rw [hlen] + rcases List.mem_cons.mp hx with rfl | hx + · have := forestNodes_length_ge cs + omega + · obtain ⟨c, hc, hxc⟩ := mem_forestNodes_iff.mp hx + have hnd_c := forestNodes_nodup_tree (List.nodup_cons.mp hnd).2 hc + have := ih c hc hnd_c hxc + obtain ⟨l₁, l₂, rfl⟩ := List.append_of_mem hc + have : c.nodes.length ≤ (forestNodes (l₁ ++ c :: l₂)).length := by + simp only [forestNodes_append, forestNodes, List.length_append] + omega + omega + +/-- **A cut keeps the forest `Cascading`**, with the parent `p` now pending. The cut node `cur` +becomes the root of a new tree; its old tree loses that subtree. This is the forest part of the +hand-stepped `cutNode_forest`. -/ +theorem CutsNode.cascading {n K : ℕ} {s : IndexedMinPQ.State n} {st st' : RawState n} + {cur p v m : Fin n} {pending : Option (Fin n)} {ts : List (FHTree n)} {rtail : List (Fin n)} + (h : Cascading n K s st v m pending ts) (hperm_r : (m :: rtail).Perm (ts.map FHTree.root)) + (hpend : pending = none ∨ pending = some cur) + (hv_root : cur = v ∨ ∃ T ∈ ts, T.root = v) + (hcur_ne_v : ∀ T ∈ ts, cur ∈ T.nodes → T.root ≠ v) + (hcur : cur ∈ forestNodes ts) (hpar_cur : st.par cur = p.val + 1) + (hcut : CutsNode st cur p m rtail st') : + ∃ ts', Cascading n K s st' v m (some p) ts' ∧ (∃ T ∈ ts', T.root = v) ∧ + (∀ T ∈ ts', p ∈ T.nodes → T.root ≠ v) ∧ p ∈ forestNodes ts' := by + obtain ⟨Ti, hTi, hcur_Ti⟩ := mem_forestNodes_iff.mp hcur + obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp hTi + have hnd_Ti : (ts[i]).nodes.Nodup := forestNodes_nodup_tree h.nodup hTi + have hTi_ne_v : (ts[i]).root ≠ v := hcur_ne_v _ hTi hcur_Ti + have hcur_ne_root : cur ≠ (ts[i]).root := fun e => by + have := (h.valid _ hTi).2.1 + rw [← e] at this + omega + have hcur_desc : cur ∈ forestNodes (ts[i]).children := by + rw [(ts[i]).nodes_eq] at hcur_Ti + exact (List.mem_cons.mp hcur_Ti).resolve_left hcur_ne_root + obtain ⟨T_cut, T', hcut_r, hT'_r, hp_T', hperm_Ti, hvalid_cut, hvalid_T'⟩ := + (h.valid _ hTi).1.exists_cut hnd_Ti hcur_desc hpar_cur hpend + (fun u _ => ⟨congrFun hcut.inHeap u, congrFun hcut.key u⟩) + ⟨hcut.mark_cur, fun u _ hu => hcut.mark_ne u hu⟩ + ⟨hcut.deg_p, fun u _ hu => hcut.deg_ne u hu⟩ + ⟨hcut.par_cur, fun u _ hu => hcut.par_ne u hu⟩ + ⟨hcut.child_one, hcut.child_two⟩ + (fun u _ hu => hcut.child_ne u hu) (fun u _ h1 h0 => hcut.lr_ne u h1 h0) + have hnd_cut_T' : (T_cut.nodes ++ T'.nodes).Nodup := hperm_Ti.nodup_iff.mpr hnd_Ti + have hcur_T' : cur ∉ T'.nodes := fun hm => + (List.nodup_append.mp hnd_cut_T').2.2 cur (hcut_r ▸ T_cut.root_mem_nodes) cur hm rfl + have hT'_ne_cur : T'.root ≠ cur := fun e => hcur_T' (e ▸ T'.root_mem_nodes) + let ts' : List (FHTree n) := T_cut :: ts.set i T' + have hperm_fn : (forestNodes ts').Perm (forestNodes ts) := + forestNodes_set_perm ts i hi T_cut T' hperm_Ti + have hnd' : (forestNodes ts').Nodup := hperm_fn.nodup_iff.mpr h.nodup + have hT'_mem : T' ∈ ts' := List.mem_cons_of_mem _ (List.mem_iff_getElem.mpr + ⟨i, by simpa using hi, by simp⟩) + -- Every other tree is untouched: none of its nodes is `cur` or `p`. + have hother : ∀ j (hj : j < ts.length), j ≠ i → ValidRoot st' (some p) ts[j] := by + intro j hj hji + have hcur_j : cur ∉ (ts[j]).nodes := fun hm => + forestNodes_nodup_idx_disjoint h.nodup hi hj (Ne.symm hji) hcur_Ti hm + have hp_j : p ∉ (ts[j]).nodes := fun hm => by + have hp_Ti : p ∈ (ts[i]).nodes := hperm_Ti.subset (List.mem_append_right _ hp_T') + exact forestNodes_nodup_idx_disjoint h.nodup hi hj (Ne.symm hji) hp_Ti hm + have hsub : ValidSubtree st none ts[j] := by + rcases hpend with rfl | rfl + · exact (h.valid _ (List.getElem_mem hj)).1 + · exact (h.valid _ (List.getElem_mem hj)).1.clear_pending fun hm => + hcur_j ((ts[j]).nodes_eq ▸ List.mem_cons_of_mem _ hm) + have hr_ne : (ts[j]).root ≠ cur := fun e => hcur_j (e ▸ (ts[j]).root_mem_nodes) + refine ⟨(hsub.frame (pending' := none) (fun u hu => ?_) (fun u hu => ?_)).weaken_pending _, + by rw [hcut.par_ne _ hr_ne]; exact (h.valid _ (List.getElem_mem hj)).2.1, + by rw [hcut.mark_ne _ hr_ne]; exact (h.valid _ (List.getElem_mem hj)).2.2⟩ + · have hu_cur : u ≠ cur := fun e => hcur_j (e ▸ hu) + have hu_p : u ≠ p := fun e => hp_j (e ▸ hu) + exact ⟨congrFun hcut.inHeap u, hcut.mark_ne u hu_cur, hcut.deg_ne u hu_p, + hcut.child_ne u hu_p, congrFun hcut.key u⟩ + · have hu_j : u ∈ (ts[j]).nodes := (ts[j]).nodes_eq ▸ List.mem_cons_of_mem _ hu + have hu_cur : u ≠ cur := fun e => hcur_j (e ▸ hu_j) + obtain ⟨q, hq, hpq⟩ := hsub.par_of_mem_children u hu + have hqp : q ≠ p := fun e => hp_j (e ▸ hq) + have hlr := hcut.lr_ne u (by rw [hpq]; have := Fin.val_ne_of_ne hqp; omega) + (by rw [hpq]; omega) + exact ⟨hcut.par_ne u hu_cur, hlr.1, hlr.2, Iff.rfl⟩ + have hvalid' : ∀ T ∈ ts', ValidRoot st' (some p) T := by + intro T hT + rcases List.mem_cons.mp hT with rfl | hT + · exact ⟨hvalid_cut.1.weaken_pending _, hvalid_cut.2.1, hvalid_cut.2.2⟩ + · obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hT + have hj' : j < ts.length := by simpa using hj + by_cases hji : j = i + · subst hji + simp only [List.getElem_set_self] + refine ⟨hvalid_T', ?_, ?_⟩ + · rw [hcut.par_ne _ hT'_ne_cur, hT'_r]; exact (h.valid _ hTi).2.1 + · rw [hcut.mark_ne _ hT'_ne_cur, hT'_r]; exact (h.valid _ hTi).2.2 + · rw [List.getElem_set_ne (Ne.symm hji)] + exact hother j hj' hji + have hroots' : (m :: cur :: rtail).Perm (ts'.map FHTree.root) := by + simp only [ts', List.map_cons, hcut_r, map_root_set_eq ts i hi T' hT'_r] + exact (List.Perm.swap cur m rtail).trans (List.Perm.cons cur hperm_r) + have hmem_set : ∀ j (hj : j < ts.length), j ≠ i → ts[j] ∈ ts' := fun j hj hji => + List.mem_cons_of_mem _ (List.mem_iff_getElem.mpr ⟨j, by simpa using hj, + by simp [List.getElem_set_ne (Ne.symm hji)]⟩) + refine ⟨ts', ⟨hvalid', hnd', fun u => hperm_fn.mem_iff.trans (h.dom u), + fun u => by rw [hcut.inHeap]; exact h.inHeap u, + fun u ku hu => by rw [hcut.key]; exact h.keys u ku hu, hcut.sz.trans h.sz, + by rw [hcut.numRoots, h.numRoots]; simp [ts'], ?_, + fun d hd => by rw [hcut.cons]; exact h.cons d hd, + hcut.minRoot.trans h.minRoot, ⟨cur :: rtail, hcut.roots, hroots'⟩, ?_⟩, ?_, ?_, + mem_forestNodes_iff.mpr ⟨T', hT'_mem, hp_T'⟩⟩ + · -- The cut node loses its mark, if any. + obtain ⟨-, -, -, hin_cur, hmk_cur, -⟩ := exists_parent_info (h.valid _ hTi).1 hcur_desc hpar_cur + rw [hcut.numMarked, h.numMarked] + have hiff : ∀ x, x ≠ cur → ((st'.inHeap x ≠ 0 ∧ st'.mark x ≠ 0) ↔ + (st.inHeap x ≠ 0 ∧ st.mark x ≠ 0)) := fun x hx => by + rw [hcut.inHeap, hcut.mark_ne x hx] + by_cases hm0 : st.mark cur = 0 + · rw [hm0, Nat.sub_zero] + refine (markedCount_congr fun x => ?_).symm + by_cases hx : x = cur + · subst hx; simp [hcut.mark_cur, hm0] + · exact hiff x hx + · have := markedCount_clear_one hin_cur hm0 hcut.mark_cur hiff + omega + · intro T hT hTv + rw [hcut.key] + rcases List.mem_cons.mp hT with rfl | hT + · rw [hcut_r] at hTv ⊢ + exact (h.min_le _ hTi hTi_ne_v).trans ((h.valid _ hTi).1.prioLE_of_mem hcur_Ti) + · obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hT + have hj' : j < ts.length := by simpa using hj + by_cases hji : j = i + · subst hji + simp only [List.getElem_set_self, hT'_r] at hTv ⊢ + exact h.min_le _ hTi hTi_ne_v + · simp only [List.getElem_set_ne (Ne.symm hji)] at hTv ⊢ + exact h.min_le _ (List.getElem_mem hj') hTv + · rcases hv_root with rfl | ⟨Tv, hTv, hTv_r⟩ + · exact ⟨T_cut, List.mem_cons_self, hcut_r⟩ + · obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.mp hTv + have hji : j ≠ i := fun e => by subst e; exact hTi_ne_v hTv_r + exact ⟨_, hmem_set j hj hji, hTv_r⟩ + · intro T hT hpT + by_cases hTT' : T = T' + · subst hTT'; rw [hT'_r]; exact hTi_ne_v + · exact (forestNodes_nodup_disjoint hnd' hT hT'_mem hTT' hpT hp_T').elim + +/-- A node of the forest with a parent `p` is a strict descendant of its tree. -/ +theorem Cascading.desc_of_par {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + {v m : Fin n} {pending : Option (Fin n)} {ts : List (FHTree n)} + (h : Cascading n K s st v m pending ts) {z : Fin n} (hz : z ∈ forestNodes ts) + (hpz : st.par z ≠ 0) : ∃ T ∈ ts, z ∈ forestNodes T.children := by + obtain ⟨T, hT, hzT⟩ := mem_forestNodes_iff.mp hz + refine ⟨T, hT, ?_⟩ + rw [T.nodes_eq] at hzT + exact (List.mem_cons.mp hzT).resolve_left fun e => hpz (e ▸ (h.valid T hT).2.1) + +/-- **The preconditions of a cut** of a non-root `cur` from its parent `p`, as `wp_cut` takes +them. -/ +theorem Cascading.cut_pre {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + {v m : Fin n} {pending : Option (Fin n)} {ts : List (FHTree n)} {rtail : List (Fin n)} + (h : Cascading n K s st v m pending ts) (hperm_r : (m :: rtail).Perm (ts.map FHTree.root)) + {cur p : Fin n} (hcur : cur ∈ forestNodes ts) (hpar_cur : st.par cur = p.val + 1) : + 1 ≤ st.deg p ∧ + (2 ≤ st.deg p → ∃ (h : Fin n) (tail : List (Fin n)), + st.child p = h.val + 1 ∧ IsCircList st.left st.right (h :: tail) ∧ + cur ∈ h :: tail ∧ 2 ≤ (h :: tail).length ∧ ∀ u ∈ h :: tail, st.par u = p.val + 1) ∧ + st.deg p ≤ n ∧ (∀ u ∈ m :: rtail, st.par u = 0) ∧ st.numRoots + 1 ≤ n ∧ + st.numMarked ≤ n := by + obtain ⟨T, hT, hdesc⟩ := h.desc_of_par hcur (by omega) + obtain ⟨hpT, -, -, -, -, hdp, hdp2⟩ := exists_parent_info (h.valid T hT).1 hdesc hpar_cur + have hnd_T := forestNodes_nodup_tree h.nodup hT + have hdeg := ValidSubtree.deg_lt_length (h.valid T hT).1 hnd_T hpT + have hlen : T.nodes.length ≤ n := by simpa using hnd_T.length_le_card + have hroot0 : ∀ u ∈ ts.map FHTree.root, st.par u = 0 := fun u hu => by + obtain ⟨R, hR, rfl⟩ := List.mem_map.mp hu + exact (h.valid R hR).2.1 + have hcur_roots : cur ∉ ts.map FHTree.root := fun hm => by + have := hroot0 cur hm + omega + have hnd_roots : (cur :: ts.map FHTree.root).Nodup := + List.nodup_cons.mpr ⟨hcur_roots, map_root_nodup h.nodup⟩ + have hnr : (cur :: ts.map FHTree.root).length ≤ n := by simpa using hnd_roots.length_le_card + simp only [List.length_cons, List.length_map] at hnr + refine ⟨hdp, hdp2, by omega, fun u hu => hroot0 u (hperm_r.subset hu), by rw [h.numRoots]; omega, + h.numMarked ▸ markedCount_le_n st⟩ + +/-- **The cascade stops at a root**: a pending root has lost nothing that matters. -/ +theorem Cascading.clear_root {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + {v m z : Fin n} {ts : List (FHTree n)} (h : Cascading n K s st v m (some z) ts) + (hz : z ∈ forestNodes ts) (hpz : st.par z = 0) : Cascading n K s st v m none ts := by + obtain ⟨Tz, hTz, hzT⟩ := mem_forestNodes_iff.mp hz + have hz_root : z = Tz.root := ((h.valid Tz hTz).par_eq_zero_iff_root hzT).mp hpz + refine { h with valid := fun T hT => ⟨(h.valid T hT).1.clear_pending fun hm => ?_, + (h.valid T hT).2.1, (h.valid T hT).2.2⟩ } + exact descendant_ne_root_of_nodup h.nodup hT hTz hm hz_root + +/-- **The cascade stops at an unmarked node**, which it marks. -/ +theorem Cascading.mark {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + {v m z : Fin n} {ts : List (FHTree n)} (h : Cascading n K s st v m (some z) ts) + (hz : z ∈ forestNodes ts) (hpz : st.par z ≠ 0) (hmz : st.mark z = 0) : + Cascading n K s { st with + mark := Function.update st.mark z 1 + numMarked := st.numMarked + 1 } v m none ts := by + obtain ⟨Tz, hTz, hdesc⟩ := h.desc_of_par hz hpz + have hzT : z ∈ Tz.nodes := Tz.nodes_eq ▸ List.mem_cons_of_mem _ hdesc + have hz_ne_root : ∀ T ∈ ts, T.root ≠ z := fun T hT e => + descendant_ne_root_of_nodup h.nodup hTz hT hdesc e.symm + refine { h with valid := fun T hT => ⟨?_, (h.valid T hT).2.1, ?_⟩, numMarked := ?_ } + · by_cases hTT : T = Tz + · subst hTT + exact (h.valid T hT).1.mark_pending hmz (by simp) + (fun x _ hx => by simp [Function.update_of_ne hx]) (fun _ _ => ⟨rfl, rfl, rfl, rfl⟩) + (fun _ _ => ⟨rfl, rfl, rfl⟩) + · have hzT' : z ∉ T.nodes := fun hm => forestNodes_nodup_disjoint h.nodup hT hTz hTT hm hzT + exact ((h.valid T hT).1.clear_pending fun hm => hzT' (T.nodes_eq ▸ List.mem_cons_of_mem _ hm) + ).frame (fun x hx => ⟨rfl, by + simp [Function.update_of_ne (fun e : x = z => hzT' (e ▸ hx))], rfl, rfl, rfl⟩) + (fun _ _ => ⟨rfl, rfl, rfl, Iff.rfl⟩) + · simpa [Function.update_of_ne (hz_ne_root T hT)] using (h.valid T hT).2.2 + · obtain ⟨T, hT, hzT⟩ := mem_forestNodes_iff.mp hz + have hin_z : st.inHeap z ≠ 0 := ((h.inHeap z).1).mpr ((h.dom z).mp hz) + rw [h.numMarked] + exact (markedCount_set_one (st := st) + (st' := { st with mark := Function.update st.mark z 1, numMarked := st.numMarked + 1 }) + hin_z hmz (by simp) fun x hx => by simp [Function.update_of_ne hx]).symm + +/-- **Lowering the key of the root `v`** keeps every tree valid, and with `v` a root the forest +satisfies the existing `CutInv`, ready for the minimum-root update. -/ +theorem Cascading.lowerRootKey {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + {v m : Fin n} {ts : List (FHTree n)} (h : Cascading n K s st v m none ts) + (hv : ∃ T ∈ ts, T.root = v) {k₀ k : ℕ} (hsv : s v = some k₀) (hk₀ : k ≤ k₀) (hK : k ≤ K) : + CutInv n K (Function.update s v (some k)) { st with key := Function.update st.key v k } + v m none := by + obtain ⟨Tv, hTv, rfl⟩ := hv + have hkv : st.key Tv.root = k₀ := (h.keys _ k₀ hsv).1 + have hvalid : ∀ T ∈ ts, ValidRoot { st with key := Function.update st.key Tv.root k } none T := by + intro T hT + by_cases hTT : T = Tv + · subst hTT + refine ⟨(h.valid T hT).1.lower_key_no_cut (k := k) (forestNodes_nodup_tree h.nodup hT) + T.root_mem_nodes (by omega) (by simp) (fun x _ hx => by simp [hx]) + (fun _ _ => ⟨rfl, rfl, rfl, rfl⟩) (fun _ _ => ⟨rfl, rfl, rfl⟩) (Or.inl rfl), + (h.valid T hT).2.1, (h.valid T hT).2.2⟩ + · have hv_T : Tv.root ∉ T.nodes := fun hm => forestNodes_nodup_disjoint h.nodup hT hTv hTT hm + Tv.root_mem_nodes + exact (h.valid T hT).frame_tree (fun x hx => ⟨rfl, rfl, rfl, rfl, + by simp [Function.update_of_ne (fun e : x = Tv.root => hv_T (e ▸ hx))], rfl⟩) + (fun _ _ => ⟨rfl, rfl⟩) + have hsome : ∀ u, (Function.update s Tv.root (some k) u).isSome = (s u).isSome := fun u => by + by_cases hu : u = Tv.root + · subst hu; simp [hsv] + · simp [hu] + obtain ⟨rtail, hcirc, hperm⟩ := h.roots + refine ⟨ts, hvalid, h.nodup, fun u => (h.dom u).trans (by rw [hsome]), + fun u => by rw [hsome]; exact h.inHeap u, fun u ku hu => ?_, ?_, h.numRoots, + h.numMarked.trans (markedCount_congr fun _ => Iff.rfl).symm, h.cons, + ⟨rtail, h.minRoot, hcirc, hperm⟩, ⟨Tv, hTv, rfl⟩, fun T hT hTr => ?_⟩ + · by_cases hu' : u = Tv.root + · subst hu' + simp only [Function.update_self, Option.some.injEq] at hu + subst hu + simp [hK] + · rw [Function.update_of_ne hu'] at hu + simpa [hu'] using h.keys u ku hu + · rw [h.sz, IndexedMinPQ.dom_decreaseKey (IndexedMinPQ.mem_dom_iff.mpr ⟨k₀, hsv⟩)] + · have hle := h.min_le T hT hTr + simp only [Function.update_of_ne hTr] + by_cases hmv : m = Tv.root + · subst hmv + simp only [Function.update_self] + refine IndexedMinPQ.PrioLE.trans ?_ hle + dsimp only [IndexedMinPQ.PrioLE, IndexedMinPQ.RawPrioLE] + omega + · simpa [Function.update_of_ne hmv] using hle + +/-- **Lowering a key without a cut.** If `v` keeps its heap order with its parent `p`, the heap +stays valid, and `v` cannot precede the minimum root. -/ +theorem FibRawInv.lowerKey_noCut {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + {v p : Fin n} {k₀ k : ℕ} (h : FibRawInv n K s st) (hsv : s v = some k₀) (hk₀ : k ≤ k₀) + (hK : k ≤ K) (hpv : st.par v = p.val + 1) (hord : ¬IndexedMinPQ.PrioLT (v, k) (p, st.key p)) : + FibRawInv n K (Function.update s v (some k)) { st with key := Function.update st.key v k } ∧ + ∀ m : Fin n, st.minRoot = m.val + 1 → + ¬IndexedMinPQ.PrioLT (v, k) (m, Function.update st.key v k m) := by + obtain ⟨m, ts, hc⟩ := cascading_of_fibRawInv (v := v) h (by simp [hsv]) + obtain ⟨Tv, hTv, hvT⟩ := mem_forestNodes_iff.mp ((hc.dom v).mpr (by simp [hsv])) + have hkv : st.key v = k₀ := (hc.keys v k₀ hsv).1 + have hv_ne_root : ∀ T ∈ ts, T.root ≠ v := fun T hT e => by + have := (hc.valid T hT).2.1 + rw [e] at this + omega + let st₁ : RawState n := { st with key := Function.update st.key v k } + have hvalid : ∀ T ∈ ts, ValidRoot st₁ none T := by + intro T hT + by_cases hTT : T = Tv + · subst hTT + exact ⟨(hc.valid T hT).1.lower_key_no_cut (k := k) (forestNodes_nodup_tree hc.nodup hT) hvT + (by omega) (by simp [st₁]) (fun x _ hx => by simp [st₁, hx]) + (fun _ _ => ⟨rfl, rfl, rfl, rfl⟩) (fun _ _ => ⟨rfl, rfl, rfl⟩) (Or.inr ⟨p, hpv, hord⟩), + (hc.valid T hT).2.1, (hc.valid T hT).2.2⟩ + · have hv_T : v ∉ T.nodes := fun hm => forestNodes_nodup_disjoint hc.nodup hT hTv hTT hm hvT + exact (hc.valid T hT).frame_tree (fun x hx => ⟨rfl, rfl, rfl, rfl, + by simp [st₁, Function.update_of_ne (fun e : x = v => hv_T (e ▸ hx))], rfl⟩) + (fun _ _ => ⟨rfl, rfl⟩) + have hroot_key : ∀ T ∈ ts, st₁.key T.root = st.key T.root := fun T hT => by + simp [st₁, Function.update_of_ne (hv_ne_root T hT)] + obtain ⟨rtail, hcirc, hperm⟩ := hc.roots + obtain ⟨Tm, hTm, hTm_r⟩ := List.mem_map.mp (hperm.subset List.mem_cons_self) + have hmv : m ≠ v := hTm_r ▸ hv_ne_root Tm hTm + have hcut : CutInv n K (Function.update s v (some k)) st₁ Tv.root m none := by + have hsome : ∀ u, (Function.update s v (some k) u).isSome = (s u).isSome := fun u => by + by_cases hu : u = v + · subst hu; simp [hsv] + · simp [hu] + refine ⟨ts, hvalid, hc.nodup, fun u => (hc.dom u).trans (by rw [hsome]), + fun u => by rw [hsome]; exact hc.inHeap u, fun u ku hu => ?_, ?_, hc.numRoots, + hc.numMarked.trans (markedCount_congr fun _ => Iff.rfl).symm, hc.cons, + ⟨rtail, hc.minRoot, hcirc, hperm⟩, ⟨Tv, hTv, rfl⟩, fun T hT _ => ?_⟩ + · by_cases hu' : u = v + · subst hu' + simp only [Function.update_self, Option.some.injEq] at hu + subst hu + simp [st₁, hK] + · rw [Function.update_of_ne hu'] at hu + simpa [st₁, hu'] using hc.keys u ku hu + · rw [hc.sz, IndexedMinPQ.dom_decreaseKey (IndexedMinPQ.mem_dom_iff.mpr ⟨k₀, hsv⟩)] + · rw [hroot_key T hT, ← hTm_r, hroot_key Tm hTm, hTm_r] + by_cases hTv' : T.root = v + · exact (hv_ne_root T hT hTv').elim + · exact hc.min_le T hT hTv' + -- `m` precedes the root of `v`'s tree, which precedes `v`. + have hmin_v : IndexedMinPQ.PrioLE (m, st₁.key m) (v, k) := by + have h1 := hc.min_le Tv hTv (hv_ne_root Tv hTv) + have h2 := (hvalid Tv hTv).1.prioLE_of_mem hvT + rw [← hroot_key Tv hTv, ← hTm_r, ← hroot_key Tm hTm, hTm_r] at h1 + simpa [st₁] using h1.trans h2 + refine ⟨CutInv.to_fibRawInv hcut ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + (Or.inr ⟨fun hlt => ?_, hc.minRoot⟩), fun m' hm' => ?_⟩ + · have hle := hc.min_le Tv hTv (hv_ne_root Tv hTv) + rw [← hroot_key Tv hTv, ← hTm_r, ← hroot_key Tm hTm, hTm_r] at hle + exact IndexedMinPQ.not_prioLT_iff_prioLE.mpr hle hlt + · obtain rfl : m' = m := Fin.ext (by have := hc.minRoot; omega) + exact IndexedMinPQ.not_prioLT_iff_prioLE.mpr hmin_v + +section Programs + +variable {n w : ℕ} + +/-- Splicing `u` after `h`, whose right neighbour is `r`, makes four writes. -/ +theorem wp_spliceAfter {g : Cell → ℕ} {h u r : Fin n} (hr : (view n g).right h = r.val) + (hfit : Fits w n) {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : Q () (Function.update (Function.update (Function.update (Function.update g + (.left u) h) (.left r) u) (.right u) r) (.right h) u) 5) : + Record.wp (Cell.ok n) w (spliceAfter h u) Q g := by + have hr' : g (.right h) = r.val := hr + simp only [spliceAfter, Record.wp_read_bind, Record.wp_write_bind, Record.wp_write, hr', + Cell.ok] + exact ⟨h.isLt, ⟨u.isLt, hfit.of_le h.isLt.le⟩, ⟨r.isLt, hfit.of_le u.isLt.le⟩, + ⟨u.isLt, hfit.of_le r.isLt.le⟩, ⟨h.isLt, hfit.of_le u.isLt.le⟩, hQ⟩ + +/-- Unlinking `cur` from `p`'s children evaluates to the two cases of `cutsNode_cutState`. -/ +theorem wp_unlink {g : Cell → ℕ} {cur p : Fin n} + (hdp_pos : 1 ≤ (view n g).deg p) + (hdp2 : 2 ≤ (view n g).deg p → ∃ (h : Fin n) (tail : List (Fin n)), + (view n g).child p = h.val + 1 ∧ IsCircList (view n g).left (view n g).right (h :: tail) ∧ + cur ∈ h :: tail ∧ 2 ≤ (h :: tail).length ∧ ∀ u ∈ h :: tail, (view n g).par u = p.val + 1) + (hdp_le : (view n g).deg p ≤ n) (hfit : Fits w n) {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g' t, t ≤ 7 → ∀ (left₁ right₁ : Fin n → ℕ) (child₁ : ℕ), + (((view n g).deg p = 1 ∧ child₁ = 0 ∧ left₁ = (view n g).left ∧ + right₁ = (view n g).right) ∨ + (2 ≤ (view n g).deg p ∧ ∃ r l : Fin n, (view n g).right cur = r.val ∧ + (view n g).left cur = l.val ∧ child₁ = r.val + 1 ∧ + left₁ = Function.update (view n g).left r l.val ∧ + right₁ = Function.update (view n g).right l r.val)) → + view n g' = { view n g with + deg := Function.update (view n g).deg p ((view n g).deg p - 1) + child := Function.update (view n g).child p child₁ + left := left₁ + right := right₁ } → Q () g' t) : + Record.wp (Cell.ok n) w (unlink cur p) Q g := by + have hpn := p.isLt + have hdp : g (.deg p) = (view n g).deg p := rfl + by_cases h1 : (view n g).deg p - 1 = 0 + · simp only [unlink, Record.wp_bind, Record.wp_read, Record.wp_write, hdp, h1, ite_true, + Cell.ok] + refine ⟨hpn, ⟨hpn, fits_zero w⟩, ⟨hpn, fits_zero w⟩, hQ _ _ (by omega) _ _ 0 + (Or.inl ⟨by omega, rfl, rfl, rfl⟩) ?_⟩ + simp only [view_update_deg, view_update_child, h1] + · obtain ⟨h, tail, -, hcirc, hcur, hlen, hpar⟩ := hdp2 (by omega) + obtain ⟨r, l, -, hr, hl, -⟩ := hcirc.remove hcur hlen + have hr' : g (.right cur) = r.val := hr + have hl' : g (.left cur) = l.val := hl + simp only [unlink, Record.wp_bind, Record.wp_read, Record.wp_write, hdp, h1, ite_false, + Function.update_apply, reduceCtorEq, hr', hl', Cell.ok] + refine ⟨hpn, ⟨hpn, hfit.of_le (by omega)⟩, cur.isLt, cur.isLt, ⟨r.isLt, hfit.of_le l.isLt.le⟩, + ⟨l.isLt, hfit.of_le r.isLt.le⟩, ⟨hpn, hfit.of_le r.isLt⟩, hQ _ _ (by omega) _ _ _ + (Or.inr ⟨by omega, r, l, hr, hl, rfl, rfl, rfl⟩) ?_⟩ + simp only [view_update_deg, view_update_child, view_update_left, view_update_right] + +/-- Moving the unlinked `cur` to the root list after the minimum root `m`, whose right neighbour +is `r'`, makes thirteen operations. -/ +theorem wp_toRoot {g : Cell → ℕ} {cur m r' : Fin n} (hm : (view n g).minRoot = m.val + 1) + (hr' : (view n g).right m = r'.val) (hfit : Fits w n) (hnr : (view n g).numRoots + 1 ≤ n) + (hnm : (view n g).numMarked ≤ n) {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g', view n g' = { view n g with + left := Function.update (Function.update (view n g).left cur m.val) r' cur.val + right := Function.update (Function.update (view n g).right cur r'.val) m cur.val + par := Function.update (view n g).par cur 0 + mark := Function.update (view n g).mark cur 0 + numMarked := (view n g).numMarked - (view n g).mark cur + numRoots := (view n g).numRoots + 1 } → Q () g' 13) : + Record.wp (Cell.ok n) w (toRoot cur) Q g := by + have hm' : g .minRoot = m.val + 1 := hm + simp only [toRoot, Record.wp_read_bind, hm', Nat.add_sub_cancel] + refine ⟨trivial, ?_⟩ + rw [Record.wp_bind] + refine wp_spliceAfter hr' hfit ?_ + simp only [Record.wp_write_bind, Record.wp_read_bind, Record.wp_write, Function.update_apply, + reduceCtorEq, ite_false, Cell.ok, true_and] + refine ⟨⟨cur.isLt, fits_zero w⟩, cur.isLt, ⟨cur.isLt, fits_zero w⟩, + hfit.of_le ((Nat.sub_le _ _).trans hnm), hfit.of_le hnr, hQ _ ?_⟩ + simp only [view_update_left, view_update_right, view_update_par, view_update_mark, + view_update_numMarked, view_update_numRoots] + rfl + +/-- **One cut.** Cutting `cur` from its parent `p` evaluates to `CutsNode` in at most `20` +operations. The hypotheses are those of the hand-stepped `cutNodeCode_raw`. -/ +theorem wp_cut {g : Cell → ℕ} {cur p m : Fin n} {rtail : List (Fin n)} + (hdp_pos : 1 ≤ (view n g).deg p) + (hdp2 : 2 ≤ (view n g).deg p → ∃ (h : Fin n) (tail : List (Fin n)), + (view n g).child p = h.val + 1 ∧ IsCircList (view n g).left (view n g).right (h :: tail) ∧ + cur ∈ h :: tail ∧ 2 ≤ (h :: tail).length ∧ ∀ u ∈ h :: tail, (view n g).par u = p.val + 1) + (hdp_le : (view n g).deg p ≤ n) + (hmin : (view n g).minRoot = m.val + 1) + (hcirc_r : IsCircList (view n g).left (view n g).right (m :: rtail)) + (hroots_par0 : ∀ u ∈ m :: rtail, (view n g).par u = 0) + (hpar_cur : (view n g).par cur = p.val + 1) + (hfit : Fits w n) (hnr : (view n g).numRoots + 1 ≤ n) (hnm : (view n g).numMarked ≤ n) + {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g' t, t ≤ 20 → CutsNode (view n g) cur p m rtail (view n g') → Q () g' t) : + Record.wp (Cell.ok n) w (cut cur p) Q g := by + rw [cut, Record.wp_bind] + refine wp_unlink hdp_pos hdp2 hdp_le hfit fun g₁ t₁ ht₁ left₁ right₁ child₁ hunlink hg₁ => ?_ + -- The minimum root's right neighbour, after unlinking. + have hr₁ : ∃ r' : Fin n, right₁ m = r'.val := by + obtain ⟨r', hr', -⟩ := hcirc_r.right_head + rcases hunlink with ⟨-, -, -, rfl⟩ | ⟨h2, r, l, -, hl, -, -, rfl⟩ + · exact ⟨r', hr'⟩ + · obtain ⟨h, tail, -, hcirc, hcur, hlen, hpar⟩ := hdp2 h2 + obtain ⟨r₂, l₂, -, -, hl₂, -, hl₂m, -⟩ := hcirc.remove hcur hlen + obtain rfl : l₂ = l := Fin.ext (hl₂.symm.trans hl) + have hml : m ≠ l₂ := fun e => by + have := hroots_par0 m List.mem_cons_self + rw [e, hpar l₂ hl₂m] at this + omega + exact ⟨r', by rw [Function.update_of_ne hml]; exact hr'⟩ + obtain ⟨r', hr'⟩ := hr₁ + refine wp_toRoot (by rw [hg₁]; exact hmin) (by rw [hg₁]; exact hr') hfit + (by rw [hg₁]; exact hnr) (by rw [hg₁]; exact hnm) fun g₂ hg₂ => hQ _ _ (by omega) ?_ + rw [hg₂, hg₁] + exact cutsNode_cutState hdp_pos hdp2 hcirc_r hroots_par0 hpar_cur hunlink hr' + +/-- **Cascading cuts.** From a forest with `z` pending, the cascade leaves a forest with nothing +pending. Each cut costs at most `22` operations and releases one credit (one more root, one mark +less), so the whole cascade costs at most `53` operations plus the potential it releases. -/ +theorem wp_cascade {K : ℕ} {s : IndexedMinPQ.State n} {v m : Fin n} (hfit : Fits w n) : + ∀ (fuel : ℕ) {g : Cell → ℕ} {z : Fin n} {ts : List (FHTree n)}, + Cascading n K s (view n g) v m (some z) ts → (∃ T ∈ ts, T.root = v) → + (∀ T ∈ ts, z ∈ T.nodes → T.root ≠ v) → z ∈ forestNodes ts → + (view n g).numMarked < fuel → + Record.wp (Cell.ok n) w (cascade fuel z) (fun _ g' t => ∃ ts', + Cascading n K s (view n g') v m none ts' ∧ (∃ T ∈ ts', T.root = v) ∧ + t + potential n g' ≤ 53 + potential n g) g + | 0, _, _, _, _, _, _, _, hfuel => absurd hfuel (Nat.not_lt_zero _) + | fuel + 1, g, z, ts, h, hv, hzv, hz, hfuel => by + have hzn := z.isLt + simp only [cascade, Record.wp_read_bind, Cell.ok] + refine ⟨hzn, ?_⟩ + by_cases hpz : (view n g).par z = 0 + · have hpz' : g (.par z) = 0 := hpz + simp only [hpz', ite_true, Record.wp_pure] + exact ⟨ts, h.clear_root hz hpz, hv, by omega⟩ + obtain ⟨T, hT, hdesc⟩ := h.desc_of_par hz hpz + obtain ⟨p, -, hpar⟩ := (h.valid T hT).1.par_of_mem_children z hdesc + obtain ⟨-, -, -, hinz, hmz1, -⟩ := exists_parent_info (h.valid T hT).1 hdesc hpar + have hpar' : g (.par z) = p.val + 1 := hpar + simp only [hpar', Nat.add_one_ne_zero, ite_false, Record.wp_read_bind, Nat.add_sub_cancel, + Cell.ok] + refine ⟨hzn, ?_⟩ + by_cases hmz : (view n g).mark z = 0 + · have hmz' : g (.mark z) = 0 := hmz + have hc' := h.mark hz hpz hmz + have hcount : (view n g).numMarked + 1 ≤ n := + calc (view n g).numMarked + 1 = markedCount _ := hc'.numMarked + _ ≤ n := markedCount_le_n _ + simp only [hmz', ite_true, Record.wp_write_bind, Record.wp_read_bind, Record.wp_write, + Function.update_apply, reduceCtorEq, ite_false, Cell.ok, true_and] + refine ⟨⟨hzn, hfit.of_le (by omega)⟩, hfit.of_le hcount, ts, ?_, hv, ?_⟩ + · simp only [view_update_mark, view_update_numMarked] + exact hc' + · have : (view n g).numMarked = g .numMarked := rfl + simp only [potential, credit, view_update_mark, view_update_numMarked] + omega + · have hmz' : g (.mark z) ≠ 0 := hmz + simp only [hmz', ite_false] + rw [Record.wp_bind] + obtain ⟨rtail, hcirc, hperm⟩ := h.roots + obtain ⟨hdp, hdp2, hdp_le, hroots0, hnr, hnm⟩ := h.cut_pre hperm hz hpar + refine wp_cut hdp hdp2 hdp_le h.minRoot hcirc hroots0 hpar hfit hnr hnm + fun g₁ t₁ ht₁ hcut => ?_ + obtain ⟨ts₁, hc₁, hv₁, hpv₁, hp₁⟩ := + hcut.cascading h hperm (Or.inr rfl) (Or.inr hv) hzv hz hpar + have hpos : 1 ≤ (view n g).numMarked := by + rw [h.numMarked] + exact Finset.card_pos.mpr ⟨z, by simp [markedSet, hinz, hmz]⟩ + have hnm₁ : (view n g₁).numMarked + 1 = (view n g).numMarked := by + rw [hcut.numMarked]; omega + refine Record.wp_mono (fun _ g' t ⟨ts', hc', hv', hcost⟩ => ⟨ts', hc', hv', ?_⟩) + (wp_cascade hfit fuel hc₁ hv₁ hpv₁ hp₁ (by omega)) + simp only [potential, credit] at hcost ⊢ + rw [hcut.numRoots] at hcost + omega + +/-- **Storing the key.** With the forest ready (`v` a root, or `v` not preceding the minimum +root), storing the key and updating the minimum root restores `FibRawInv`. -/ +theorem wp_setKey {K : ℕ} {s' : IndexedMinPQ.State n} {g : Cell → ℕ} {v m : Fin n} {k : ℕ} + (hm : (view n g).minRoot = m.val + 1) (hk : Fits w k) (hfit : Fits w n) + (hpost : CutInv n K s' { view n g with key := Function.update (view n g).key v k } v m none ∨ + (FibRawInv n K s' { view n g with key := Function.update (view n g).key v k } ∧ + ¬IndexedMinPQ.PrioLT (v, k) (m, Function.update (view n g).key v k m))) + {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g' t, t ≤ 4 → FibRawInv n K s' (view n g') → + (view n g').numRoots = (view n g).numRoots → + (view n g').numMarked = (view n g).numMarked → Q () g' t) : + Record.wp (Cell.ok n) w (setKey v k) Q g := by + have hm' : g .minRoot = m.val + 1 := hm + have hkm : Function.update g (.key v) k (.key m) = Function.update (view n g).key v k m := by + by_cases hmv : m = v + · subst hmv; simp + · simp [Function.update_of_ne hmv, Fin.val_ne_of_ne hmv, view] + simp only [setKey, Record.wp_write_bind, Record.wp_read_bind, Function.update_apply, + reduceCtorEq, ite_false, hm', Nat.add_sub_cancel, Cell.ok, true_and] + rw [← Function.update_apply (f := g), hkm] + refine ⟨⟨v.isLt, hk⟩, m.isLt, ?_⟩ + by_cases hlt : IndexedMinPQ.PrioLT (v, k) (m, Function.update (view n g).key v k m) + · have hlt' : IndexedMinPQ.RawPrioLT (↑v, k) (↑m, Function.update (view n g).key v k m) := hlt + simp only [hlt', ite_true, Record.wp_write, Cell.ok, true_and] + refine ⟨hfit.of_le v.isLt, hQ _ _ (by omega) ?_ rfl rfl⟩ + rcases hpost with hcut | ⟨-, hnlt⟩ + · simp only [view_update_minRoot, view_update_key] + exact CutInv.to_fibRawInv hcut ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + (Or.inl ⟨by simpa using hlt, rfl⟩) + · exact (hnlt hlt).elim + · have hlt' : ¬IndexedMinPQ.RawPrioLT (↑v, k) (↑m, Function.update (view n g).key v k m) := hlt + simp only [hlt', ite_false, Record.wp_pure] + refine hQ _ _ (by omega) ?_ rfl rfl + rcases hpost with hcut | ⟨hinv, -⟩ + · simp only [view_update_key] + exact CutInv.to_fibRawInv hcut ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + (Or.inr ⟨by simpa using hlt, hm⟩) + · simpa only [view_update_key] using hinv + +/-- **Decreasing a key.** `decreaseKey n v k` lowers the key of the present handle `v` to `k`, +preserves the invariant, and costs at most `104` operations amortized. -/ +theorem wp_decreaseKey {K : ℕ} {g : Cell → ℕ} {v : Fin n} {k₀ k : ℕ} (hI : Inv n K g) + (hsv : abs n g v = some k₀) (hk₀ : k ≤ k₀) (hK : k ≤ K) (hfit : Fits w n) + (hKfit : Fits w K) : + Record.wp (Cell.ok n) w (decreaseKey n v k) (fun _ g' t => + abs n g' = Function.update (abs n g) v (some k) ∧ Inv n K g' ∧ + t + potential n g' ≤ 104 + potential n g) g := by + have hvn := v.isLt + have hkfit : Fits w k := hKfit.of_le hK + obtain ⟨m, ts, hc⟩ := cascading_of_fibRawInv (v := v) hI (by simp [hsv]) + have hv_fn : v ∈ forestNodes ts := (hc.dom v).mpr (by simp [hsv]) + obtain ⟨Tv, hTv, hvT⟩ := mem_forestNodes_iff.mp hv_fn + -- Every case ends in `setKey` from a state with the same counters as its potential says. + have hdone : ∀ g' t, FibRawInv n K (Function.update (abs n g) v (some k)) (view n g') → + t + potential n g' ≤ 104 + potential n g → + abs n g' = Function.update (abs n g) v (some k) ∧ Inv n K g' ∧ + t + potential n g' ≤ 104 + potential n g := fun g' t hinv hcost => by + obtain ⟨hI', habs⟩ := inv_of_fibRawInv hinv + exact ⟨habs, hI', hcost⟩ + simp only [decreaseKey, Record.wp_read_bind, Cell.ok] + refine ⟨hvn, ?_⟩ + by_cases hpv : (view n g).par v = 0 + · have hpv' : g (.par v) = 0 := hpv + have hvr : v = Tv.root := ((hc.valid Tv hTv).par_eq_zero_iff_root hvT).mp hpv + simp only [hpv', ne_eq, not_true_eq_false, ite_false] + refine wp_setKey hc.minRoot hkfit hfit + (Or.inl (hc.lowerRootKey ⟨Tv, hTv, hvr.symm⟩ hsv hk₀ hK)) fun g' t ht hinv hnr hnm => ?_ + have hpot : potential n g' = potential n g := by simp only [potential, hnr, hnm] + exact hdone g' (t + 1) hinv (by omega) + · obtain ⟨T, hT, hdesc⟩ := hc.desc_of_par hv_fn hpv + obtain ⟨p, -, hpar⟩ := (hc.valid T hT).1.par_of_mem_children v hdesc + have hpar' : g (.par v) = p.val + 1 := hpar + simp only [hpar', ne_eq, Nat.add_one_ne_zero, not_false_eq_true, ite_true, Nat.add_sub_cancel, + Record.wp_read_bind, Cell.ok] + refine ⟨p.isLt, ?_⟩ + by_cases hlt : IndexedMinPQ.PrioLT (v, k) (p, (view n g).key p) + · -- `v` now precedes its parent: cut it, cascade, and store the key. + have hlt' : IndexedMinPQ.RawPrioLT (↑v, k) (↑p, g (.key ↑p)) := hlt + simp only [hlt', ite_true] + rw [Record.wp_bind] + obtain ⟨rtail, hcirc, hperm⟩ := hc.roots + obtain ⟨hdp, hdp2, hdp_le, hroots0, hnr, hnm⟩ := hc.cut_pre hperm hv_fn hpar + refine wp_cut hdp hdp2 hdp_le hc.minRoot hcirc hroots0 hpar hfit hnr hnm + fun g₁ t₁ ht₁ hcut => ?_ + have hv_ne : ∀ T ∈ ts, v ∈ T.nodes → T.root ≠ v := fun T hT _ e => + hpv (e ▸ (hc.valid T hT).2.1) + obtain ⟨ts₁, hc₁, hv₁, hpv₁, hp₁⟩ := + hcut.cascading hc hperm (Or.inl rfl) (Or.inl rfl) hv_ne hv_fn hpar + rw [Record.wp_bind] + refine Record.wp_mono ?_ (wp_cascade hfit (n + 1) hc₁ hv₁ hpv₁ hp₁ + (by rw [hcut.numMarked]; omega)) + rintro _ g₂ t₂ ⟨ts₂, hc₂, hv₂, hcost₂⟩ + refine wp_setKey hc₂.minRoot hkfit hfit (Or.inl (hc₂.lowerRootKey hv₂ hsv hk₀ hK)) + fun g' t ht hinv hnr' hnm' => hdone g' _ hinv ?_ + have hΦ₁ : potential n g₁ ≤ potential n g + 24 := by + simp only [potential, credit, hcut.numRoots, hcut.numMarked] + omega + have hΦ' : potential n g' = potential n g₂ := by simp only [potential, hnr', hnm'] + omega + · -- `v` keeps its heap order: only the key changes. + have hlt' : ¬IndexedMinPQ.RawPrioLT (↑v, k) (↑p, g (.key ↑p)) := hlt + simp only [hlt', ite_false] + obtain ⟨hinv, hnot⟩ := FibRawInv.lowerKey_noCut hI hsv hk₀ hK hpar hlt + refine wp_setKey hc.minRoot hkfit hfit (Or.inr ⟨hinv, hnot m hc.minRoot⟩) + fun g' t ht hinv' hnr hnm => ?_ + have hpot : potential n g' = potential n g := by simp only [potential, hnr, hnm] + exact hdone g' (t + 1 + 1) hinv' (by omega) + +end Programs + +end Cslib.DataStructure.PriorityQueue.FibonacciHeap diff --git a/Complexity/DataStructure/Queue/Memory.lean b/Complexity/DataStructure/Queue/Memory.lean index 89acafde8b..e3845a1645 100644 --- a/Complexity/DataStructure/Queue/Memory.lean +++ b/Complexity/DataStructure/Queue/Memory.lean @@ -22,16 +22,18 @@ proved once: (`Queue.potential_step`); only the capacity and word-fit admissibility of the bounded stacks is new. Each queue operation costs at most three stack calls, amortized, with two credits per rear element. -2. `pair`: two array stacks with disjoint layouts in one memory, as the generic product - `Memory.Framed.prod` of two framed stacks, each stack call costing at most three memory +2. Two array stacks allocated one after the other, as the generic product + `Memory.Allocator.prod` of two stack allocators, each stack call costing at most three memory units. -`memRefinement` composes them, and `mem_amortized` stacks the potentials across the composition -(`Refinement.Amortized.comp`): every queue operation costs at most nine memory units, amortized, -with six credits per rear element. `run` allocates the two stacks and then runs a queue client. -From any memory with room for both stacks, `run_correct` gives its answer and the admissibility of -its memory operations, `run_cost` bounds its memory cost by `6 + 9 m` for `m` queue operations, -and `run_cost_isBigO` exports that bound as `O(m)`. +`allocator` puts the first step on top of the second (`Memory.Allocator.comp`), and +`amortized_allocator` stacks the potentials across the composition: every queue operation costs +at most nine memory units, amortized, with six credits per rear element. `run` allocates the two +stacks and then runs a queue client. From any memory with room for both stacks, `run_correct` +gives its answer and the admissibility of its memory operations, `run_cost` bounds its memory +cost by `6 + 9 m` for `m` queue operations, and `run_cost_isBigO` exports that bound as `O(m)`. +All three are instances of the generic theorems of `Memory.Allocator`, so this file has no setup +proof of its own. The machine-level counterpart is `Queue.WordRAM`, whose dispatcher is hand-stepped instruction by instruction. Here the proofs mention neither registers nor instructions. Executing the memory @@ -43,16 +45,15 @@ provide. * `boundedStacks`: the pair of bounded stacks. * `Inv`: a FIFO list within capacity holding words. * `refinement`: the two-stack queue over the pair of bounded stacks. -* `pair`: the two stacks in one memory. -* `memRefinement`, `memMethods`: the queue over two array stacks over memory, and its methods as - plain memory programs. +* `allocator`: the queue over two array stacks, allocated in memory. * `run`: allocate the stacks, then run a queue client. ## Main results * `runClient_boundedStacks`: bounded stacks run clients exactly as unbounded ones. * `amortized`: three stack calls per queue operation, with two credits per rear element. -* `mem_amortized`: nine memory units per queue operation, with six credits per rear element. +* `amortized_allocator`: nine memory units per queue operation, with six credits per rear + element. * `run_correct`, `run_cost`: the allocated queue answers like the specification and costs at most `6 + 9 m` memory units for `m` queue operations. * `run_cost_glue`: with glue charged per memory operation, at most `(2 K + 1) (6 + 9 m)`. @@ -191,100 +192,37 @@ theorem amortized : /-! ## Over memory -/ -/-- The two stacks over one memory, in disjoint layouts. -/ -abbrev pair {L₁ L₂ : Stack.Memory.Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) : - Memory.Framed (boundedStacks w C) w := - (Stack.Memory.framed h₁).prod (Stack.Memory.framed h₂) +/-- The queue over two array stacks of capacity `C`: allocate the stacks one after the other, +and run the two-stack queue on their product. -/ +def allocator (w C : ℕ) : Allocator (Queue.WordRAM.spec w C) w := + ((Stack.Memory.allocator w C).prod (Stack.Memory.allocator w C)).comp (refinement w C) + (show Inv w C [] from ⟨Nat.zero_le C, fun _ h => absurd h List.not_mem_nil⟩) -/-- The queue over two array stacks over memory. -/ -def memRefinement {L₁ L₂ : Stack.Memory.Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) : - Refinement (Queue.WordRAM.spec w C) (Memory.spec w) := - (refinement w C).comp (pair h₁ h₂).toRefinement +/-- The allocated queue is empty. -/ +@[simp] theorem init_allocator : (allocator w C).init = [] := rfl + +/-- The two stacks take `2 (C + 1)` cells. -/ +@[simp] theorem room_allocator : (allocator w C).room = 2 * (C + 1) := by + change (C + 1) + (C + 1) = _ + omega + +/-- The two stacks are allocated from scratch, so the allocation needs nothing of the memory +besides room. -/ +theorem pre_allocator (s : Memory.State) : (allocator w C).Pre s := + ⟨trivial, trivial, Finset.disjoint_empty_left _⟩ /-- **Stacked potentials.** Every queue operation costs at most nine memory units, amortized, with six credits per element of the rear stack: the queue's potential, at three memory units per -stack call, read through the stacks' abstraction. -/ -theorem mem_amortized {L₁ L₂ : Stack.Memory.Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) : - (memRefinement h₁ h₂).Amortized charge (fun _ _ => 9) - fun s => 6 * (Stack.Memory.abs L₂ s).length := by - have hpair := Memory.Framed.amortized_prod (Stack.Memory.amortized h₁) - (Stack.Memory.amortized h₂) (Memory.Framed.Local.const _ 0) (Memory.Framed.Local.const _ 0) +stack call, read through the stacks' abstraction. Allocation leaves no potential. -/ +theorem amortized_allocator : (allocator w C).Amortized (fun _ _ => 9) 0 := by + have hpair := (Stack.Memory.amortized_allocator (w := w) (C := C)).prod + (Stack.Memory.amortized_allocator (w := w) (C := C)) rw [productCharge_const] at hpair - have h := (amortized.mul_left 3).comp hpair - have hΦ : (fun s : Memory.State => - 3 * (2 * (Stack.Memory.abs L₂ s).length) + (0 + 0)) = - fun s => 6 * (Stack.Memory.abs L₂ s).length := by - funext s - omega - exact hΦ ▸ h - -/-! ## Allocation and a whole run -/ - -/-- The queue methods over two array stacks, as plain memory programs. -/ -def memMethods (L₁ L₂ : Stack.Memory.Layout) (w C : ℕ) : - Methods (Queue.WordRAM.spec w C) (Memory.spec w) := - fun o => link (Methods.prod (Stack.Memory.methods L₁ w C) (Stack.Memory.methods L₂ w C)) - (methods o) - -/-- The composite's methods are `memMethods`, whatever the proofs about the layouts. -/ -theorem memRefinement_methods {L₁ L₂ : Stack.Memory.Layout} (h₁ : L₁.Valid w C) - (h₂ : L₂.Valid w C) : (memRefinement h₁ h₂).methods = memMethods L₁ L₂ w C := rfl + exact Allocator.Amortized.comp (amortized.mul_left 3) hpair /-- Allocate two empty stacks of capacity `C`, then run a queue client on them. -/ -def run (w C : ℕ) {β : Type} (p : (Queue.WordRAM.spec w C).Client β) : Prog β := do - let L₁ ← Stack.Memory.allocLayout C - let L₂ ← Stack.Memory.allocLayout C - link (memMethods L₁ L₂ w C) p - -/-- The first stack allocated from `s`. -/ -abbrev frontLayout (s : Memory.State) (C : ℕ) : Stack.Memory.Layout := - ⟨⟨s.frontier, 1⟩, ⟨s.frontier + 1, C⟩⟩ - -/-- The second stack allocated from `s`. -/ -abbrev rearLayout (s : Memory.State) (C : ℕ) : Stack.Memory.Layout := - ⟨⟨s.frontier + 1 + C, 1⟩, ⟨s.frontier + 1 + C + 1, C⟩⟩ - -/-- The memory after both allocations. -/ -abbrev allocated (s : Memory.State) (C : ℕ) : Memory.State := - ⟨clear (clear s.mem s.frontier 1) (s.frontier + 1 + C) 1, s.frontier + 1 + C + 1 + C⟩ - -/-- A run allocates both stacks, then runs the linked client from the allocated memory. -/ -theorem runClient_run {β : Type} (p : (Queue.WordRAM.spec w C).Client β) (s : Memory.State) : - (Memory.spec w).runClient s (run w C p) = - let (v, s', os) := (Memory.spec w).runClient (allocated s C) - (link (memMethods (frontLayout s C) (rearLayout s C) w C) p) - (v, s', .alloc 1 :: .allocDirty C :: .alloc 1 :: .allocDirty C :: os) := rfl - -/-- The facts that start the refinement after allocation. -/ -private theorem setup (s : Memory.State) (hfit : Fits w (s.frontier + 2 * (C + 1))) : - ∃ (h₁ : (frontLayout s C).Valid w C) (h₂ : (rearLayout s C).Valid w C), - (memRefinement h₁ h₂).inv (allocated s C) ∧ - (memRefinement h₁ h₂).abs (allocated s C) = [] ∧ - Stack.Memory.abs (rearLayout s C) (allocated s C) = [] := by - have h₁ : (frontLayout s C).Valid w C := Stack.Memory.valid_allocLayout (hfit.of_le (by omega)) - have h₂ : (rearLayout s C).Valid w C := Stack.Memory.valid_allocLayout (hfit.of_le (by omega)) - -- Each stack is empty once allocated, the second one from the state after the first. - obtain ⟨hi₁, ha₁⟩ := Stack.Memory.inv_allocLayout (C := C) s - obtain ⟨hi₂, ha₂⟩ := Stack.Memory.inv_allocLayout (C := C) - ⟨clear s.mem s.frontier 1, s.frontier + 1 + C⟩ - -- The second allocation is fresh, so the stacks form a product. - obtain ⟨hinv, habs⟩ := Memory.Framed.prod_of_fresh (M₁ := Stack.Memory.framed h₁) - (M₂ := Stack.Memory.framed h₂) hi₁ - (fun a ha => clear_of_not_owns (by simp only [Block.Owns] at ha ⊢; omega)) (by simp only; omega) - hi₂ - (fun a ha => by - simp only [Stack.Memory.framed_footprint, Stack.Memory.Layout.footprint, Finset.mem_union, - Block.mem_footprint, Block.Owns] at ha - simp only - omega) - have hempty : (pair h₁ h₂).abs (allocated s C) = ([], []) := habs.trans (Prod.ext ha₁ ha₂) - refine ⟨h₁, h₂, ⟨hinv, ?_⟩, ?_, ha₂⟩ - · change Inv w C (Queue.WordRAM.contents ((pair h₁ h₂).abs (allocated s C))) - rw [hempty] - exact ⟨by simp [Queue.WordRAM.contents], by simp [Queue.WordRAM.contents]⟩ - · change Queue.WordRAM.contents ((pair h₁ h₂).abs (allocated s C)) = [] - rw [hempty] - rfl +def run (w C : ℕ) {β : Type} (p : (Queue.WordRAM.spec w C).Client β) : Prog β := + (allocator w C).run p /-- **Correctness.** From any memory with room for both stacks, an admissible queue client run over two freshly allocated array stacks issues only admissible memory operations and returns the @@ -293,17 +231,9 @@ theorem run_correct {β : Type} (p : (Queue.WordRAM.spec w C).Client β) {s : Me (hfit : Fits w (s.frontier + 2 * (C + 1))) (hv : (Queue.WordRAM.spec w C).ValidHistory [] ((Queue.WordRAM.spec w C).clientHistory [] p)) : (Memory.spec w).ValidHistory s ((Memory.spec w).clientHistory s (run w C p)) ∧ - (Memory.spec w).clientResult s (run w C p) = (Queue.WordRAM.spec w C).clientResult [] p := by - obtain ⟨h₁, h₂, hinv, habs, -⟩ := setup s hfit - obtain ⟨hvE, hres, -, -⟩ := - (memRefinement h₁ h₂).simulates_client p hinv (by rw [habs]; exact hv) - rw [memRefinement_methods] at hvE hres - simp only [StateTransitionSpec.clientHistory, StateTransitionSpec.clientResult, - runClient_run] at hvE hres ⊢ - simp only [StateTransitionSpec.validHistory_cons, StateTransitionSpec.stepFn, step_alloc, - step_allocDirty, valid_alloc, valid_allocDirty] - refine ⟨⟨hfit.of_le (by omega), hfit.of_le (by omega), hfit.of_le (by omega), - hfit.of_le (by omega), hvE⟩, hres.trans (by rw [habs])⟩ + (Memory.spec w).clientResult s (run w C p) = (Queue.WordRAM.spec w C).clientResult [] p := + have ⟨hvE, hres, _⟩ := (allocator w C).run_correct p (pre_allocator s) (room_allocator ▸ hfit) hv + ⟨hvE, hres⟩ /-- **Cost.** The same run costs at most `6 + 9 m` memory units for a client of `m` queue operations: six for the two allocations and nine per operation, amortized. -/ @@ -311,15 +241,8 @@ theorem run_cost {β : Type} (p : (Queue.WordRAM.spec w C).Client β) {s : Memor (hfit : Fits w (s.frontier + 2 * (C + 1))) (hv : (Queue.WordRAM.spec w C).ValidHistory [] ((Queue.WordRAM.spec w C).clientHistory [] p)) : (Memory.spec w).totalCost charge s ((Memory.spec w).clientHistory s (run w C p)) ≤ - 6 + 9 * ((Queue.WordRAM.spec w C).clientHistory [] p).length := by - obtain ⟨h₁, h₂, hinv, habs, hrear⟩ := setup s hfit - have h := (mem_amortized h₁ h₂).client p hinv (by rw [habs]; exact hv) - rw [memRefinement_methods, habs, StateTransitionSpec.totalCost_const, hrear] at h - simp only [StateTransitionSpec.clientHistory, runClient_run, - StateTransitionSpec.totalCost_cons, charge_alloc, charge_allocDirty, - StateTransitionSpec.stepFn, step_alloc, step_allocDirty] at h ⊢ - simp only [List.length_nil, Nat.mul_zero, Nat.add_zero, allocated] at h ⊢ - omega + 6 + 9 * ((Queue.WordRAM.spec w C).clientHistory [] p).length := + Allocator.run_cost_le amortized_allocator p (pre_allocator s) (room_allocator ▸ hfit) hv /-- **Cost with glue.** A realization also charges the glue that runs after each memory operation. If that glue costs at most `K` times the operation's charge plus `K`, the run costs at most @@ -345,6 +268,6 @@ theorem run_cost_isBigO (s : Memory.State) (hfit : Fits w (s.frontier + 2 * (C + ((Queue.WordRAM.spec w C).clientHistory [] p.1).length) (fun p => (Memory.spec w).totalCost charge s ((Memory.spec w).clientHistory s (run w C p.1))) := - CostIsBigO.of_le_add_mul 6 9 fun p => run_cost p.1 hfit p.2 + Allocator.run_cost_isBigO amortized_allocator (pre_allocator s) (room_allocator ▸ hfit) end Cslib.DataStructure.Queue.Memory diff --git a/Complexity/DataStructure/Stack/Memory.lean b/Complexity/DataStructure/Stack/Memory.lean index 5fb09e09e6..4db5ea5025 100644 --- a/Complexity/DataStructure/Stack/Memory.lean +++ b/Complexity/DataStructure/Stack/Memory.lean @@ -8,7 +8,7 @@ module -- upstream: candidate public import Complexity.DataStructure.Memory.Field -public import Complexity.DataStructure.Memory.Frame +public import Complexity.DataStructure.Memory.Alloc public import Complexity.DataStructure.Stack.WordRAM.Basic /-! @@ -25,7 +25,8 @@ Every operation costs at most three memory units, with no potential (`amortized` write only the layout's cells and never allocate (`modifies_methods`), and the abstraction and invariant depend only on those cells (`abs_congr`, `Inv.congr`). So the stack is framed by its layout (`framed`), and stacks with disjoint layouts share one memory through the generic product -`Memory.Framed.prod`. +`Memory.Framed.prod`. `allocator` packages the allocation of an empty stack (`allocLayout`) with +the framed stack it sets up, so that clients allocate stacks through `Memory.Allocator`. This is the same specification that `Stack.WordRAM` implements by a hand-stepped nine-register dispatcher. Here no register or instruction count appears. Word fit enters only through the @@ -40,6 +41,7 @@ admissibility of `Memory.spec w` and one static fact of the layout, that the cap * `refinement`: the array stack as a `Refinement` of the bounded stack. * `framed`: the same refinement, framed by the layout's cells. * `allocLayout`: allocate an empty stack. +* `allocator`: allocation and the framed stack, as a `Memory.Allocator`. ## Main results @@ -47,8 +49,9 @@ admissibility of `Memory.spec w` and one static fact of the layout, that the cap * `runClient_push`, `runClient_pop_of_eq_zero`, `runClient_pop_of_pos`, `runClient_size`: the operations evaluate definitionally. * `modifies_methods`, `abs_congr`, `Inv.congr`, `Inv.lt_frontier`: the frame of a stack. -* `runClient_allocLayout_bind`, `valid_allocLayout`, `inv_allocLayout`: allocation yields a - well-formed empty stack in three memory units. +* `runClient_allocLayout_bind`, `runClient_allocLayout`, `valid_allocLayout`, + `inv_allocLayout`: allocation yields a well-formed empty stack in three memory units. +* `amortized_allocator`: the allocator's cost certificate, three units per operation. ## References @@ -318,6 +321,7 @@ def framed (hL : L.Valid w C) : Memory.Framed (Stack.WordRAM.spec w C) w := .ofStatic (refinement hL) L.footprint (fun hs ha => Inv.lt_frontier hs ha) (fun hs h hf => ⟨hs.congr hL h hf, abs_congr hL hs h⟩) (fun o _ hv b _ hb => (modifies_methods hL o hv).1 b hb) + (fun o _ hv => (modifies_methods hL o hv).2) /-- Every operation costs at most three memory units, so the stack needs no potential. -/ theorem amortized (hL : L.Valid w C) : @@ -385,4 +389,51 @@ theorem inv_allocLayout (s : Memory.State) : exact Nat.zero_le C · simp [abs, h0] +/-- Allocation returns the layout at the frontier, clears the count cell, and advances the +frontier past the items. -/ +theorem runClient_allocLayout (C : ℕ) (s : Memory.State) : + (Memory.spec w).runClient s (allocLayout C) = + (⟨⟨s.frontier, 1⟩, ⟨s.frontier + 1, C⟩⟩, ⟨clear s.mem s.frontier 1, s.frontier + 1 + C⟩, + [.alloc 1, .allocDirty C]) := rfl + +/-- **The array stack as an allocator**: allocate an empty stack of capacity `C` in `C + 1` +cells, at a memory cost of three units. -/ +def allocator (w C : ℕ) : Allocator (Stack.WordRAM.spec w C) w where + Handle := Layout + alloc := allocLayout C + methods L := methods L w C + init := [] + room := C + 1 + cost := 3 + framed s _ hroom := framed (valid_allocLayout (f := s.frontier) (hroom.of_le (by omega))) + allocates s _ hroom := by + obtain ⟨hinv, habs⟩ := inv_allocLayout (C := C) s + refine + { validHistory := ?_, cost_le := ?_, mem_eq := ?_, methods_eq := rfl, inv := ?_, + abs_eq := ?_, of_mem_footprint := ?_, room_le := ?_ } <;> + simp only [StateTransitionSpec.clientHistory, StateTransitionSpec.clientState, + runClient_allocLayout] + · simp only [StateTransitionSpec.validHistory_cons, StateTransitionSpec.stepFn, step_alloc, + valid_alloc, valid_allocDirty] + exact ⟨hroom.of_le (by omega), hroom.of_le (by omega), trivial⟩ + · simp + · exact fun a ha => clear_of_not_owns (by simp only [Block.Owns]; omega) + · exact hinv + · exact habs + · intro a ha + simp only [framed_footprint, Layout.footprint, Finset.mem_union, Block.mem_footprint, + Block.Owns] at ha + right + omega + · simp only [framed, Memory.Framed.ofStatic] + omega + +/-- The allocated stack is empty. -/ +@[simp] theorem init_allocator (w C : ℕ) : (allocator w C).init = [] := rfl + +/-- Every stack operation costs at most three memory units, and allocation leaves no +potential. -/ +theorem amortized_allocator : (allocator w C).Amortized (fun _ _ => 3) 0 := + fun _ _ _ => ⟨fun _ => 0, amortized _, Memory.Framed.Local.const _ 0, le_rfl⟩ + end Cslib.DataStructure.Stack.Memory diff --git a/Complexity/DataStructure/StateTransition.lean b/Complexity/DataStructure/StateTransition.lean index 623ad75564..032f4dac9f 100644 --- a/Complexity/DataStructure/StateTransition.lean +++ b/Complexity/DataStructure/StateTransition.lean @@ -71,8 +71,10 @@ The relational semantics is **demonic** for callers and **angelic** for implemen under `[StateTransitionSpec.HasStepFn]`. * `StateTransitionSpec.fst_run_eq_toFLTS_mtr`, `StateTransitionSpec.run_append`, `StateTransitionSpec.validHistory_append`, `StateTransitionSpec.totalCost_append`, - `StateTransitionSpec.run_runClient`, `StateTransitionSpec.runClient_bind`, `eval_bind`, - `eval_eq_liftM`: functional history and client laws under `[StateTransitionSpec.HasStepFn]`. + `StateTransitionSpec.run_runClient`, `StateTransitionSpec.runClient_bind`, + `StateTransitionSpec.clientResult_bind`, `StateTransitionSpec.clientState_bind`, + `StateTransitionSpec.clientHistory_bind`, `eval_bind`, `eval_eq_liftM`: functional history and + client laws under `[StateTransitionSpec.HasStepFn]`. ## References @@ -870,6 +872,26 @@ theorem runClient_bind (p : D.Client α) (k : α → D.Client β) (s : D.State) exact congrArg (fun r : β × D.State × List D.Op => (r.1, r.2.1, o :: r.2.2)) (ih (D.stepFn s o).2 (D.stepFn s o).1) +/-- A sequential client answers as its continuation, run from where the first client stopped. -/ +theorem clientResult_bind (p : D.Client α) (k : α → D.Client β) (s : D.State) : + D.clientResult s (p >>= k) = D.clientResult (D.clientState s p) (k (D.clientResult s p)) := by + change D.clientResult s (p.bind k) = _ + rw [clientResult, runClient_bind] + +/-- A sequential client stops where its continuation, run from where the first client stopped, +stops. -/ +theorem clientState_bind (p : D.Client α) (k : α → D.Client β) (s : D.State) : + D.clientState s (p >>= k) = D.clientState (D.clientState s p) (k (D.clientResult s p)) := by + change D.clientState s (p.bind k) = _ + rw [clientState, runClient_bind] + +/-- The history of a sequential client is the first client's history, then its continuation's. -/ +theorem clientHistory_bind (p : D.Client α) (k : α → D.Client β) (s : D.State) : + D.clientHistory s (p >>= k) = + D.clientHistory s p ++ D.clientHistory (D.clientState s p) (k (D.clientResult s p)) := by + change D.clientHistory s (p.bind k) = _ + rw [clientHistory, runClient_bind] + /-- On a deterministic specification (`[D.HasStepFn f]`), demonic operation-sequence admissibility `ValidOpSeq` coincides with `D.ValidHistory`. -/ @[simp] diff --git a/Complexity/Foundations/Analysis/ENNRealFraction.lean b/Complexity/Foundations/Analysis/ENNRealFraction.lean new file mode 100644 index 0000000000..2bbc1e3cc7 --- /dev/null +++ b/Complexity/Foundations/Analysis/ENNRealFraction.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +-- upstream: candidate + +public import Complexity.Init +public import Mathlib.Basic.ENNReal.Inv + +/-! +# Dyadic fractions in `ℝ≥0∞` + +A count `c` out of `2 ^ n` equally likely strings is a probability `c / 2 ^ n`. Bounded-error +acceptance thresholds compare it with `2 / 3`; this file turns that comparison into one between +natural numbers. + +## Main results + +* `ENNReal.two_div_three_le_natCast_div_two_pow_iff`: `2 / 3 ≤ c / 2 ^ n ↔ 2 * 2 ^ n ≤ 3 * c`. +-/ + +@[expose] public section + +open scoped ENNReal + +namespace ENNReal + +/-- A dyadic fraction `c / 2 ^ n` is at least two thirds exactly when `2 * 2 ^ n ≤ 3 * c`. -/ +theorem two_div_three_le_natCast_div_two_pow_iff {c n : ℕ} : + (2 / 3 : ℝ≥0∞) ≤ c / 2 ^ n ↔ 2 * 2 ^ n ≤ 3 * c := by + rw [ENNReal.le_div_iff_mul_le (Or.inl (pow_ne_zero _ two_ne_zero)) + (Or.inl (ENNReal.pow_ne_top ENNReal.ofNat_ne_top)), div_eq_mul_inv, mul_right_comm, + ← div_eq_mul_inv, ENNReal.div_le_iff (by norm_num) (by norm_num)] + constructor + · intro h + have : ((2 * 2 ^ n : ℕ) : ℝ≥0∞) ≤ ((3 * c : ℕ) : ℝ≥0∞) := by + push_cast + rw [mul_comm (3 : ℝ≥0∞)] + exact h + exact_mod_cast this + · intro h + have : ((2 * 2 ^ n : ℕ) : ℝ≥0∞) ≤ ((3 * c : ℕ) : ℝ≥0∞) := by exact_mod_cast h + push_cast at this + rw [mul_comm (c : ℝ≥0∞)] + exact this + +end ENNReal diff --git a/ComplexityTests/DataStructureMemoryAlloc.lean b/ComplexityTests/DataStructureMemoryAlloc.lean new file mode 100644 index 0000000000..292ff6f507 --- /dev/null +++ b/ComplexityTests/DataStructureMemoryAlloc.lean @@ -0,0 +1,592 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +-- upstream: local-only (test driver) + +public import Complexity.DataStructure.Stack.Memory + +/-! +# Allocation inside operations, and structures already in memory + +Two checks of the allocator contract of `Memory.Allocator`, at word size `8`. + +**Room consumed inside operations.** A write-once cell reserves one cell of room when it is +allocated, and allocates that cell inside its first `set`. Its header is taken without clearing, +so its allocator needs the memory beyond the frontier to be zero, which the other cell's +allocation keeps. Two such cells share one memory as `cells`, the product of their allocators. +A client sets them alternately, so each `set` allocates above the other structure's newest cell. +The tests check: + +* the answers and the admissibility of the whole run, by the generic `Allocator.run_correct`; +* the allocations inside the operations, in the run's memory history; +* after each step, the footprints, the abstractions and the frontier plus the remaining room, + which stays at the frontier the allocation reserved up to; +* the boundary: from frontier `251`, where `251 + 4` fits a byte, the run is admissible. From + `252` it is not, and only the right `set` fails: its allocation, of the last of the four + reserved cells, would leave the frontier at `256`; +* that the precondition is needed: over a nonzero cell, an unset cell reads as set. + +**Structures already in memory.** A stack that the input holds is taken over by +`Allocator.resident`, in the shape of Dijkstra's algorithm: two stacks are allocated from +scratch above the input, and the input's stack is used in place. The generic theorems give the +run's answer and cost. Two stacks that the input holds in disjoint cells combine too. Taking +over the same cells twice is excluded by the product's precondition. +-/ + +@[expose] public section + +namespace ComplexityTests.DataStructureMemoryAlloc + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.Memory + +/-! ## A write-once cell that allocates on its first `set` -/ + +/-- The operations of a write-once cell: set it once, and get its value. -/ +inductive CellOp where + /-- Set the cell to a value. -/ + | set (v : ℕ) + /-- Get the value, if set. -/ + | get + deriving DecidableEq + +/-- Setting answers nothing; getting answers the value, if set. -/ +abbrev CellOp.Result : CellOp → Type + | .set _ => Unit + | .get => Option ℕ + +/-- Setting stores the value, and getting returns it. -/ +def cellStep (c : Option ℕ) : (o : CellOp) → Option ℕ × o.Result + | .set v => (some v, ()) + | .get => (c, c) + +/-- A cell is set once, to a word. -/ +def cellValid (w : ℕ) (c : Option ℕ) : CellOp → Prop + | .set v => c = none ∧ Fits w v + | .get => True + +instance (w : ℕ) (c : Option ℕ) (o : CellOp) : Decidable (cellValid w c o) := by + cases o <;> unfold cellValid <;> infer_instance + +/-- The write-once cell at word size `w`. -/ +abbrev Cell (w : ℕ) : StateTransitionSpec := + StateTransitionSpec.ofFn (State := Option ℕ) (Op := CellOp) (Result := CellOp.Result) cellStep + (cellValid w) + +/-- Admissibility of a concrete history of cell operations is decidable. -/ +instance (w : ℕ) (c : Option ℕ) (os : List CellOp) : Decidable ((Cell w).ValidHistory c os) := by + induction os generalizing c with + | nil => exact isTrue trivial + | cons o os ih => + exact decidable_of_iff (cellValid w c o ∧ (Cell w).ValidHistory (cellStep c o).1 os) Iff.rfl + +variable (h w : ℕ) + +/-- Set: allocate the value cell, write the value there, and point the header `h` at it. -/ +def cellSet (v : ℕ) : Prog Unit := do + let p ← allocDirty 1 + write p v + write h p + +/-- Get: a zero header means unset; otherwise read the cell that it points to. -/ +def cellGet : Prog (Option ℕ) := do + let p ← read h + if p = 0 then pure none else do + let v ← read p + pure (some v) + +/-- The cell's operations as memory programs, with header `h`. -/ +def cellMethods : Methods (Cell w) (spec w) + | .set v => cellSet h v + | .get => cellGet h + +/-- The value cell, if the header points to one. -/ +def cellAbs (s : State) : Option ℕ := if s.mem h = 0 then none else some (s.mem (s.mem h)) + +/-- The header, and the value cell once set. -/ +def cellFootprint (s : State) : Finset ℕ := if s.mem h = 0 then {h} else {h, s.mem h} + +/-- One cell of room until the cell is set. -/ +def cellRoom (s : State) : ℕ := if s.mem h = 0 then 1 else 0 + +/-- The header and the value cell are allocated, and the frontier plus the room fits a word, so +that the first `set` may allocate. -/ +structure CellInv (s : State) : Prop where + /-- The header is allocated. -/ + header_lt : h < s.frontier + /-- The value cell is allocated. -/ + value_lt : s.mem h ≠ 0 → s.mem h < s.frontier + /-- The reserved cell fits. -/ + fits_room : Fits w (s.frontier + cellRoom h s) + +/-- A set allocates one cell at the frontier, writes the value there and points the header at +it. -/ +theorem runClient_cellSet (s : State) (v : ℕ) : + (spec w).runClient s (cellSet h v) = + ((), ⟨Function.update (Function.update s.mem s.frontier v) h s.frontier, s.frontier + 1⟩, + [.allocDirty 1, .write s.frontier v, .write h s.frontier]) := rfl + +/-- A get of an unset cell reads the header. -/ +theorem runClient_cellGet_of_eq_zero (s : State) (h0 : s.mem h = 0) : + (spec w).runClient s (cellGet h) = (none, s, [.read h]) := by + simp [cellGet, h0] + +/-- A get of a set cell reads the header and the value cell. -/ +theorem runClient_cellGet_of_ne_zero (s : State) (h0 : s.mem h ≠ 0) : + (spec w).runClient s (cellGet h) = (some (s.mem (s.mem h)), s, [.read h, .read (s.mem h)]) := by + unfold cellGet + simp only [StateTransitionSpec.runClient_lift_bind', StateTransitionSpec.stepFn, step_read, h0, + ↓reduceIte] + rfl + +/-- Allocating a header takes one cell at the frontier, without clearing it. -/ +theorem runClient_allocDirty_one (s : State) : + (spec w).runClient s (allocDirty 1) = (s.frontier, ⟨s.mem, s.frontier + 1⟩, [.allocDirty 1]) := + rfl + +variable {h w} + +/-- A cell is unset exactly when its header is zero. -/ +theorem cellAbs_eq_none {s : State} : cellAbs h s = none ↔ s.mem h = 0 := by + unfold cellAbs + split <;> simp_all + +variable (h w) + +/-- The write-once cell with header `h` implements its specification. -/ +def cellRefinement : Refinement (Cell w) (spec w) := + Refinement.ofFn (cellMethods h w) (CellInv h w) (cellAbs h) + (by + intro s o hs hv + have hh := CellInv.header_lt hs + cases o with + | set v => + obtain ⟨hnone, hfit⟩ := hv + have h0 := cellAbs_eq_none.mp hnone + have hr := CellInv.fits_room hs + simp only [cellRoom, h0, ↓reduceIte] at hr + simp only [cellMethods, StateTransitionSpec.clientHistory, runClient_cellSet, + StateTransitionSpec.validHistory_cons, StateTransitionSpec.stepFn, step_allocDirty, + step_write, valid_allocDirty, valid_write] + exact ⟨hr, ⟨Nat.lt_add_one _, hfit⟩, ⟨by omega, hr.of_le (by omega)⟩, trivial⟩ + | get => + by_cases h0 : s.mem h = 0 + · simp only [cellMethods, StateTransitionSpec.clientHistory, + runClient_cellGet_of_eq_zero h w s h0] + exact ⟨hh, trivial⟩ + · simp only [cellMethods, StateTransitionSpec.clientHistory, + runClient_cellGet_of_ne_zero h w s h0] + exact ⟨hh, CellInv.value_lt hs h0, trivial⟩) + (by + intro s o hs hv + have hh := CellInv.header_lt hs + cases o with + | set v => + obtain ⟨hnone, -⟩ := hv + have h0 := cellAbs_eq_none.mp hnone + have hr := CellInv.fits_room hs + simp only [cellRoom, h0, ↓reduceIte] at hr + have hne : s.frontier ≠ h := by omega + have hf0 : s.frontier ≠ 0 := by omega + simp only [cellMethods, StateTransitionSpec.clientState, StateTransitionSpec.clientResult, + runClient_cellSet] + refine ⟨?_, ⟨by simp only; omega, fun _ => ?_, ?_⟩⟩ + · simp [cellAbs, cellStep, hne, hf0] + · simp only [Function.update_self] + omega + · simpa [cellRoom, hf0] using hr + | get => + by_cases h0 : s.mem h = 0 + · simp only [cellMethods, StateTransitionSpec.clientState, + StateTransitionSpec.clientResult, runClient_cellGet_of_eq_zero h w s h0] + exact ⟨by simp [cellAbs, h0, cellStep], hs⟩ + · simp only [cellMethods, StateTransitionSpec.clientState, + StateTransitionSpec.clientResult, runClient_cellGet_of_ne_zero h w s h0] + exact ⟨by simp [cellAbs, h0, cellStep], hs⟩) + +/-- The refinement runs the cell's methods. -/ +@[simp] theorem cellRefinement_methods : (cellRefinement h w).methods = cellMethods h w := rfl + +/-- The refinement's abstraction. -/ +@[simp] theorem cellRefinement_abs : (cellRefinement h w).abs = cellAbs h := rfl + +/-- The refinement's invariant. -/ +@[simp] theorem cellRefinement_inv : (cellRefinement h w).inv = CellInv h w := rfl + +/-- The header belongs to the footprint. -/ +theorem header_mem_cellFootprint (s : State) : h ∈ cellFootprint h s := by + unfold cellFootprint + split <;> simp + +/-- **The write-once cell, framed with room.** Its footprint grows into the cell that its first +`set` allocates, and that `set` gives up the one cell of room it advances the frontier by. -/ +def cellFramed : Framed (Cell w) w where + toRefinement := cellRefinement h w + footprint := cellFootprint h + room := cellRoom h + lt_frontier {s a} hs ha := by + have hh := CellInv.header_lt hs + unfold cellFootprint at ha + split at ha + · rw [Finset.mem_singleton] at ha + omega + · rcases Finset.mem_insert.mp ha with ha | ha + · omega + · rw [Finset.mem_singleton] at ha + rw [ha] + exact CellInv.value_lt hs (by assumption) + congr {s s'} hs hmem hf hr := by + have hh : s'.mem h = s.mem h := hmem h (header_mem_cellFootprint h s) + have hroom : cellRoom h s' = cellRoom h s := by simp only [cellRoom, hh] + have hfp : cellFootprint h s' = cellFootprint h s := by simp only [cellFootprint, hh] + refine ⟨⟨(CellInv.header_lt hs).trans_le hf, fun h0 => ?_, hroom ▸ hr⟩, ?_, hfp, hroom⟩ + · rw [hh] at h0 ⊢ + exact (CellInv.value_lt hs h0).trans_le hf + · change cellAbs h s' = cellAbs h s + unfold cellAbs + by_cases h0 : s.mem h = 0 + · simp [hh, h0] + · have hv : s'.mem (s.mem h) = s.mem (s.mem h) := hmem _ (by simp [cellFootprint, h0]) + simp [hh, h0, hv] + modifies {s} o {a s' tr} hs hv hrun := by + obtain ⟨_, _, rfl, _⟩ := ((spec w).clientRun_iff_runClient _ _ _ _ _).mp hrun + simp only [cellRefinement_inv, cellRefinement_abs] at hs hv + have hh := CellInv.header_lt hs + cases o with + | set v => + obtain ⟨hnone, -⟩ := hv + have h0 := cellAbs_eq_none.mp hnone + have hne : s.frontier ≠ h := by omega + simp only [cellRefinement_methods, cellMethods, StateTransitionSpec.clientState, + runClient_cellSet] + refine ⟨fun b hb hb' => ?_, fun b hb => ?_, ?_⟩ + · have hbh : b ≠ h := fun e => hb' (e ▸ header_mem_cellFootprint h s) + change Function.update (Function.update s.mem s.frontier v) h s.frontier b = s.mem b + rw [Function.update_of_ne hbh, Function.update_of_ne (by omega)] + · have hf0 : s.frontier ≠ 0 := by omega + simp only [cellFootprint, Function.update_self, hf0, ↓reduceIte, Finset.mem_insert, + Finset.mem_singleton] at hb + rcases hb with hb | hb + · exact .inl (hb ▸ header_mem_cellFootprint h s) + · exact .inr hb.ge + · have hf0 : s.frontier ≠ 0 := by omega + simp [cellRoom, h0, hf0] + | get => + by_cases h0 : s.mem h = 0 + · simp only [cellRefinement_methods, cellMethods, StateTransitionSpec.clientState, + runClient_cellGet_of_eq_zero h w s h0] + exact ⟨fun _ _ _ => trivial, fun _ hb => .inl hb, le_rfl⟩ + · simp only [cellRefinement_methods, cellMethods, StateTransitionSpec.clientState, + runClient_cellGet_of_ne_zero h w s h0] + exact ⟨fun _ _ _ => trivial, fun _ hb => .inl hb, le_rfl⟩ + +/-- A set costs three memory units, a get at most two, with no potential. -/ +theorem cellAmortized : (cellFramed h w).Amortized charge (fun _ _ => 3) fun _ => 0 := by + apply Refinement.Amortized.ofFn + intro s o _ _ + change (spec w).totalCost charge s ((spec w).clientHistory s (cellMethods h w o)) + 0 ≤ 3 + 0 + cases o with + | set v => simp [cellMethods, StateTransitionSpec.clientHistory, runClient_cellSet] + | get => + by_cases h0 : s.mem h = 0 + · simp [cellMethods, StateTransitionSpec.clientHistory, runClient_cellGet_of_eq_zero h w s h0] + · simp [cellMethods, StateTransitionSpec.clientHistory, runClient_cellGet_of_ne_zero h w s h0] + +/-- **The write-once cell as an allocator**: take a header at the frontier without clearing it, +since the memory beyond the frontier is zero, and reserve one more cell for the first `set`. +Another structure's allocation keeps the memory beyond the new frontier zero. -/ +def cellAllocator : Allocator (Cell w) w where + Handle := ℕ + alloc := allocDirty 1 + methods h := cellMethods h w + init := none + room := 2 + cost := 1 + Pre s := ∀ a, s.frontier ≤ a → s.mem a = 0 + pre_fresh hs _ habove hf _ a ha := (habove a ha).trans (hs a (hf.trans ha)) + framed s _ _ := cellFramed s.frontier w + allocates s hs hroom := by + have h0 : s.mem s.frontier = 0 := hs _ le_rfl + refine + { validHistory := ?_, cost_le := ?_, mem_eq := ?_, methods_eq := rfl, inv := ?_, + abs_eq := ?_, of_mem_footprint := ?_, room_le := ?_ } <;> + simp only [StateTransitionSpec.clientHistory, StateTransitionSpec.clientState, + runClient_allocDirty_one] + · exact ⟨hroom.of_le (by omega), trivial⟩ + · simp + · exact fun _ _ => trivial + · refine ⟨Nat.lt_add_one _, fun h => absurd h0 h, ?_⟩ + change Fits w (s.frontier + 1 + cellRoom s.frontier ⟨s.mem, _⟩) + simp only [cellRoom, h0, ↓reduceIte] + exact hroom.of_le (by omega) + · change cellAbs s.frontier ⟨s.mem, _⟩ = none + simp [cellAbs, h0] + · intro a ha + change a ∈ cellFootprint s.frontier ⟨s.mem, _⟩ at ha + simp only [cellFootprint, h0, ↓reduceIte, Finset.mem_singleton] at ha + exact .inr ha.ge + · change s.frontier + 1 + cellRoom s.frontier ⟨s.mem, _⟩ ≤ _ + simp only [cellRoom, h0, ↓reduceIte] + omega + +/-- Each cell costs three memory units per operation, and allocation leaves no potential. -/ +theorem cellAllocator_amortized : (cellAllocator w).Amortized (fun _ _ => 3) 0 := + fun s _ _ => ⟨fun _ => 0, cellAmortized s.frontier w, Framed.Local.const _ 0, le_rfl⟩ + +/-! ## Two cells that allocate inside their operations -/ + +/-- Two write-once cells in one memory, each with one cell of room for its `set`. -/ +abbrev cells : Allocator (product (Cell 8) (Cell 8)) 8 := (cellAllocator 8).prod (cellAllocator 8) + +/-- The two cells reserve four cells: two headers and two value cells. -/ +example : cells.room = 4 := rfl + +/-- Set the left cell. -/ +def setLeft : (product (Cell 8) (Cell 8)).Client Unit := + (product (Cell 8) (Cell 8)).call (.inl (.set 5)) + +/-- Set the left cell, then the right one. -/ +def setBoth : (product (Cell 8) (Cell 8)).Client Unit := do + let _ ← (product (Cell 8) (Cell 8)).call (.inl (.set 5)) + let _ ← (product (Cell 8) (Cell 8)).call (.inr (.set 7)) + pure () + +/-- Set both cells, then get both. -/ +def client : (product (Cell 8) (Cell 8)).Client (Option ℕ × Option ℕ) := do + setBoth + let a ← (product (Cell 8) (Cell 8)).call (.inl .get) + let b ← (product (Cell 8) (Cell 8)).call (.inr .get) + pure (a, b) + +/-- Memory with nothing allocated. -/ +def nothing : State := ⟨fun _ => 0, 0⟩ + +/-- Besides room, the two cells need the memory beyond the frontier to be zero, as the input +convention leaves it. The second cell's need survives the first cell's allocation. -/ +theorem pre {s : State} (hs : ∀ a, s.frontier ≤ a → s.mem a = 0) : cells.Pre s := + ⟨hs, hs, Finset.disjoint_empty_left _⟩ + +/-- The four reserved cells fit a byte. -/ +theorem fits : Fits 8 (nothing.frontier + cells.room) := by decide + +/-- The two cells, as set up by the allocation from `nothing`. -/ +abbrev framed : Framed (product (Cell 8) (Cell 8)) 8 := + cells.framed nothing (pre fun _ _ => rfl) fits + +/-- The client is admissible: each cell is set once, to a byte. -/ +theorem client_valid : (product (Cell 8) (Cell 8)).ValidHistory cells.init + ((product (Cell 8) (Cell 8)).clientHistory cells.init client) := + ⟨⟨rfl, by decide⟩, ⟨rfl, by decide⟩, trivial, trivial, trivial⟩ + +/-- **The run is admissible and answers as the specification does**, by the generic theorem: no +proof about this client or this product. -/ +theorem run_correct : + (spec 8).ValidHistory nothing ((spec 8).clientHistory nothing (cells.run client)) ∧ + (spec 8).clientResult nothing (cells.run client) = (some 5, some 7) ∧ + framed.abs ((spec 8).clientState nothing (cells.run client)) = (some 5, some 7) := by + obtain ⟨hv, hres, -, habs⟩ := cells.run_correct client (pre fun _ _ => rfl) fits client_valid + exact ⟨hv, hres, habs⟩ + +/-- The same answer, by evaluation. -/ +example : (spec 8).clientResult nothing (cells.run client) = (some 5, some 7) := by decide + +/-- **Each `set` allocates inside the operation**: the headers at `0` and `1`, then the left +value cell at `2` and the right one at `3`, above the other structure's newest cell. -/ +example : (spec 8).clientHistory nothing (cells.run client) = + [.allocDirty 1, .allocDirty 1, .allocDirty 1, .write 2 5, .write 0 2, .allocDirty 1, + .write 3 7, .write 1 3, .read 0, .read 2, .read 1, .read 3] := by + decide + +/-- After allocation: both headers, both cells unset, and two cells of room up to frontier +`4`. -/ +example : let s := (spec 8).clientState nothing (cells.run (pure ())) + framed.footprint s = {0, 1} ∧ framed.abs s = (none, none) ∧ s.frontier = 2 ∧ + framed.room s = 2 := by + decide + +/-- After the left `set`: the left cell has taken its reserved cell `2`, and the right cell keeps +its value, its footprint and its reservation. The frontier plus the room is still `4`. -/ +example : let s := (spec 8).clientState nothing (cells.run setLeft) + framed.footprint s = {0, 2, 1} ∧ framed.abs s = (some 5, none) ∧ s.frontier = 3 ∧ + framed.room s = 1 := by + decide + +/-- After both `set`s: all four reserved cells are used and no room is left. -/ +example : let s := (spec 8).clientState nothing (cells.run setBoth) + framed.footprint s = {0, 2, 1, 3} ∧ framed.abs s = (some 5, some 7) ∧ s.frontier = 4 ∧ + framed.room s = 0 := by + decide + +/-- It costs one unit per header, three per `set` and two per `get`. -/ +example : (spec 8).totalCost charge nothing ((spec 8).clientHistory nothing (cells.run client)) = + 12 := by + decide + +/-- The generic cost theorem: two units to allocate, and three per operation. -/ +example : (spec 8).totalCost charge nothing ((spec 8).clientHistory nothing (cells.run client)) ≤ + 2 + 0 + 3 * 4 := by + have h := Allocator.Amortized.prod (cellAllocator_amortized (w := 8)) + (cellAllocator_amortized (w := 8)) + simp only [productCharge_const] at h + exact Allocator.run_cost_le h client (pre fun _ _ => rfl) fits client_valid + +/-- Get the left cell. -/ +def getLeft : (product (Cell 8) (Cell 8)).Client (Option ℕ) := + (product (Cell 8) (Cell 8)).call (.inl .get) + +/-- A memory with a nonzero cell beyond the frontier, where the left header will be taken. -/ +def dirty : State := ⟨fun a => if a = 0 then 9 else 0, 0⟩ + +/-- **The precondition is needed**: from `dirty` it fails, and the left cell, never set, reads as +set, since its header was taken without clearing. -/ +example : ¬cells.Pre dirty ∧ (spec 8).clientResult dirty (cells.run getLeft) = some 0 := by + refine ⟨fun hs => absurd (Allocator.ProdPre.left hs 0 le_rfl) (by decide), by decide⟩ + +/-! ### The boundary of the reservation -/ + +/-- The highest frontier with room for both cells at word size `8`: `251 + 4 = 255`. -/ +def high : State := ⟨fun _ => 0, 251⟩ + +/-- One cell higher: `252 + 4 = 256` does not fit a byte. -/ +def tooHigh : State := ⟨fun _ => 0, 252⟩ + +example : Fits 8 (high.frontier + cells.room) ∧ ¬Fits 8 (tooHigh.frontier + cells.room) := by + decide + +/-- From the highest frontier with room, the generic theorem gives an admissible run. -/ +example : (spec 8).ValidHistory high ((spec 8).clientHistory high (cells.run client)) := + (cells.run_correct client (pre fun _ _ => rfl) (by decide) client_valid).1 + +/-- One cell higher, the run is not admissible. -/ +example : ¬(spec 8).ValidHistory tooHigh ((spec 8).clientHistory tooHigh (cells.run client)) := by + decide + +/-- Only the right `set` fails, when it allocates the last of the four reserved cells: the +allocations and the left `set` are admissible. -/ +example : (spec 8).ValidHistory tooHigh ((spec 8).clientHistory tooHigh (cells.run setLeft)) ∧ + ¬(spec 8).ValidHistory tooHigh ((spec 8).clientHistory tooHigh (cells.run setBoth)) := by + decide + +/-! ## Stacks already in memory -/ + +/-- A bounded stack of capacity `2` at word size `8`. -/ +abbrev S : StateTransitionSpec := Stack.WordRAM.spec 8 2 + +/-- The layout of stack `i`: its count cell at `3 i`, its items at `3 i + 1` and `3 i + 2`. -/ +def layout (i : ℕ) : Stack.Memory.Layout := ⟨⟨3 * i, 1⟩, ⟨3 * i + 1, 2⟩⟩ + +/-- The layouts are well formed. -/ +theorem valid (i : ℕ) (hi : i < 3) : (layout i).Valid 8 2 := + Stack.Memory.valid_allocLayout (f := 3 * i) (Fits.of_le (show Fits 8 9 by decide) (by omega)) + +/-- The stack at layout `i`, taken over as it is in memory, holding `xs`. -/ +abbrev inputStack (i : ℕ) (hi : i < 3) (xs : List ℕ) : Allocator S 8 := + Allocator.resident (Stack.Memory.framed (valid i hi)) xs 0 + +/-- The input: stack `0` holds `7` on top of `5`, and stack `1` holds `4`. -/ +def input : State := + ⟨fun a => if a = 0 then 2 else if a = 1 then 5 else if a = 2 then 7 else if a = 3 then 1 + else if a = 4 then 4 else 0, 6⟩ + +/-- Stack `i` holds in the input. -/ +theorem inv_input (i : ℕ) (hi : i < 2) : Stack.Memory.Inv (layout i) input where + count_allocated := by simp only [Block.Allocated, layout, input]; omega + items_allocated := by simp only [Block.Allocated, layout, input]; omega + count_le := by + obtain _ | _ | i := i + · decide + · decide + · omega + +/-- **The Dijkstra shape**: two stacks allocated from scratch above the input, and the input's +stack `0` taken over in place, as Dijkstra's algorithm takes over its input graph. -/ +abbrev dijkstraShape : Allocator (product S (product S S)) 8 := + (Stack.Memory.allocator 8 2).prod ((Stack.Memory.allocator 8 2).prod (inputStack 0 (by decide) + [7, 5])) + +/-- The input holds the stack that the third structure takes over. -/ +theorem pre_dijkstraShape : dijkstraShape.Pre input := + ⟨trivial, ⟨trivial, ⟨inv_input 0 (by decide), by decide, le_rfl⟩, Finset.disjoint_empty_left _⟩, + Finset.disjoint_empty_left _⟩ + +/-- Pop the input's stack, push `1` on the first fresh stack and `2` on the second, then pop +all three. -/ +def dijkstraClient : (product S (product S S)).Client (List (Option ℕ)) := do + let a ← (product S (product S S)).call (.inr (.inr .pop)) + let _ ← (product S (product S S)).call (.inl (.push 1)) + let _ ← (product S (product S S)).call (.inr (.inl (.push 2))) + let b ← (product S (product S S)).call (.inl .pop) + let c ← (product S (product S S)).call (.inr (.inl .pop)) + let d ← (product S (product S S)).call (.inr (.inr .pop)) + pure [a, b, c, d] + +/-- The client is admissible from the allocated states. -/ +theorem dijkstraClient_valid : (product S (product S S)).ValidHistory dijkstraShape.init + ((product S (product S S)).clientHistory dijkstraShape.init dijkstraClient) := + ⟨trivial, ⟨by decide, by decide⟩, ⟨by decide, by decide⟩, trivial, trivial, trivial, trivial⟩ + +/-- **The generic correctness theorem**: the run answers as the specification does from the +input's stack and two empty ones. -/ +example : (spec 8).clientResult input (dijkstraShape.run dijkstraClient) = + [some 7, some 1, some 2, some 5] := by + obtain ⟨-, hres, -⟩ := + dijkstraShape.run_correct dijkstraClient pre_dijkstraShape (by decide) dijkstraClient_valid + rw [hres] + decide + +/-- The same answer, by evaluation. The fresh stacks take the six cells above the input, and +the input's stack is popped in place: its count cell, at address `0`, ends at `0`. -/ +example : (spec 8).clientResult input (dijkstraShape.run dijkstraClient) = + [some 7, some 1, some 2, some 5] ∧ + ((spec 8).clientState input (dijkstraShape.run dijkstraClient)).frontier = 12 ∧ + ((spec 8).clientState input (dijkstraShape.run dijkstraClient)).mem 0 = 0 := by + decide + +/-- The generic cost theorem: six units to allocate the fresh stacks, none for the input's, and +three per operation. -/ +example : (spec 8).totalCost charge input ((spec 8).clientHistory input + (dijkstraShape.run dijkstraClient)) ≤ 6 + 0 + 3 * 6 := by + have hres : (inputStack 0 (by decide) [7, 5]).Amortized (fun _ _ => 3) 0 := + Allocator.Amortized.resident (Stack.Memory.amortized _) (Framed.Local.const _ 0) + fun _ _ _ => le_rfl + have h := Allocator.Amortized.prod (Stack.Memory.amortized_allocator (w := 8) (C := 2)) + (Allocator.Amortized.prod (Stack.Memory.amortized_allocator (w := 8) (C := 2)) hres) + simp only [productCharge_const] at h + exact Allocator.run_cost_le h dijkstraClient pre_dijkstraShape (by decide) dijkstraClient_valid + +/-- Two stacks that the input holds in disjoint cells. -/ +abbrev bothInputs : Allocator (product S S) 8 := + (inputStack 0 (by decide) [7, 5]).prod (inputStack 1 (by decide) [4]) + +/-- Pop both input stacks twice. -/ +def popBoth : (product S S).Client (List (Option ℕ)) := do + let a ← (product S S).call (.inl .pop) + let b ← (product S S).call (.inr .pop) + let c ← (product S S).call (.inl .pop) + let d ← (product S S).call (.inr .pop) + pure [a, b, c, d] + +/-- Both stacks hold in the input, in disjoint cells. -/ +theorem pre_bothInputs : bothInputs.Pre input := + ⟨⟨inv_input 0 (by decide), by decide, le_rfl⟩, ⟨inv_input 1 (by decide), by decide, le_rfl⟩, + by decide⟩ + +/-- The generic correctness theorem for two structures taken over in place. -/ +example : (spec 8).clientResult input (bothInputs.run popBoth) = + [some 7, some 4, some 5, none] := by + obtain ⟨-, hres, -⟩ := bothInputs.run_correct popBoth pre_bothInputs (by decide) + ⟨trivial, trivial, trivial, trivial, trivial⟩ + rw [hres] + decide + +/-- **The same cells cannot be taken over twice**: the product's precondition asks for disjoint +cells, so no memory satisfies it for one stack taken over twice. -/ +example (s : State) : ¬((inputStack 0 (by decide) [7, 5]).prod + (inputStack 0 (by decide) [7, 5])).Pre s := fun hs => by + have hd : Disjoint (layout 0).footprint (layout 0).footprint := Allocator.ProdPre.disjoint hs + exact absurd hd (by decide) + +end ComplexityTests.DataStructureMemoryAlloc diff --git a/ComplexityTests/DataStructureMemoryProduct.lean b/ComplexityTests/DataStructureMemoryProduct.lean index 52d5e75184..2ad73fad46 100644 --- a/ComplexityTests/DataStructureMemoryProduct.lean +++ b/ComplexityTests/DataStructureMemoryProduct.lean @@ -99,15 +99,16 @@ theorem inv_layout (i : ℕ) (hi : i < 3) : Stack.Memory.Inv (layout i) empty wh /-- The three stacks hold in the empty memory, with disjoint footprints. -/ theorem inv_empty : triple.inv empty := - ⟨⟨inv_layout 0 (by decide), inv_layout 1 (by decide), by decide⟩, inv_layout 2 (by decide), - by decide⟩ + ⟨⟨inv_layout 0 (by decide), inv_layout 1 (by decide), by decide, by decide⟩, + inv_layout 2 (by decide), by decide, by decide⟩ /-- The specification's answer, transported to the memory run by the iterated product. -/ example : (spec 8).clientResult empty (link triple.methods client) = (product (product S S) S).clientResult (triple.abs empty) client := - (triple.simulates_client client inv_empty + have ⟨_, hres, _⟩ := triple.simulates_client client inv_empty ⟨⟨by decide, by decide⟩, ⟨by decide, by decide⟩, ⟨by decide, by decide⟩, trivial, trivial, - trivial, trivial, trivial⟩).2.1 + trivial, trivial, trivial⟩ + hres /-- Every operation of the three stacks costs at most three memory units, amortized with zero potential: the stacks' certificates add across both products. -/ @@ -117,11 +118,78 @@ theorem amortized : triple.Amortized charge (fun _ _ => 3) fun _ => 0 := by (Framed.Local.const _ 0) rw [productCharge_const] at h₀₁ have h := Framed.amortized_prod h₀₁ (Stack.Memory.amortized (valid 2 (by decide))) - (fun _ _ _ => rfl) (Framed.Local.const _ 0) + (fun _ _ _ _ => rfl) (Framed.Local.const _ 0) rwa [productCharge_const] at h /-- With zero potential, the same certificate is a worst-case charge bound. -/ example : triple.toModule.ChargeBound charge fun _ _ => 3 := amortized.chargeBound +/-! ## Allocated one after the other + +The same three stacks, allocated by a program rather than laid out by hand, in the shape of a +client of three structures such as Dijkstra's algorithm over `product PQ (product Dict Adj)`. +The generic theorems of `Memory.Allocator` give the run's admissibility, answer and cost, with no +setup proof for this client. -/ + +/-- Three stacks of capacity `2`, allocated one after the other. -/ +abbrev allocated : Allocator (product S (product S S)) 8 := + (Stack.Memory.allocator 8 2).prod + ((Stack.Memory.allocator 8 2).prod (Stack.Memory.allocator 8 2)) + +/-- The client above, on the right-nested product. -/ +def client' : (product S (product S S)).Client (List (Option ℕ) × List ℕ) := do + let _ ← (product S (product S S)).call (.inl (.push 1)) + let _ ← (product S (product S S)).call (.inl (.push 2)) + let _ ← (product S (product S S)).call (.inr (.inr (.push 3))) + let a ← (product S (product S S)).call (.inl .pop) + let b ← (product S (product S S)).call (.inl .pop) + let m ← (product S (product S S)).call (.inr (.inl .size)) + let n ← (product S (product S S)).call (.inr (.inr .size)) + pure ([a, b], [m, n]) + +/-- Memory with nothing allocated. -/ +def nothing : State := ⟨fun _ => 0, 0⟩ + +/-- The allocated run answers as the linked client on hand-placed stacks. -/ +example : (spec 8).clientResult nothing (allocated.run client') = ([some 2, some 1], [0, 1]) := by + decide + +/-- It costs the 17 units of the client and three units per allocated stack. -/ +example : (spec 8).totalCost charge nothing ((spec 8).clientHistory nothing + (allocated.run client')) = 9 + 17 := by + decide + +/-- The three stacks are allocated from scratch, so nothing is needed of the memory besides +room. -/ +theorem pre_allocated (s : State) : allocated.Pre s := + ⟨trivial, ⟨trivial, trivial, Finset.disjoint_empty_left _⟩, Finset.disjoint_empty_left _⟩ + +/-- The client is admissible for the three bounded stacks. -/ +theorem client'_valid : (product S (product S S)).ValidHistory allocated.init + ((product S (product S S)).clientHistory allocated.init client') := + ⟨⟨by decide, by decide⟩, ⟨by decide, by decide⟩, ⟨by decide, by decide⟩, trivial, trivial, + trivial, trivial, trivial⟩ + +/-- The stacks' certificates add across both products of allocators. -/ +theorem amortized_allocated : allocated.Amortized (fun _ _ => 3) 0 := by + have h := Allocator.Amortized.prod (Stack.Memory.amortized_allocator (w := 8) (C := 2)) + (Allocator.Amortized.prod (Stack.Memory.amortized_allocator (w := 8) (C := 2)) + (Stack.Memory.amortized_allocator (w := 8) (C := 2))) + simp only [productCharge_const] at h + exact h + +/-- The generic correctness theorem gives the specification's answer. -/ +example : (spec 8).clientResult nothing (allocated.run client') = + (product S (product S S)).clientResult allocated.init client' := + have ⟨_, hres, _⟩ := + allocated.run_correct client' (pre_allocated _) (by decide) client'_valid + hres + +/-- The generic cost theorem: nine units to allocate, and three per operation. -/ +example : (spec 8).totalCost charge nothing ((spec 8).clientHistory nothing + (allocated.run client')) ≤ 9 + 0 + 3 * 7 := + Allocator.run_cost_le amortized_allocated client' (pre_allocated _) (by decide) + client'_valid + end ComplexityTests.DataStructureMemoryProduct diff --git a/ComplexityTests/FibonacciHeapDecreaseKey.lean b/ComplexityTests/FibonacciHeapDecreaseKey.lean new file mode 100644 index 0000000000..7e4acce3d4 --- /dev/null +++ b/ComplexityTests/FibonacciHeapDecreaseKey.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +-- upstream: local-only (test driver) + +public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.DecreaseKey + +/-! +# The record Fibonacci heap's `decreaseKey` on a concrete heap + +A heap on three handles is one chain: root `0` with child `1` with child `2`, and `1` is marked. +It satisfies `Inv`, proved here directly, so the invariant and its `Cascading` form have a +concrete instance with a marked node. Decreasing the key of `2` below its parent's cuts `2`, and +the cascade cuts the marked `1` in turn. The tests check the result by evaluation (the keys, the +three unmarked roots, the minimum root, the exact cost) and apply `wp_decreaseKey`, which gives +admissibility, the invariant of the result and the amortized bound `104`. +-/ + +@[expose] public section + +namespace ComplexityTests.FibonacciHeapDecreaseKey + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.PriorityQueue + Cslib.DataStructure.PriorityQueue.FibonacciHeap + Cslib.DataStructure.PriorityQueue.WordRAM.FibonacciHeap + +/-- The record specification for heaps on three handles at word size `4`. -/ +abbrev heap : StateTransitionSpec := Record.spec (Cell.ok 3) 4 + +/-- Root `0` (key `1`) with child `1` (key `5`, marked) with child `2` (key `7`). Each child list +and the root list is a one-element circular list. -/ +def chain : Cell → ℕ + | .key 0 => 1 | .key 1 => 5 | .key 2 => 7 + | .par 1 => 0 + 1 | .par 2 => 1 + 1 + | .child 0 => 1 + 1 | .child 1 => 2 + 1 + | .left 1 => 1 | .right 1 => 1 | .left 2 => 2 | .right 2 => 2 + | .deg 0 => 1 | .deg 1 => 1 + | .mark 1 => 1 + | .inHeap 0 => 1 | .inHeap 1 => 1 | .inHeap 2 => 1 + | .minRoot => 0 + 1 | .numRoots => 1 | .numMarked => 1 | .sz => 3 + | _ => 0 + +/-- The chain as a tree. -/ +def tree : FHTree 3 := .node 0 [.node 1 [.node 2 []]] + +/-- The chain is a valid root tree. -/ +theorem valid_tree : ValidRoot (view 3 chain) none tree := by + refine ⟨.mk (by decide) (by decide) rfl + (Or.inr ⟨1, [], rfl, by unfold IsCircList ChainLinks; decide, by decide⟩) + (by decide) (by decide) (fun i hi => by simp at hi; omega) fun T hT => ?_, rfl, rfl⟩ + simp only [List.mem_singleton] at hT + subst hT + refine .mk (by decide) (by decide) rfl + (Or.inr ⟨2, [], rfl, by unfold IsCircList ChainLinks; decide, by decide⟩) + (by decide) (by decide) (fun i hi => by simp at hi; omega) fun T hT => ?_ + simp only [List.mem_singleton] at hT + subst hT + exact .mk (by decide) (by decide) rfl (Or.inl ⟨rfl, rfl⟩) (by simp) (by simp) (by simp) (by simp) + +/-- **The invariant has an instance with a marked node**: the chain is a valid heap. -/ +theorem inv_chain : Inv 3 9 chain := by + refine ⟨[tree], by simpa using valid_tree, by decide, fun v => by revert v; decide, + fun v => by revert v; decide, fun v k h => ?_, by decide, rfl, by decide, by decide, + Or.inr ⟨0, [], rfl, by unfold IsCircList ChainLinks; decide, by decide, by decide⟩⟩ + fin_cases v <;> simp [FibonacciHeap.abs, absRaw, view, chain] at h ⊢ <;> omega + +/-- So the forest is `Cascading` for `2`, with nothing pending. -/ +example : ∃ m ts, Cascading 3 9 (abs 3 chain) (view 3 chain) 2 m none ts := + cascading_of_fibRawInv inv_chain (by decide) + +/-- Decrease the key of `2` from `7` to `3`. -/ +abbrev lower : Prog Unit := decreaseKey 3 2 3 + +/-- The keys after the run. -/ +example : abs 3 (heap.clientState chain lower) = ![some 1, some 5, some 3] := by decide + +/-- Both cuts happened: the three handles are unmarked roots, and `0` is still the minimum. -/ +example : (view 3 (heap.clientState chain lower)).numRoots = 3 ∧ + (view 3 (heap.clientState chain lower)).numMarked = 0 ∧ + (∀ v : Fin 3, (view 3 (heap.clientState chain lower)).par v = 0 ∧ + (view 3 (heap.clientState chain lower)).mark v = 0) ∧ + (view 3 (heap.clientState chain lower)).minRoot = 0 + 1 := by decide + +/-- The run's exact cost in record operations. -/ +example : (heap.clientHistory chain lower).length = 40 := by decide + +/-- The potential before and after: one root and one mark, then three roots. -/ +example : potential 3 chain = 72 ∧ potential 3 (heap.clientState chain lower) = 72 := by decide + +/-- **The specification applies**: `wp_decreaseKey` on this run. -/ +theorem lower_spec : Record.wp (Cell.ok 3) 4 lower (fun _ g' t => + abs 3 g' = Function.update (abs 3 chain) 2 (some 3) ∧ Inv 3 9 g' ∧ + t + potential 3 g' ≤ 104 + potential 3 chain) chain := + wp_decreaseKey (v := 2) (k₀ := 7) (k := 3) (w := 4) inv_chain (by decide) (by decide) (by decide) + (by decide) (by decide) + +/-- So the run is admissible, the result is a valid heap, and the cost is within the bound. -/ +example : heap.ValidHistory chain (heap.clientHistory chain lower) ∧ + Inv 3 9 (heap.clientState chain lower) ∧ + (heap.clientHistory chain lower).length + potential 3 (heap.clientState chain lower) ≤ + 104 + potential 3 chain := by + obtain ⟨hv, -, hI, hc⟩ := (Record.wp_iff _ _ _).mp lower_spec + exact ⟨hv, hI, hc⟩ + +end ComplexityTests.FibonacciHeapDecreaseKey diff --git a/ComplexityTests/PromiseBPTIME.lean b/ComplexityTests/PromiseBPTIME.lean new file mode 100644 index 0000000000..533d6fc758 --- /dev/null +++ b/ComplexityTests/PromiseBPTIME.lean @@ -0,0 +1,98 @@ +/- +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 Complexity.Computability.Complexity.Classes.Promise.Time.Verifier +import Complexity.Computability.Machines.Turing.MultiTape.Complexity.Quantitative +import Complexity.Computability.Machines.Turing.MultiTape.Internal.OCombinators + +/-! The explicit-time verifier characterization of `PromiseBPTIME` on concrete bounds. A +deterministic linear-time decider is a sample-and-verify machine with no coins, so it solves every +promise problem it separates, and its problem is in `BPTIME`. A promise problem in linear time +survives the round trip through its linear-time coin-replay verifier and sample and verify, at the +same linear bound, so both explicit-time hypotheses are satisfiable together. -/ + +public section + +namespace ComplexityTests.PromiseBPTIME + +open Cslib Cslib.Complexity Turing Turing.MultiTapeTM + +/-- `c * n + c` in unary, within linear time and space. -/ +private theorem computableInO_linear_unary (c : ℕ) : + ComputableInO (fun x : List Bool => c * x.length + c) encBits encUnary + (fun x => x.length) (fun x => x.length) := by + induction c with + | zero => + simpa using ComputableInO.const (encIn := encBits) (encMid := encUnary) 0 + | succ c ih => + have hstep := ComputableInO.lengthUnary.append + (ComputableInO.const (encIn := encBits) (encMid := encUnary) 1) + (g := fun x : List Bool => x.length + 1) (encOut := encUnary) + fun x => by simp [encUnary_apply, List.replicate_add] + have h := ih.append hstep (g := fun x : List Bool => (c + 1) * x.length + (c + 1)) + (encOut := encUnary) fun x => by + simp only [encUnary_apply, ← List.replicate_add] + congr 1 + ring + exact h.mono 3 (fun x => by simp only [encBits_apply]; omega) + (fun x => by simp only [encBits_apply]; omega) + +/-- **A deterministic linear-time decider, with no coins.** Every promise problem separated by a +problem in `DTIME n` is in `PromiseBPTIME n`. -/ +theorem mem_PromiseBPTIME_of_mem_DTIME {A : Set (List Bool)} {Q : PromiseProblem (List Bool)} + (hA : A ∈ DTIME encBits fun n => n) (hyes : Q.yes ⊆ A) (hno : Q.no ⊆ Aᶜ) : + Q ∈ PromiseBPTIME encBits fun n => n := by + have hV := (computableInO_indicator_of_mem_DTIME hA).comp (ComputableInO.fst encBits encBits) + refine mem_PromiseBPTIME_of_verifier (ℓ := fun _ => 0) (t := fun n => n) (C := 6) + (ComputableInO.const (encIn := encBits) (encMid := encUnary) 0) hV (fun x w hw => ?_) + (fun x hx => ?_) fun x hx => ?_ + · simp only [List.length_eq_zero_iff] at hw + subst hw + simp only [encBits_apply, encPair_apply, List.length_append, length_frame, List.length_nil] + omega + · simp [acceptCount_zero, indicator, hyes hx] + · simp [acceptCount_zero, indicator, show x ∉ A from hno hx] + +/-- Through the bridge with `BPTIME`, a problem in `DTIME n` is in `BPTIME n`. -/ +example {A : Set (List Bool)} (hA : A ∈ DTIME encBits fun n => n) : + A ∈ BPTIME encBits fun n => n := + ofSet_mem_PromiseBPTIME.mp + (mem_PromiseBPTIME_of_mem_DTIME hA le_rfl fun _ h => h) + +/-- The promise problem with every word a yes-instance, solved by sampling no coins and +accepting: a concrete member of `PromiseBPTIME n`. -/ +example : (⟨Set.univ, ∅, Set.disjoint_empty _⟩ : PromiseProblem (List Bool)) ∈ + PromiseBPTIME encBits fun n => n := by + refine mem_PromiseBPTIME_of_verifier (V := fun _ => true) (ℓ := fun _ => 0) (t := fun n => n) + (C := 4) (ComputableInO.const (encIn := encBits) (encMid := encUnary) 0) + (ComputableInO.const (encIn := encPair encBits encBits) (encMid := encBool) true) + (fun x w hw => ?_) (fun x _ => by simp) fun x hx => absurd hx (Set.notMem_empty x) + simp only [List.length_eq_zero_iff] at hw + subst hw + simp only [encBits_apply, encPair_apply, List.length_append, length_frame, List.length_nil] + omega + +/-- **Round trip at linear time.** A promise problem in linear time has a linear-time coin-replay +verifier, and sampling strings of length `c * n + c` for it solves the problem in linear time +again. Both explicit-time hypotheses are satisfiable together. -/ +theorem mem_PromiseBPTIME_linear_of_verifier_roundTrip {Q : PromiseProblem (List Bool)} + (hQ : Q ∈ PromiseBPTIME encBits fun n => n) : Q ∈ PromiseBPTIME encBits fun n => n := by + obtain ⟨V, c, hV, hbound⟩ := exists_verifier_of_mem_PromiseBPTIME hQ + exact mem_PromiseBPTIME_of_verifier (ℓ := fun x : List Bool => c * x.length + c) + (t := fun n => n) (C := c + 4) (computableInO_linear_unary c) hV + (fun x w hw => by + simp only [encBits_apply, encPair_apply, List.length_append, length_frame, hw] + nlinarith) + (fun x hx => (hbound x _ (by simp [encBits_apply])).1 hx) + fun x hx => (hbound x _ (by simp [encBits_apply])).2 hx + +/-- The lift of `BPTIME` is contained in `PromiseBPTIME`, at a concrete bound. -/ +example : promiseClass (BPTIME encBits fun n => n) ⊆ PromiseBPTIME encBits fun n => n := + promiseClass_BPTIME_subset_PromiseBPTIME + +end ComplexityTests.PromiseBPTIME diff --git a/ROADMAP.md b/ROADMAP.md index 27aa9fa94b..76c97cd017 100644 --- a/ROADMAP.md +++ b/ROADMAP.md @@ -185,6 +185,12 @@ index links to canonical definitions rather than keeping a second set. machine's own steps, noninteger polynomial degrees, a word-RAM hierarchy by direct diagonalization with a smaller gap, and sharp nondeterministic and alternating time hierarchies with certified simulators. +- **Probabilistic time hierarchies** ([#2084]): the hierarchy for promise problems + (`PromiseBPTIME`), by delayed diagonalization following He (ECCC TR25-004), and the + one-bit-advice hierarchy for languages of van Melkebeek and Pervyshev. `PromiseBPTIME` and its + explicit-time sample-and-verify characterization are in place (`Classes/Promise/Time` and + `Classes/Promise/Time/Verifier`). The advice-free hierarchy for `BPTIME` itself is open and is + not a target. - The space hierarchy for `log n ≤ g n`, which needs a universal simulation that does not hold its input. - **Space:** Savitch bounds for general space-constructible functions. @@ -799,3 +805,4 @@ not planned, not as proved. [#2127]: https://github.com/cslib-community/complexitylib/issues/2127 [#2145]: https://github.com/cslib-community/complexitylib/issues/2145 [#2146]: https://github.com/cslib-community/complexitylib/issues/2146 +[#2084]: https://github.com/cslib-community/complexitylib/issues/2084 diff --git a/references.bib b/references.bib index 0b4758dbf6..a940707f2c 100644 --- a/references.bib +++ b/references.bib @@ -2429,6 +2429,15 @@ @article{Haussler1992 doi = {10.1016/0890-5401(92)90010-D} } +@techreport{He2025, + author = {He, Songhua}, + title = {A note on a hierarchy theorem for promise-{BPTIME}}, + institution = {Electronic Colloquium on Computational Complexity}, + number = {TR25-004}, + year = {2025}, + url = {https://eccc.weizmann.ac.il/report/2025/004/} +} + @inproceedings{HemaspaandraEtAl2018, author = {Hemaspaandra, Edith and Hemaspaandra, Lane A. and Spakowski, Holger and Watanabe, Osamu}, diff --git a/scripts/aggregate_merge.md b/scripts/aggregate_merge.md new file mode 100644 index 0000000000..e800bde15f --- /dev/null +++ b/scripts/aggregate_merge.md @@ -0,0 +1,63 @@ +# Report an aggregate-only merge conflict + +`aggregate_merge.py` checks the narrow generated `Complexity.lean` case from +[#2274](https://github.com/cslib-community/complexitylib/issues/2274). Run it against immutable, +locally available commits: + +```sh +python3 -B scripts/aggregate_merge.py --repo /path/to/checkout \ + --prefix FULL_ACCEPTED_PREFIX_SHA --source FULL_SOURCE_HEAD_SHA \ + --reviewed-base FULL_ORIGINAL_PARENT_SHA --reviewed-head FULL_REVIEWED_HEAD_SHA \ + > aggregate-report.json +``` + +It prints JSON and exits zero only for `status: verified`. `rejected` means an input or merge +falls outside the supported case; `limitation` means canonical reconstruction passed but the +ordinary tracked-attribute Git merge did not produce that exact tree. Neither status authorizes +integration. The report includes immutable inputs, trees, the complete candidate entry map, +reviewed payload entries, feature/aggregate digests and exact inverse recovery of the prefix. + +The verifier requires the complete neutral conflict set to be exactly `Complexity.lean`. +Each input aggregate must have the exact module-style preamble and complete sorted public +imports generated by `scripts/MkAll.lean`. Module names follow the conservative path syntax in +`quick_check.py`; dynamic Lake configuration, moved library roots, symlink modules and other +aggregate styles are rejected. This is an exact generated-format check, not a general Lean +parser that might overlook declarations or options after the imports. + +Canonical imports come from the merged library inventory, so additions and deletions are both +accounted for. Every other entry and mode must equal the neutral merge. The complete original +nonaggregate feature, including docs, tests and removals, must replay onto the accepted prefix; +reviewed payload modes/blobs must remain exact. Reversing that feature and restoring the prefix +aggregate must recover the exact prefix tree. Additional unreviewed source payloads are rejected. + +Finally, Git's ordinary merge with the prefix's tracked attributes must yield the identical +canonical tree. For example, an adjacent insertion may produce sorted imports with `merge=union`, +while reversing the insertion order may produce unsorted imports. Adjacent independent deletions +can also reconstruct correctly while union retains deleted imports. Both latter cases report a +limitation: the source owner must refresh the source branch through the usual reviewed process. +The tool never proposes an alternative queue API or enables a merge driver. + +Git operations use a temporary bare repository/index/object directory populated by an ordinary +local `file://` fetch. It has its own common directory, no alternates or shallow boundary, and +no object inode shared with the source. These properties are checked. Fetching complete history +can cost disk space and time; shallow source repositories are rejected. Pack threads are capped +at two. All inherited `GIT_*` environment variables are cleared before the first Git command, +including object, index, common-directory and worktree redirects. +No source/index/ref/config/object write, merge commit, +queue operation, workflow or cache action occurs in the inspected repository. User/system +attributes, local `info/attributes`, hooks and configured merge drivers are excluded; only the +prefix's tracked attributes participate in the ordinary comparison. Python 3.11+ and Git 2.43+ +are required. Unavailable history is an error, not a request to repair or reconstruct objects. + +This local standard-Git comparison does not certify GitHub's settings, current source ownership, +review approval, dependency landings or CI. Coordinators must still guard the live source/full +prefix, verify the actual hosted candidate tree, and require all six queue checks, including +`mk_all --check`. The report does not change admission policy. + +Focused regression tests use independent temporary Git repositories and run without Lean: + +```sh +python3 -B -m unittest discover -s scripts -p test_aggregate_merge.py -v +``` + +No Lean statement, definition, selected abstract, catalogue entry or rendered PDF changes. diff --git a/scripts/aggregate_merge.py b/scripts/aggregate_merge.py new file mode 100644 index 0000000000..21dcc87e75 --- /dev/null +++ b/scripts/aggregate_merge.py @@ -0,0 +1,261 @@ +#!/usr/bin/env python3 +"""Report whether an aggregate-only conflict has an exact canonical Git merge. + +All four inputs must be full commit IDs available locally. Git writes only to a temporary +repository; the inspected repository is read-only. See aggregate_merge.md for the contract. +""" + +from __future__ import annotations + +import argparse +from contextlib import contextmanager +import hashlib +import json +import os +from pathlib import Path +import re +import subprocess +import sys +import tempfile +import tomllib + + +AGGREGATE = "Complexity.lean" +# scripts/MkAll.lean, module-style branch; intentionally not a general Lean header parser. +MODULE_HEADER = b"module -- shake: keep-all --deprecated_module: ignore\n\n" +COMPONENT = re.compile(r"[A-Za-z_][A-Za-z_0-9]*\Z") # quick_check.source_modules convention +OID = re.compile(r"[0-9a-f]{40}\Z") + + +class Rejected(Exception): + """An input or merge is outside this verifier's bounded contract.""" + + +def require(condition: bool, message: str) -> None: + if not condition: + raise Rejected(message) + + +def environment() -> dict[str, str]: + # Do not inherit replacement objects, index/object directories or user merge drivers. + env = {key: value for key, value in os.environ.items() if not key.startswith("GIT_")} + env.update(GIT_CONFIG_NOSYSTEM="1", GIT_CONFIG_GLOBAL=os.devnull, + GIT_ATTR_NOSYSTEM="1", GIT_NO_REPLACE_OBJECTS="1", GIT_OPTIONAL_LOCKS="0") + return env + + +class Git: + def __init__(self, root: Path, env: dict[str, str]): + self.root, self.env = root, env + + def run(self, *args: str, data: bytes | None = None, allowed=(0,)): + result = subprocess.run( + ["git", "-c", "gc.auto=0", "-c", "maintenance.auto=false", + "-c", "pack.threads=2", "-c", "fetch.parallel=1", + "-c", f"core.attributesFile={os.devnull}", "-c", f"core.hooksPath={os.devnull}", + *args], cwd=self.root, env=self.env, input=data, capture_output=True) + require(result.returncode in allowed, + f"git {args[0]} failed: {result.stderr.decode(errors='replace').strip()}") + return result + + def text(self, *args: str) -> str: + return self.run(*args).stdout.decode().strip() + + def entries(self, tree: str) -> dict[str, dict[str, str]]: + entries = {} + for row in self.run("ls-tree", "-rz", tree).stdout.split(b"\0"): + if row: + metadata, path = row.split(b"\t", 1) + mode, kind, oid = metadata.decode().split() + entries[path.decode()] = {"mode": mode, "type": kind, "oid": oid} + return entries + + def blob(self, entry: dict[str, str]) -> bytes: + require(entry["type"] == "blob", "expected a blob") + return self.run("cat-file", "blob", entry["oid"]).stdout + + def set_aggregate(self, entry: dict[str, str]) -> str: + self.run("update-index", "--add", "--cacheinfo", entry["mode"], entry["oid"], AGGREGATE) + return self.text("write-tree") + + +@contextmanager +def scratch_git(repo: Path, commits: tuple[str, ...]): + require(all(OID.fullmatch(oid) for oid in commits), "use full immutable commit IDs") + source = Git(repo, environment()) + require(source.text("rev-parse", "--show-object-format") == "sha1", "only SHA-1 is supported") + require(source.text("rev-parse", "--is-shallow-repository") == "false", + "shallow source repositories are unsupported") + objects = Path(source.text("rev-parse", "--path-format=absolute", "--git-path", "objects")) + common = Path(source.text("rev-parse", "--path-format=absolute", "--git-common-dir")) + with tempfile.TemporaryDirectory(prefix="aggregate-merge-") as directory: + root = Path(directory) + source.run("init", "--bare", "--quiet", "--template=", "--object-format=sha1", str(root)) + git = Git(root, environment()) + require(Path(git.text("rev-parse", "--absolute-git-dir")).resolve() == root.resolve() and + Path(git.text("rev-parse", "--path-format=absolute", "--git-common-dir")).resolve() + == root.resolve() and root.resolve() != common.resolve(), + "temporary repository does not have an independent common directory") + own_objects = Path(git.text("rev-parse", "--path-format=absolute", "--git-path", "objects")) + require(own_objects.resolve() == (root / "objects").resolve() and + own_objects.resolve() != objects.resolve() and not (root / ".git").exists(), + "temporary object directory is not independent") + # Check identity before fetching or writing merge/index objects. A normal file:// + # fetch uses upload-pack, unlike clone's local hard-link shortcut. + git.run("fetch", "--no-tags", "--no-write-fetch-head", "--no-recurse-submodules", + "--no-auto-maintenance", repo.as_uri(), *dict.fromkeys(commits)) + require(not (own_objects / "info/alternates").exists() and + not (own_objects / "info/http-alternates").exists() and not (root / "shallow").exists(), + "temporary repository contains alternates or a shallow boundary") + source_inodes = {(p.stat().st_dev, p.stat().st_ino) for p in objects.rglob("*") if p.is_file()} + copied = [p for p in own_objects.rglob("*") if p.is_file()] + require(all(not p.is_symlink() and (p.stat().st_dev, p.stat().st_ino) not in source_inodes + for p in copied), "temporary objects share source storage") + git.isolation = {"independent_common_directory": True, "independent_object_directory": True, + "no_alternates_or_shallow_boundary": True, "no_shared_object_inodes": True, + "fetched_object_files": len(copied)} + yield git + + +def canonical(entries: dict[str, dict[str, str]]) -> bytes: + """Mirror mk_all's Complexity root: all .lean modules, sorted by module name.""" + modules = [] + for path, entry in entries.items(): + if path.startswith("Complexity/") and path.endswith(".lean"): + parts = path[:-5].split("/") + require(all(COMPONENT.fullmatch(part) for part in parts), + f"unsupported module path: {path}") + require(entry["type"] == "blob" and entry["mode"] in {"100644", "100755"}, + f"nonregular Lean module: {path}") + modules.append(".".join(parts)) + require(bool(modules), "empty Complexity library") + return MODULE_HEADER + b"".join(f"public import {name}\n".encode() for name in sorted(modules)) + + +def check_aggregate(git: Git, entries: dict, label: str) -> None: + require("lakefile.lean" not in entries and "lakefile.toml" in entries, + f"{label}: unsupported Lake configuration") + config = tomllib.loads(git.blob(entries["lakefile.toml"]).decode()) + libraries = config.get("lean_lib", []) + require(isinstance(libraries, list), f"{label}: invalid Lake libraries") + roots = [lib for lib in libraries if isinstance(lib, dict) and lib.get("name") == "Complexity"] + require(config.get("srcDir", ".") == "." and len(roots) == 1 and + roots[0].get("srcDir", ".") == "." and + roots[0].get("roots", ["Complexity"]) == ["Complexity"] and "globs" not in roots[0], + f"{label}: unsupported Complexity library layout") + require(AGGREGATE in entries and entries[AGGREGATE]["mode"] == "100644", + f"{label}: missing or nonregular aggregate") + content = git.blob(entries[AGGREGATE]) + require(content.startswith(MODULE_HEADER), f"{label}: changed known aggregate preamble") + # Exact generation rejects options/declarations, comments, malformed, repeated, missing, + # extra and unsorted imports. General Lean parsing would accept too much here. + require(content == canonical(entries), f"{label}: aggregate is not canonical for its inventory") + + +def merge(git: Git, prefix: str, source: str, attributes: str): + result = git.run("-c", f"attr.tree={attributes}", "merge-tree", "--write-tree", + "--name-only", "-z", prefix, source, allowed=(0, 1)) + fields = result.stdout.split(b"\0") + tree = fields.pop(0).decode() + require(bool(OID.fullmatch(tree)), "unexpected merge-tree output (Git >= 2.43 required)") + conflicts = [] + for field in fields: + if not field: + break + conflicts.append(field.decode()) + return result.returncode, tree, conflicts + + +def verify(git: Git, prefix: str, source: str, reviewed_base: str, reviewed_head: str, + report: dict) -> None: + refs = {"prefix": prefix, "source": source, + "reviewed_base": reviewed_base, "reviewed_head": reviewed_head} + for label, oid in refs.items(): + require(bool(OID.fullmatch(oid)), f"{label}: use a full immutable commit ID") + require(git.text("rev-parse", "--verify", f"{oid}^{{commit}}") == oid, + f"{label}: expected a commit") + require(git.run("merge-base", "--is-ancestor", reviewed_base, reviewed_head, + allowed=(0, 1)).returncode == 0, "reviewed base is not an ancestor of reviewed head") + require(git.run("merge-base", "--is-ancestor", reviewed_head, source, + allowed=(0, 1)).returncode == 0, "source does not retain reviewed history") + require(len(git.text("merge-base", "--all", prefix, source).splitlines()) == 1, + "merge needs exactly one base") + inventories = {label: git.entries(oid) for label, oid in refs.items()} + for label, entries in inventories.items(): + check_aggregate(git, entries, label) + report.update(inputs=refs, isolation=git.isolation, + input_trees={label: git.text("rev-parse", f"{oid}^{{tree}}") + for label, oid in refs.items()}) + empty = git.run("hash-object", "-t", "tree", "--stdin", "-w", data=b"").stdout.decode().strip() + # attr.tree must actually disable the tracked union attribute on this Git version. + attrs = git.run("-c", f"attr.tree={empty}", "check-attr", "-z", "merge", "--", AGGREGATE).stdout + require(attrs == b"Complexity.lean\0merge\0unspecified\0", "cannot disable tracked attributes") + status, neutral, conflicts = merge(git, prefix, source, empty) + report.update(neutral_tree=neutral, conflicts=conflicts) + require(status == 1 and conflicts == [AGGREGATE], + f"complete neutral conflict set must be exactly [{AGGREGATE!r}], got {conflicts!r}") + merged = git.entries(neutral) + content = canonical(merged) + entry = {"mode": "100644", "type": "blob", + "oid": git.run("hash-object", "-w", "--stdin", data=content).stdout.decode().strip()} + git.run("read-tree", neutral) + candidate = git.set_aggregate(entry) + candidate_entries = git.entries(candidate) + require({p: e for p, e in merged.items() if p != AGGREGATE} == + {p: e for p, e in candidate_entries.items() if p != AGGREGATE}, + "canonicalization changed a nonaggregate entry") + feature = git.run("diff", "--no-ext-diff", "--no-textconv", "--no-renames", "--binary", + "--full-index", reviewed_base, reviewed_head, "--", ".", + ":(exclude)Complexity.lean").stdout + require(bool(feature), "reviewed feature has no nonaggregate payload") + own_paths = sorted(p for p in inventories["reviewed_base"].keys() | inventories["reviewed_head"].keys() + if p != AGGREGATE and inventories["reviewed_base"].get(p) != + inventories["reviewed_head"].get(p)) + for path in own_paths: + require(candidate_entries.get(path) == inventories["reviewed_head"].get(path), + f"reviewed payload mode/blob changed: {path}") + # Whole-feature replay is stronger than checking only the named Lean payloads. It also + # guards docs, removals, modes and every unrelated accepted-prefix entry. + git.run("read-tree", prefix) + git.run("apply", "--cached", "--binary", data=feature) + require(git.set_aggregate(entry) == candidate, "feature forward replay does not recover candidate") + git.run("read-tree", candidate) + git.run("apply", "--cached", "--binary", "--reverse", data=feature) + recovered = git.set_aggregate(inventories["prefix"][AGGREGATE]) + require(recovered == report["input_trees"]["prefix"], "feature inverse does not recover exact prefix") + report.update(candidate_tree=candidate, candidate_entries=candidate_entries, + reviewed_paths=own_paths, reviewed_entries={p: candidate_entries.get(p) for p in own_paths}, + feature_patch_sha256=hashlib.sha256(feature).hexdigest(), recovered_prefix_tree=recovered, + canonical_aggregate_sha256=hashlib.sha256(content).hexdigest(), + canonical_import_count=len(content.splitlines()) - 2) + # A private canonical tree is not an admission mechanism. The ordinary tracked-attribute + # merge, in the target-prefix direction, must produce exactly that tree itself. + status, default, conflicts = merge(git, prefix, source, prefix) + report.update(default_merge_tree=default, default_conflicts=conflicts) + if status != 0 or conflicts or default != candidate: + report["status"] = "limitation" + raise Rejected("ordinary tracked-attribute merge cannot represent the exact canonical candidate; " + "refresh the source branch through its owner") + report["status"] = "verified" + + +def main(argv=None) -> int: + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("--repo", type=Path, default=Path.cwd()) + for name in ("prefix", "source", "reviewed-base", "reviewed-head"): + parser.add_argument(f"--{name}", required=True) + args = parser.parse_args(argv) + report = {"status": "rejected", "report_only": True, + "limits": "No source review, CI, hosted candidate or queue authority is certified."} + try: + with scratch_git(args.repo.resolve(), + (args.prefix, args.source, args.reviewed_base, args.reviewed_head)) as git: + verify(git, args.prefix, args.source, args.reviewed_base, args.reviewed_head, report) + except (Rejected, OSError, ValueError) as error: + report["reason"] = str(error) + print(json.dumps(report, indent=2, sort_keys=True)) + return 0 if report["status"] == "verified" else 1 + + +if __name__ == "__main__": + sys.exit(main()) diff --git a/scripts/test_aggregate_merge.py b/scripts/test_aggregate_merge.py new file mode 100644 index 0000000000..220d97abf7 --- /dev/null +++ b/scripts/test_aggregate_merge.py @@ -0,0 +1,289 @@ +#!/usr/bin/env python3 +"""Real Git fixtures for the report-only aggregate verifier; no Lean build is needed.""" + +import contextlib +import hashlib +import io +import json +import os +from pathlib import Path +import subprocess +import tempfile +import unittest +from unittest.mock import patch + +import aggregate_merge as verifier + + +class AggregateMergeTests(unittest.TestCase): + def setUp(self): + temp = tempfile.TemporaryDirectory(prefix="test-aggregate-merge-") + self.addCleanup(temp.cleanup) + self.repo = Path(temp.name) + self.env = verifier.environment() + self.env.update(GIT_AUTHOR_NAME="Fixture", GIT_AUTHOR_EMAIL="fixture@example.invalid", + GIT_COMMITTER_NAME="Fixture", GIT_COMMITTER_EMAIL="fixture@example.invalid") + self.git("init", "--quiet", "--initial-branch=main") + self.write("lakefile.toml", 'name = "fixture"\n[[lean_lib]]\nname = "Complexity"\n') + self.write(".gitattributes", "Complexity.lean merge=union\n") + for name in ("Init", "Zed"): + self.write(f"Complexity/{name}.lean", f"-- fixture {name}\n") + self.aggregate() + self.base = self.commit("base") + + def git(self, *args): + return subprocess.run(["git", "-c", "gc.auto=0", "-c", "maintenance.auto=false", *args], + cwd=self.repo, env=self.env, check=True, + capture_output=True).stdout.decode().strip() + + def write(self, path, content): + target = self.repo / path + target.parent.mkdir(parents=True, exist_ok=True) + target.write_text(content) + + def aggregate(self): + modules = sorted(".".join(p.relative_to(self.repo).with_suffix("").parts) + for p in (self.repo / "Complexity").rglob("*.lean")) + self.write("Complexity.lean", verifier.MODULE_HEADER.decode() + + "".join(f"public import {name}\n" for name in modules)) + + def commit(self, message): + self.git("add", ".") + self.git("commit", "--quiet", "-m", message) + return self.git("rev-parse", "HEAD") + + def additions(self, prefix_name="Able", source_name="Beta"): + self.write(f"Complexity/{prefix_name}.lean", "-- accepted prefix payload\n") + self.write("prefix-doc.md", "accepted prefix documentation\n") + self.aggregate() + prefix = self.commit("prefix") + self.git("switch", "--quiet", "--detach", self.base) + self.write(f"Complexity/{source_name}.lean", "-- reviewed feature payload\n") + self.write("review-doc.md", "reviewed feature documentation\n") + self.write("ComplexityTests/Feature.lean", "-- reviewed fixture\n") + self.aggregate() + return prefix, self.commit("reviewed feature") + + def report(self, prefix, source, reviewed=None, base=None): + output = io.StringIO() + with contextlib.redirect_stdout(output): + status = verifier.main(["--repo", str(self.repo), "--prefix", prefix, + "--source", source, "--reviewed-base", base or self.base, + "--reviewed-head", reviewed or source]) + return status, json.loads(output.getvalue()) + + def snapshot(self): + # Include objects and the fixture's index/refs/config/working files, not just status. + return {str(p.relative_to(self.repo)): hashlib.sha256(p.read_bytes()).hexdigest() + for p in self.repo.rglob("*") if p.is_file()} + + def test_adjacent_additions_exact_default_and_whole_feature_recovery(self): + prefix, source = self.additions() + before = self.snapshot() + status, report = self.report(prefix, source) + self.assertEqual(status, 0, report) + self.assertEqual(report["status"], "verified") + self.assertEqual(report["conflicts"], ["Complexity.lean"]) + self.assertEqual(report["candidate_tree"], report["default_merge_tree"]) + self.assertEqual(report["recovered_prefix_tree"], self.git("rev-parse", prefix + "^{tree}")) + self.assertEqual(report["reviewed_paths"], + ["Complexity/Beta.lean", "ComplexityTests/Feature.lean", "review-doc.md"]) + self.assertEqual(report["canonical_import_count"], 4) + self.assertTrue(report["isolation"]["no_shared_object_inodes"]) + self.assertEqual(before, self.snapshot(), "verifier mutated inspected repository") + + def test_actual_temporary_git_storage_is_independent(self): + prefix, source = self.additions() + with verifier.scratch_git(self.repo, (prefix, source)) as scratch: + self.assertNotEqual(scratch.root, self.repo / ".git") + self.assertFalse((scratch.root / ".git").exists()) + self.assertFalse((scratch.root / "objects/info/alternates").exists()) + self.assertFalse((scratch.root / "objects/info/http-alternates").exists()) + self.assertFalse((scratch.root / "shallow").exists()) + source_inodes = {(p.stat().st_dev, p.stat().st_ino) + for p in (self.repo / ".git/objects").rglob("*") if p.is_file()} + temporary_objects = [p for p in (scratch.root / "objects").rglob("*") if p.is_file()] + self.assertTrue(temporary_objects) + self.assertTrue(all((p.stat().st_dev, p.stat().st_ino) not in source_inodes + for p in temporary_objects)) + # Read a real reviewed payload through the independent fetched objects. + self.assertIn("Complexity/Beta.lean", scratch.entries(source)) + + def test_adjacent_deletions_reconstruct_but_default_union_is_a_limitation(self): + for name in ("Able", "Beta"): + self.write(f"Complexity/{name}.lean", "-- removal fixture\n") + self.aggregate() + base = self.commit("deletion base") + (self.repo / "Complexity/Able.lean").unlink() + self.aggregate() + prefix = self.commit("remove Able") + self.git("switch", "--quiet", "--detach", base) + (self.repo / "Complexity/Beta.lean").unlink() + self.aggregate() + source = self.commit("remove Beta") + status, report = self.report(prefix, source, base=base) + self.assertEqual(status, 1) + self.assertEqual(report["status"], "limitation", report) + self.assertEqual(report["canonical_import_count"], 2) + self.assertEqual(report["reviewed_entries"], {"Complexity/Beta.lean": None}) + self.assertEqual(report["recovered_prefix_tree"], self.git("rev-parse", prefix + "^{tree}")) + self.assertNotEqual(report["candidate_tree"], report["default_merge_tree"]) + + def test_noncanonical_default_merge_fails_closed(self): + prefix, source = self.additions("Beta", "Able") + status, report = self.report(prefix, source) + self.assertEqual(status, 1) + self.assertEqual(report["status"], "limitation", report) + self.assertIn("cannot represent", report["reason"]) + + def test_reviewed_feature_after_ordinary_main_merge(self): + self.write("Complexity/Mid.lean", "-- already landed dependency\n") + self.aggregate() + old_main = self.commit("older main") + self.write("Complexity/Able.lean", "-- accepted prefix addition\n") + self.aggregate() + prefix = self.commit("prefix") + self.git("switch", "--quiet", "--detach", self.base) + self.write("Complexity/Beta.lean", "-- reviewed feature\n") + self.aggregate() + reviewed = self.commit("reviewed feature") + self.git("merge", "--quiet", "--no-edit", old_main) + source = self.git("rev-parse", "HEAD") + status, report = self.report(prefix, source, reviewed=reviewed) + self.assertEqual(status, 0, report) + self.assertEqual(report["reviewed_paths"], ["Complexity/Beta.lean"]) + self.assertIn("Complexity/Mid.lean", report["candidate_entries"]) + + def test_without_tracked_union_default_conflict_is_a_limitation(self): + self.write(".gitattributes", "# no aggregate merge driver\n") + self.base = self.commit("no union base") + prefix, source = self.additions() + _, report = self.report(prefix, source) + self.assertEqual(report["status"], "limitation", report) + self.assertEqual(report["default_conflicts"], ["Complexity.lean"]) + + def test_another_conflicted_file_is_rejected_even_with_union_for_it(self): + self.write(".gitattributes", "Complexity.lean merge=union\n*.md merge=union\n") + self.write("shared.md", "base\n") + self.base = self.commit("shared base") + prefix, source = self.additions() + self.write("shared.md", "source\n") + source = self.commit("source conflict") + self.git("switch", "--quiet", "--detach", prefix) + self.write("shared.md", "prefix\n") + prefix = self.commit("prefix conflict") + _, report = self.report(prefix, source) + self.assertEqual(report["status"], "rejected") + self.assertEqual(report["conflicts"], ["Complexity.lean", "shared.md"]) + + def test_changed_preamble_and_hidden_commands_and_invalid_inventories(self): + prefix, source = self.additions() + valid = (self.repo / "Complexity.lean").read_text() + mutations = { + "preamble": valid.replace("module -- shake: keep-all", "module -- shake: keep-all"), + "declaration": valid + "def hidden := 1\n", + "option": valid + "set_option maxHeartbeats 0\n", + "comment spoof": valid + "-- public import Complexity.Hidden\n", + "malformed": valid.replace("public import Complexity.Beta", "public import Complexity..Beta"), + "duplicate": valid + "public import Complexity.Beta\n", + "missing": valid.replace("public import Complexity.Beta\n", ""), + "nonexistent": valid + "public import Complexity.Absent\n", + "unsorted": valid.replace("public import Complexity.Beta\n", "") + + "public import Complexity.Beta\n", + } + for label, text in mutations.items(): + with self.subTest(label=label): + self.git("switch", "--quiet", "--detach", source) + self.write("Complexity.lean", text) + bad = self.commit(label) + status, report = self.report(prefix, bad) + self.assertEqual(status, 1) + self.assertEqual(report["status"], "rejected", report) + self.assertIn("aggregate", report["reason"]) + + def test_unreviewed_extra_payload_cannot_hide_behind_aggregate_conflict(self): + prefix, reviewed = self.additions() + self.write("unreviewed.md", "not in reviewed feature\n") + source = self.commit("extra unreviewed payload") + _, report = self.report(prefix, source, reviewed=reviewed) + self.assertEqual(report["status"], "rejected", report) + self.assertIn("forward replay", report["reason"]) + + def test_reviewed_payload_byte_and_mode_drift_are_rejected(self): + prefix, reviewed = self.additions() + for mode_only in (False, True): + with self.subTest(mode_only=mode_only): + self.git("switch", "--quiet", "--detach", reviewed) + path = self.repo / "Complexity/Beta.lean" + if mode_only: + path.chmod(0o755) + else: + path.write_text("-- changed payload\n") + source = self.commit("drift") + _, report = self.report(prefix, source, reviewed=reviewed) + self.assertEqual(report["status"], "rejected", report) + self.assertIn("mode/blob changed", report["reason"]) + + def test_nonimmutable_reference_and_missing_review_history_are_rejected(self): + prefix, source = self.additions() + _, report = self.report("HEAD", source) + self.assertIn("immutable", report["reason"]) + _, report = self.report(prefix, prefix, reviewed=source) + self.assertIn("reviewed history", report["reason"]) + + def test_no_aggregate_conflict_is_out_of_scope(self): + _, source = self.additions() + _, report = self.report(self.base, source) + self.assertEqual(report["status"], "rejected", report) + self.assertIn("complete neutral conflict set", report["reason"]) + + def test_changed_library_layout_and_symlink_modules_are_rejected(self): + prefix, source = self.additions() + self.write("lakefile.toml", 'name = "fixture"\n[[lean_lib]]\n' + 'name = "Complexity"\nsrcDir = "elsewhere"\n') + bad = self.commit("changed source directory") + _, report = self.report(prefix, bad) + self.assertIn("library layout", report["reason"]) + self.git("switch", "--quiet", "--detach", source) + (self.repo / "Complexity/Beta.lean").unlink() + (self.repo / "Complexity/Beta.lean").symlink_to("Init.lean") + bad = self.commit("symlink module") + _, report = self.report(prefix, bad) + self.assertIn("nonregular Lean module", report["reason"]) + + def test_local_info_attributes_and_merge_drivers_do_not_change_result(self): + prefix, source = self.additions("Beta", "Able") + self.write(".git/info/attributes", "Complexity.lean merge=ours\n") + self.git("config", "merge.ours.driver", "touch SHOULD_NOT_RUN") + before = self.snapshot() + _, report = self.report(prefix, source) + self.assertEqual(report["status"], "limitation", report) + self.assertEqual(before, self.snapshot()) + self.assertFalse((self.repo / "SHOULD_NOT_RUN").exists()) + + def test_hostile_inherited_git_paths_cannot_redirect_temporary_writes(self): + prefix, source = self.additions() + control = self.repo / ".git" + hostile = {"GIT_DIR": str(control), "GIT_COMMON_DIR": str(control), + "GIT_OBJECT_DIRECTORY": str(control / "objects"), + "GIT_ALTERNATE_OBJECT_DIRECTORIES": str(control / "objects"), + "GIT_INDEX_FILE": str(control / "index"), "GIT_WORK_TREE": str(self.repo)} + before = self.snapshot() + with patch.dict(os.environ, hostile): + status, report = self.report(prefix, source) + self.assertEqual(status, 0, report) + self.assertEqual(before, self.snapshot()) + + def test_noncanonical_accepted_prefix_is_rejected(self): + prefix, source = self.additions() + self.git("switch", "--quiet", "--detach", prefix) + with (self.repo / "Complexity.lean").open("a") as output: + output.write("def hidden := 1\n") + prefix = self.commit("noncanonical accepted prefix") + _, report = self.report(prefix, source) + self.assertEqual(report["status"], "rejected", report) + self.assertIn("prefix: aggregate", report["reason"]) + + +if __name__ == "__main__": + unittest.main()