From 5909d1bae7648600e86ab49730835ce9d336ca95 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:07:14 -0500 Subject: [PATCH 01/18] feat(DataStructure/Memory): word-addressed memory oracle and named field arrays Memory.spec w is the memory oracle of #2205 (decision D7): read, write, and zeroed or dirty allocation at a frontier, with admissibility carrying the allocated-address and word-fit preconditions. Field arrays are WordRAM Blocks accessed by Block.get/Block.set programs over the oracle. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity.lean | 2 + Complexity/DataStructure/Memory/Field.lean | 183 +++++++++++++++ Complexity/DataStructure/Memory/Spec.lean | 258 +++++++++++++++++++++ ComplexityTests/DataStructureMemory.lean | 117 ++++++++++ 4 files changed, 560 insertions(+) create mode 100644 Complexity/DataStructure/Memory/Field.lean create mode 100644 Complexity/DataStructure/Memory/Spec.lean create mode 100644 ComplexityTests/DataStructureMemory.lean diff --git a/Complexity.lean b/Complexity.lean index 7f9a77746d..00f4bf2faf 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -2873,6 +2873,8 @@ 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.Field +public import Complexity.DataStructure.Memory.Spec public import Complexity.DataStructure.ObliviousSequence public import Complexity.DataStructure.Online.Basic public import Complexity.DataStructure.OrderedSet.Basic diff --git a/Complexity/DataStructure/Memory/Field.lean b/Complexity/DataStructure/Memory/Field.lean new file mode 100644 index 0000000000..f065798d88 --- /dev/null +++ b/Complexity/DataStructure/Memory/Field.lean @@ -0,0 +1,183 @@ +/- +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.WordRAM.ListArray +public import Complexity.DataStructure.Memory.Spec + +/-! +# Named field arrays over the memory oracle + +A field array is a `Cslib.WordRAM.Block`: a base address and a length. A data structure lays out +its storage as a structure whose fields are blocks (a struct of arrays) and accesses entry `i` of +a field `f` with the programs `f.get i` and `f.set i v` over `Memory.spec w`. Addresses are thus +named (`par.get v`) rather than computed by hand (`base + n + v`), while computed indices, pointer +chasing (`do let p ← next.get v; key.get p`) and reuse of a block across operations remain +ordinary programs. + +The lemmas here evaluate these programs, discharge their admissibility from `Block.Allocated`, +and describe their frame: a write to a field leaves every other address unchanged. +`Block.entries` reads the first `n` entries of a field as a list, which is how an abstraction +function usually sees an array. It realizes `Block.HoldsList`. + +## Main definitions + +* `Cslib.WordRAM.Block.get`, `Cslib.WordRAM.Block.set`: entry access through the oracle. +* `Cslib.WordRAM.Block.Allocated`: the block lies below the frontier. +* `Cslib.WordRAM.Block.entries`: the first `n` entries of a field in index order. +* `Cslib.DataStructure.Memory.allocBlock`, `Cslib.DataStructure.Memory.allocBlockDirty`: + allocate a field. + +## Main results + +* `Cslib.WordRAM.Block.runClient_get_bind`, `Cslib.WordRAM.Block.runClient_set_bind`: one-step + evaluation of field accesses. +* `Cslib.WordRAM.Block.Allocated.lt_frontier`, `Cslib.WordRAM.Block.Allocated.mono`: allocated + entries are admissible addresses, and stay allocated. +* `Cslib.WordRAM.Block.entries_succ`, `Cslib.WordRAM.Block.entries_congr`, + `Cslib.WordRAM.Block.entries_update_of_le`, `Cslib.WordRAM.Block.entries_update_of_not_owns`: + the list view under appends and writes. +* `Cslib.WordRAM.Block.holdsList_entries`: the list view realizes `Block.HoldsList`. +* `Cslib.DataStructure.Memory.runClient_allocBlock_bind`: allocation hands out a zeroed, + allocated block at the frontier. +-/ + +@[expose] public section + +namespace Cslib.WordRAM.Block + +open Cslib.DataStructure + +/-- Read entry `i` of the field `b` through the memory oracle. -/ +abbrev get (b : Block) (i : ℕ) : Memory.Prog ℕ := Memory.read (b.base + i) + +/-- Write `v` to entry `i` of the field `b` through the memory oracle. -/ +abbrev set (b : Block) (i v : ℕ) : Memory.Prog Unit := Memory.write (b.base + i) v + +/-- The block lies below the frontier, so all of its entries are allocated. -/ +def Allocated (b : Block) (s : Memory.State) : Prop := b.base + b.length ≤ s.frontier + +/-- An entry of an allocated block is an allocated address. -/ +theorem Allocated.lt_frontier {b : Block} {s : Memory.State} (h : b.Allocated s) {i : ℕ} + (hi : i < b.length) : b.base + i < s.frontier := by + unfold Allocated at h + omega + +/-- A block stays allocated as the frontier grows. -/ +theorem Allocated.mono {b : Block} {s s' : Memory.State} (h : b.Allocated s) + (hs : s.frontier ≤ s'.frontier) : b.Allocated s' := + le_trans h hs + +/-- A block owns the address of each of its entries. -/ +theorem owns_add {b : Block} {i : ℕ} (hi : i < b.length) : b.Owns (b.base + i) := + ⟨Nat.le_add_right _ _, Nat.add_lt_add_left hi _⟩ + +/-- Reading an entry returns the cell and leaves memory unchanged. -/ +@[simp] theorem runClient_get_bind {w : ℕ} {α : Type} (b : Block) (i : ℕ) (k : ℕ → Memory.Prog α) + (s : Memory.State) : + (Memory.spec w).runClient s (b.get i >>= k) = + let (v, s', os) := (Memory.spec w).runClient s (k (s.mem (b.base + i))) + (v, s', .read (b.base + i) :: os) := rfl + +/-- Writing an entry updates its cell. -/ +@[simp] theorem runClient_set_bind {w : ℕ} {α : Type} (b : Block) (i v : ℕ) + (k : Unit → Memory.Prog α) (s : Memory.State) : + (Memory.spec w).runClient s (b.set i v >>= k) = + let (r, s', os) := (Memory.spec w).runClient + ⟨Function.update s.mem (b.base + i) v, s.frontier⟩ (k ()) + (r, s', .write (b.base + i) v :: os) := rfl + +/-! ## The list of entries -/ + +/-- The first `n` entries of the field `b` in memory `m`, in index order. -/ +def entries (b : Block) (n : ℕ) (m : ℕ → ℕ) : List ℕ := + (List.range n).map fun i => m (b.base + i) + +@[simp] theorem length_entries (b : Block) (n : ℕ) (m : ℕ → ℕ) : (b.entries n m).length = n := by + simp [entries] + +@[simp] theorem entries_zero (b : Block) (m : ℕ → ℕ) : b.entries 0 m = [] := rfl + +/-- Entry `i` of the list view is the cell at `b.base + i`. -/ +@[simp] theorem getElem_entries (b : Block) (n : ℕ) (m : ℕ → ℕ) (i : ℕ) + (hi : i < (b.entries n m).length) : (b.entries n m)[i] = m (b.base + i) := by + simp [entries] + +/-- One more entry appends its cell. -/ +theorem entries_succ (b : Block) (n : ℕ) (m : ℕ → ℕ) : + b.entries (n + 1) m = b.entries n m ++ [m (b.base + n)] := by + simp [entries, List.range_succ] + +/-- The list view depends only on the cells of its entries. -/ +theorem entries_congr (b : Block) (n : ℕ) {m m' : ℕ → ℕ} + (h : ∀ i < n, m' (b.base + i) = m (b.base + i)) : b.entries n m' = b.entries n m := + List.map_congr_left fun i hi => h i (List.mem_range.mp hi) + +/-- Writing at or beyond entry `n` leaves the first `n` entries unchanged. -/ +theorem entries_update_of_le (b : Block) {n i : ℕ} (hi : n ≤ i) (m : ℕ → ℕ) (v : ℕ) : + b.entries n (Function.update m (b.base + i) v) = b.entries n m := + b.entries_congr n fun j hj => Function.update_of_ne (by omega) v m + +/-- Writing outside the block leaves every entry unchanged. -/ +theorem entries_update_of_not_owns (b : Block) {n : ℕ} (hn : n ≤ b.length) {a : ℕ} + (ha : ¬b.Owns a) (m : ℕ → ℕ) (v : ℕ) : + b.entries n (Function.update m a v) = b.entries n m := + b.entries_congr n fun j hj => + Function.update_of_ne (fun h => ha (by rw [← h]; exact owns_add (by omega))) v m + +/-- The list view of `n` entries realizes the list at the block's base. -/ +theorem holdsList_entries (b : Block) (n : ℕ) (m : ℕ → ℕ) : + HoldsList b.base (b.entries n m) m := fun i => by + simp [Block.read] + +end Cslib.WordRAM.Block + +namespace Cslib.DataStructure.Memory + +open Cslib.WordRAM + +/-- Allocate a zeroed field of `k` cells. -/ +def allocBlock (k : ℕ) : Prog Block := do + let base ← alloc k + pure ⟨base, k⟩ + +/-- Allocate a field of `k` cells without clearing it. -/ +def allocBlockDirty (k : ℕ) : Prog Block := do + let base ← allocDirty k + pure ⟨base, k⟩ + +/-- A zeroed allocation hands out the block at the frontier, clears it, and advances the +frontier past it. -/ +@[simp] theorem runClient_allocBlock_bind {w : ℕ} {α : Type} (k : ℕ) (next : Block → Prog α) + (s : State) : + (spec w).runClient s (allocBlock k >>= next) = + let (v, s', os) := (spec w).runClient + ⟨clear s.mem s.frontier k, s.frontier + k⟩ (next ⟨s.frontier, k⟩) + (v, s', .alloc k :: os) := rfl + +/-- A dirty allocation hands out the block at the frontier without changing memory. -/ +@[simp] theorem runClient_allocBlockDirty_bind {w : ℕ} {α : Type} (k : ℕ) + (next : Block → Prog α) (s : State) : + (spec w).runClient s (allocBlockDirty k >>= next) = + let (v, s', os) := (spec w).runClient ⟨s.mem, s.frontier + k⟩ (next ⟨s.frontier, k⟩) + (v, s', .allocDirty k :: os) := rfl + +/-- A freshly allocated block is allocated in the new state. -/ +theorem allocated_alloc (s : State) (k : ℕ) : + (Block.mk s.frontier k).Allocated ⟨clear s.mem s.frontier k, s.frontier + k⟩ := + le_rfl + +/-- A freshly allocated zeroed block holds zeros. -/ +theorem entries_alloc (s : State) (k : ℕ) {n : ℕ} (hn : n ≤ k) : + (Block.mk s.frontier k).entries n (clear s.mem s.frontier k) = List.replicate n 0 := by + refine List.ext_getElem (by simp) fun i hi _ => ?_ + simp only [Block.length_entries] at hi + simp only [Block.getElem_entries, List.getElem_replicate] + exact clear_of_owns (Block.owns_add (b := ⟨s.frontier, k⟩) (by simp only; omega)) + +end Cslib.DataStructure.Memory diff --git a/Complexity/DataStructure/Memory/Spec.lean b/Complexity/DataStructure/Memory/Spec.lean new file mode 100644 index 0000000000..3507072aee --- /dev/null +++ b/Complexity/DataStructure/Memory/Spec.lean @@ -0,0 +1,258 @@ +/- +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.WordRAM.Heap +public import Complexity.DataStructure.StateTransition + +/-! +# Word-addressed memory as a state-transition specification + +`Memory.spec w` is a memory oracle: the interface through which a data-structure implementation +reaches storage. Its state is the contents of every cell together with an allocation frontier. +Every address below the frontier is allocated, and allocation hands out the block that starts at +the frontier. The operations read a cell, write a cell, and allocate a block, either zeroed +(`alloc`, charged per cell) or with its old contents (`allocDirty`, charged one unit). + +Admissibility carries the preconditions a word RAM needs. Accessed addresses must be allocated, +written values must fit a `w`-bit word, and the frontier after an allocation must fit. Under +these preconditions the frontier and every cell keep fitting a word (`WellFormed.step`), so an +allocated address fits too (`WellFormed.fits_of_lt_frontier`). + +An implementation over this interface is an ordinary `Memory.Prog` program. Its correctness and +its operation charges are proved against `step` and `charge`, without registers or instruction +counts. `charge` is the memory-level currency; executing such a program on the word RAM is a +separate step that exchanges it into instructions. Allocation never reuses addresses, as in +`Cslib.WordRAM.alloc`, so blocks allocated at different times are disjoint +(`Cslib.WordRAM.Block.disjoint_of_le`). A program reuses memory by keeping a block it allocated. + +## Main definitions + +* `Memory.State`, `Memory.Op`, `Memory.step`, `Memory.valid`: cells and frontier, operations + with their answers, the transition function and the admissibility preconditions. +* `Memory.spec`: the deterministic specification at word size `w`. +* `Memory.charge`: one unit per read, write and dirty allocation; `k + 1` for a zeroed block of + `k` cells. +* `Memory.Prog`, `Memory.read`, `Memory.write`, `Memory.alloc`, `Memory.allocDirty`: programs + over the oracle and its four one-call programs. +* `Memory.WellFormed`: the frontier and all cell contents fit a `w`-bit word. +* `Memory.State.init`: the word RAM's input convention as a memory state. + +## Main results + +* `Memory.WellFormed.step`, `Memory.WellFormed.run`: admissible operations preserve + well-formedness. +* `Memory.WellFormed.fits_of_lt_frontier`: allocated addresses fit a word. +* `Memory.frontier_le_step`, `Memory.frontier_le_run`: the frontier never decreases. +* `Memory.mem_step_of_lt_frontier`: an operation changes an allocated cell only by writing it. +* `Memory.wellFormed_init`: the input convention is well formed. +-/ + +@[expose] public section + +namespace Cslib.DataStructure.Memory + +open Cslib.WordRAM + +/-- Memory: the contents of every cell, and the frontier below which cells are allocated. -/ +@[ext] +structure State where + /-- The contents of the cell at each address. -/ + mem : ℕ → ℕ + /-- Every address below the frontier is allocated; the next block starts here. -/ + frontier : ℕ + +/-- Operations on memory. Addresses are words computed by the caller. -/ +inductive Op where + /-- Read the cell at an address. -/ + | read (addr : ℕ) + /-- Write a value to the cell at an address. -/ + | write (addr value : ℕ) + /-- Allocate `count` zeroed cells at the frontier and return their base address. -/ + | alloc (count : ℕ) + /-- Allocate `count` cells at the frontier without clearing them and return their base + address. -/ + | allocDirty (count : ℕ) + deriving DecidableEq + +/-- The answer type of each operation: a read and an allocation return a word. -/ +abbrev Op.Result : Op → Type + | .read _ => ℕ + | .write _ _ => Unit + | .alloc _ => ℕ + | .allocDirty _ => ℕ + +/-- The transition of each operation. An allocation returns the old frontier. -/ +def step (s : State) : (o : Op) → State × o.Result + | .read a => (s, s.mem a) + | .write a v => (⟨Function.update s.mem a v, s.frontier⟩, ()) + | .alloc k => (⟨clear s.mem s.frontier k, s.frontier + k⟩, s.frontier) + | .allocDirty k => (⟨s.mem, s.frontier + k⟩, s.frontier) + +/-- Admissibility at word size `w`: accessed addresses are allocated, written values fit a word, +and an allocation leaves a fitting frontier. -/ +def valid (w : ℕ) (s : State) : Op → Prop + | .read a => a < s.frontier + | .write a v => a < s.frontier ∧ Fits w v + | .alloc k => Fits w (s.frontier + k) + | .allocDirty k => Fits w (s.frontier + k) + +instance (w : ℕ) (s : State) (o : Op) : Decidable (valid w s o) := by + cases o <;> unfold valid <;> infer_instance + +/-- Word-addressed memory at word size `w`. -/ +abbrev spec (w : ℕ) : StateTransitionSpec := + StateTransitionSpec.ofFn (State := State) (Op := Op) (Result := Op.Result) step (valid w) + +/-- The memory-level currency: one unit per read, write and dirty allocation, and `k + 1` units +for a zeroed block of `k` cells. -/ +def charge (_ : State) : Op → ℕ + | .alloc k => k + 1 + | _ => 1 + +/-- Programs over the memory oracle. They are the clients of `Memory.spec w` at every word size. -/ +abbrev Prog (α : Type) : Type := PFunctor.FreeM ⟨Op, Op.Result⟩ α + +/-- Read the cell at address `a`. -/ +abbrev read (a : ℕ) : Prog ℕ := PFunctor.FreeM.lift (P := ⟨Op, Op.Result⟩) (.read a) + +/-- Write `v` to the cell at address `a`. -/ +abbrev write (a v : ℕ) : Prog Unit := PFunctor.FreeM.lift (P := ⟨Op, Op.Result⟩) (.write a v) + +/-- Allocate `k` zeroed cells and return their base address. -/ +abbrev alloc (k : ℕ) : Prog ℕ := PFunctor.FreeM.lift (P := ⟨Op, Op.Result⟩) (.alloc k) + +/-- Allocate `k` cells without clearing them and return their base address. -/ +abbrev allocDirty (k : ℕ) : Prog ℕ := + PFunctor.FreeM.lift (P := ⟨Op, Op.Result⟩) (.allocDirty k) + +@[simp] theorem step_read (s : State) (a : ℕ) : step s (.read a) = (s, s.mem a) := rfl + +@[simp] theorem step_write (s : State) (a v : ℕ) : + step s (.write a v) = (⟨Function.update s.mem a v, s.frontier⟩, ()) := rfl + +@[simp] theorem step_alloc (s : State) (k : ℕ) : + step s (.alloc k) = (⟨clear s.mem s.frontier k, s.frontier + k⟩, s.frontier) := rfl + +@[simp] theorem step_allocDirty (s : State) (k : ℕ) : + step s (.allocDirty k) = (⟨s.mem, s.frontier + k⟩, s.frontier) := rfl + +@[simp] theorem valid_read (w : ℕ) (s : State) (a : ℕ) : valid w s (.read a) ↔ a < s.frontier := + Iff.rfl + +@[simp] theorem valid_write (w : ℕ) (s : State) (a v : ℕ) : + valid w s (.write a v) ↔ a < s.frontier ∧ Fits w v := Iff.rfl + +@[simp] theorem valid_alloc (w : ℕ) (s : State) (k : ℕ) : + valid w s (.alloc k) ↔ Fits w (s.frontier + k) := Iff.rfl + +@[simp] theorem valid_allocDirty (w : ℕ) (s : State) (k : ℕ) : + valid w s (.allocDirty k) ↔ Fits w (s.frontier + k) := Iff.rfl + +@[simp] theorem charge_read (s : State) (a : ℕ) : charge s (.read a) = 1 := rfl + +@[simp] theorem charge_write (s : State) (a v : ℕ) : charge s (.write a v) = 1 := rfl + +@[simp] theorem charge_alloc (s : State) (k : ℕ) : charge s (.alloc k) = k + 1 := rfl + +@[simp] theorem charge_allocDirty (s : State) (k : ℕ) : charge s (.allocDirty k) = 1 := rfl + +/-- Admissibility of a concrete history is decidable. -/ +instance decidableValidHistory (w : ℕ) (s : State) (os : List Op) : + Decidable ((spec w).ValidHistory s os) := by + induction os generalizing s with + | nil => exact isTrue trivial + | cons o os ih => + exact decidable_of_iff (valid w s o ∧ (spec w).ValidHistory (step s o).1 os) Iff.rfl + +/-! ## Frontier and frame -/ + +/-- No operation lowers the frontier. -/ +theorem frontier_le_step (s : State) (o : Op) : s.frontier ≤ (step s o).1.frontier := by + cases o <;> simp + +/-- No sequence of operations lowers the frontier. -/ +theorem frontier_le_run {w : ℕ} (s : State) (os : List Op) : + s.frontier ≤ ((spec w).run s os).1.frontier := by + induction os generalizing s with + | nil => exact le_rfl + | cons o os ih => exact (frontier_le_step s o).trans (ih _) + +/-- An operation changes an allocated cell only by writing to it. Allocation clears cells at or +above the frontier only. -/ +theorem mem_step_of_lt_frontier (s : State) (o : Op) {a : ℕ} (ha : a < s.frontier) + (hw : ∀ v, o ≠ .write a v) : (step s o).1.mem a = s.mem a := by + cases o with + | read => rfl + | write b v => + have hab : a ≠ b := fun h => hw v (h ▸ rfl) + exact Function.update_of_ne hab v s.mem + | alloc k => exact clear_of_not_owns (by simp only [Block.Owns]; omega) + | allocDirty => rfl + +/-! ## Word fit -/ + +/-- The frontier and every cell fit a `w`-bit word. Admissible operations preserve this. -/ +structure WellFormed (w : ℕ) (s : State) : Prop where + /-- The frontier fits a word, hence so does every allocated address. -/ + frontier_fits : Fits w s.frontier + /-- Every cell holds a word. -/ + mem_fits : ∀ a, Fits w (s.mem a) + +/-- Allocated addresses fit a word. -/ +theorem WellFormed.fits_of_lt_frontier {w : ℕ} {s : State} (h : WellFormed w s) {a : ℕ} + (ha : a < s.frontier) : Fits w a := + h.frontier_fits.of_le ha.le + +/-- Admissible operations preserve well-formedness. -/ +theorem WellFormed.step {w : ℕ} {s : State} (h : WellFormed w s) {o : Op} (hv : valid w s o) : + WellFormed w (Memory.step s o).1 := by + cases o with + | read => exact h + | write a v => + refine ⟨h.frontier_fits, fun b => ?_⟩ + by_cases hb : b = a + · subst hb + simpa using hv.2 + · simpa [Function.update_of_ne hb] using h.mem_fits b + | alloc k => + refine ⟨hv, fun b => ?_⟩ + simp only [step_alloc, clear] + split + · exact fits_zero w + · exact h.mem_fits b + | allocDirty k => exact ⟨hv, h.mem_fits⟩ + +/-- Admissible histories preserve well-formedness. -/ +theorem WellFormed.run {w : ℕ} {s : State} (h : WellFormed w s) {os : List Op} + (hv : (spec w).ValidHistory s os) : WellFormed w ((spec w).run s os).1 := by + induction os generalizing s with + | nil => exact h + | cons o os ih => exact ih (h.step hv.1) hv.2 + +/-! ## The input convention -/ + +/-- The word RAM's input convention (`Cslib.WordRAM.Data.init`) as a memory state: the input +length at address `0`, the input words at addresses `1, …, n`, and everything up to the input +allocated. -/ +def State.init (input : List ℕ) : State := + ⟨(Data.init (r := 0) input).mem, input.length + 1⟩ + +/-- The input convention is well formed when the input and its frontier fit a word. -/ +theorem wellFormed_init {w : ℕ} {input : List ℕ} (hin : InputFits w input) + (hf : Fits w (input.length + 1)) : WellFormed w (State.init input) := by + refine ⟨hf, fun a => ?_⟩ + change Fits w (if a = 0 then input.length else input.getD (a - 1) 0) + split + · exact hin.1 + · rw [List.getD_eq_getElem?_getD] + cases hi : input[a - 1]? with + | none => exact fits_zero w + | some v => exact hin.2 v (List.mem_of_getElem? hi) + +end Cslib.DataStructure.Memory diff --git a/ComplexityTests/DataStructureMemory.lean b/ComplexityTests/DataStructureMemory.lean new file mode 100644 index 0000000000..01791c6332 --- /dev/null +++ b/ComplexityTests/DataStructureMemory.lean @@ -0,0 +1,117 @@ +/- +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.Memory.Field + +/-! +# Memory-oracle programs: named fields, pointer chasing and block reuse + +A singly linked list is stored as a struct of arrays with a `key` field and a `next` field; +pointers are indices, with `0` as null. The tests allocate the layout, build a two-node list, +chase pointers to sum the keys, and reuse one scratch block across two rounds. They check the +answers, the operation histories and charges, admissibility at an 8-bit word size, and two +rejected operations: a read above the frontier and a write of an oversized value. +-/ + +@[expose] public section + +namespace ComplexityTests.DataStructureMemory + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.Memory + +/-- A linked-list node store as a struct of arrays. -/ +structure Nodes where + /-- The key of each node. -/ + key : Block + /-- The successor of each node, as an index; `0` is null. -/ + next : Block + +/-- Allocate both fields for `n` nodes. -/ +def Nodes.alloc (n : ℕ) : Prog Nodes := do + let key ← allocBlock n + let next ← allocBlock n + pure ⟨key, next⟩ + +/-- Follow at most `fuel` successors from node `v`, summing keys. Every address is computed from +an answer: the next node is read from memory. -/ +def Nodes.sumFrom (L : Nodes) : ℕ → ℕ → Prog ℕ + | 0, _ => pure 0 + | fuel + 1, v => do + let k ← L.key.get v + let nxt ← L.next.get v + if nxt = 0 then pure k else do + let rest ← L.sumFrom fuel nxt + pure (k + rest) + +/-- Build the list `1 → 2` with keys `5` and `7` (node `0` is reserved as null), then sum it. -/ +def linkedSum : Prog ℕ := do + let L ← Nodes.alloc 3 + L.key.set 1 5 + L.key.set 2 7 + L.next.set 1 2 + L.sumFrom 3 1 + +/-- The empty memory with nothing allocated. -/ +def empty : State := ⟨fun _ => 0, 0⟩ + +example : (spec 8).clientResult empty linkedSum = 12 := by decide + +/-- The history: two zeroed allocations, three writes and four reads by pointer chasing. -/ +example : (spec 8).clientHistory empty linkedSum = + [.alloc 3, .alloc 3, .write 1 5, .write 2 7, .write 4 2, + .read 1, .read 4, .read 2, .read 5] := by decide + +/-- The two zeroed allocations of three cells cost four each; seven unit operations follow. -/ +example : (spec 8).totalCost charge empty ((spec 8).clientHistory empty linkedSum) = 15 := by + decide + +/-- Every operation is admissible at an 8-bit word size. -/ +example : (spec 8).ValidHistory empty ((spec 8).clientHistory empty linkedSum) := by decide + +/-- One scratch block, allocated without clearing, is reused across two rounds. -/ +def reuse : Prog (ℕ × ℕ) := do + let scratch ← allocBlockDirty 1 + scratch.set 0 3 + let first ← scratch.get 0 + scratch.set 0 (first + 4) + let second ← scratch.get 0 + pure (first, second) + +example : (spec 8).clientResult empty reuse = (3, 7) := by decide + +example : ((spec 8).clientState empty reuse).frontier = 1 := by decide + +example : (spec 8).totalCost charge empty ((spec 8).clientHistory empty reuse) = 5 := by decide + +/-- A read above the frontier is rejected. -/ +example : ¬(spec 8).ValidHistory empty [.read 0] := by decide + +/-- A write of a value wider than the word is rejected, even at an allocated address. -/ +example : ¬(spec 8).ValidHistory ⟨fun _ => 0, 1⟩ [.write 0 256] := by decide + +/-- An allocation whose end does not fit the word is rejected. -/ +example : ¬(spec 8).ValidHistory empty [.alloc 256] := by decide + +/-- Well-formedness survives the pointer-chasing program. -/ +example : WellFormed 8 ((spec 8).clientState empty linkedSum) := by + have h : WellFormed 8 empty := ⟨by decide, fun _ => fits_zero 8⟩ + rw [← (spec 8).run_runClient] + exact h.run (by decide) + +/-- The input convention: the length at address `0`, the words from address `1`, and the +frontier just past them. -/ +example : (spec 8).clientResult (State.init [4, 9]) (do + let n ← read 0 + let x ← read 2 + pure (n, x)) = (2, 9) := by decide + +/-- The list view reads the live prefix of a field. -/ +example : (Block.mk 1 3).entries 2 (fun a => a * 10) = [10, 20] := by decide + +end ComplexityTests.DataStructureMemory From 412f614dacfeba6565117ed6b5eb8f586b7d0888 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:16:21 -0500 Subject: [PATCH 02/18] =?UTF-8?q?doc(bib):=20add=20Gu=C3=A9neau,=20Chargu?= =?UTF-8?q?=C3=A9raud=20and=20Pottier=20(ESOP=202018)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- references.bib | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/references.bib b/references.bib index e33942d5a5..0b4758dbf6 100644 --- a/references.bib +++ b/references.bib @@ -2303,6 +2303,18 @@ @inproceedings{Grover1996 doi = {10.1145/237814.237866} } +@inproceedings{GueneauChargueraudPottier2018, + author = {Gu{\'e}neau, Arma{\"e}l and Chargu{\'e}raud, Arthur and Pottier, Fran{\c{c}}ois}, + title = {A Fistful of Dollars: Formalizing Asymptotic Complexity Claims via Deductive + Program Verification}, + booktitle = {Programming Languages and Systems (ESOP 2018)}, + series = {Lecture Notes in Computer Science}, + pages = {533--560}, + publisher = {Springer}, + year = {2018}, + doi = {10.1007/978-3-319-89884-1_19} +} + @inproceedings{GuoKoppartySudan2013, author = {Guo, Alan and Kopparty, Swastik and Sudan, Madhu}, title = {New affine-invariant codes from lifting}, From 16a647fee63724bc26032a05d4bbf7a682232e1f Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:16:21 -0500 Subject: [PATCH 03/18] feat(DataStructure/StateTransition): refinements by abstraction functions with stacked potentials Refinement D E is a Module whose representation is an invariant plus an abstraction function (#2205 D2). Refinement.Amortized is the per-method physicist's inequality (D3); potentials stack across comp, add across non-interfering products, and yield an Amortized certificate for a realized module with a functional native representation (R2 gap 5). CostIsBigO is the exported asymptotic form (D6). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity.lean | 2 + .../StateTransition/Refinement.lean | 384 ++++++++++++++++++ .../Analysis/Asymptotics/CostBound.lean | 81 ++++ .../StateTransitionRefinement.lean | 143 +++++++ 4 files changed, 610 insertions(+) create mode 100644 Complexity/DataStructure/StateTransition/Refinement.lean create mode 100644 Complexity/Foundations/Analysis/Asymptotics/CostBound.lean create mode 100644 ComplexityTests/StateTransitionRefinement.lean diff --git a/Complexity.lean b/Complexity.lean index 7f9a77746d..9c6c1c30b9 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -2921,6 +2921,7 @@ public import Complexity.DataStructure.StateTransition.CostHoare public import Complexity.DataStructure.StateTransition.Hoare public import Complexity.DataStructure.StateTransition.Impl public import Complexity.DataStructure.StateTransition.Module +public import Complexity.DataStructure.StateTransition.Refinement public import Complexity.DataStructure.StateTransition.Resource public import Complexity.DataStructure.VanEmdeBoas.Basic public import Complexity.DataStructure.VanEmdeBoas.Elements @@ -2944,6 +2945,7 @@ public import Complexity.DataStructure.WordRAM.StateTransition public import Complexity.Foundations.Algebra.FiniteMagnitude public import Complexity.Foundations.Algebra.GeometricTail 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.ENNRealTsum diff --git a/Complexity/DataStructure/StateTransition/Refinement.lean b/Complexity/DataStructure/StateTransition/Refinement.lean new file mode 100644 index 0000000000..a70028a61c --- /dev/null +++ b/Complexity/DataStructure/StateTransition/Refinement.lean @@ -0,0 +1,384 @@ +/- +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.StateTransition.Amortized +public import Complexity.DataStructure.StateTransition.CostHoare + +/-! +# Refinements by abstraction functions and stacked potentials + +A `Refinement D E` is a `Module D E` whose representation is single-valued: an implementation +invariant on lower states together with an abstraction function `abs : E.State → D.State`. Each +method, run from a lower state satisfying the invariant, must realize the specified step at the +abstract state, ending in a state satisfying the invariant. On deterministic specifications +(`Refinement.ofFn`) the obligation reads `D.stepFn (abs e) o = (abs e', a)`. + +A single-valued representation is what makes amortized costs compose. `Refinement.Amortized` +asks that every method satisfy the physicist's inequality +`lower cost + potential e' ≤ upper (abs e) o + potential e`, with a potential on lower states. +Composing two refinements adds their potentials, the upper one read through the lower +abstraction (`Refinement.Amortized.comp`). A relational representation would leave the +intermediate state existential, and the composed potential would not be a function of the lower +state. For the same reason an amortized refinement over a native implementation whose +representation is functional yields an `Amortized` certificate of the realized module +(`Refinement.Amortized.realize`). + +Products of refinements over one lower interface (`Refinement.prod`) need non-interference: the +methods of each side leave the other side's abstraction, invariant and potential unchanged. + +## Main definitions + +* `Refinement`: a module given by methods, an implementation invariant and an abstraction + function. +* `Refinement.ofFn`: the constructor for deterministic specifications. +* `Refinement.toModule`: the underlying relational module. +* `Refinement.id`, `Refinement.comp`, `Refinement.prod`: identity, composition, and products under + non-interference. +* `Refinement.Amortized`: per-method amortized cost refinement with a potential on lower states. +* `productCharge`: componentwise charges of a product specification. + +## Main results + +* `Refinement.simulates_demonic`, `Refinement.simulates_client`: whole adaptive clients run + through the abstraction function. +* `Refinement.comp_rep_iff`: composition agrees with `Module.comp` of the underlying modules. +* `Refinement.Amortized.demonic`, `Refinement.Amortized.client`: potentials telescope along + adaptive clients. +* `Refinement.Amortized.comp`: potentials stack across composition. +* `Refinement.Amortized.prod`: potentials add across non-interfering products. +* `Refinement.Amortized.realize`: an amortized certificate for the realized module. +* `Refinement.Amortized.id`: the identity refinement passes charges through. +* `Refinement.Amortized.chargeBound`, `Refinement.Amortized.of_chargeBound`: with zero + potential, the existing worst-case `Module.ChargeBound`. + +## References + +* [Cormen, Leiserson, Rivest and Stein, *Introduction to Algorithms*, Chapter 17][CLRS2009]. +-/ + +@[expose] public section + +namespace Cslib.DataStructure + +universe u v w x + +variable {D E F D₁ D₂ : StateTransitionSpec.{u, v, w}} {α : Type w} + +/-- A module whose representation is an implementation invariant `inv` together with an +abstraction function `abs`. From a lower state satisfying `inv`, every run of a method on an +admissible operation realizes a permitted step of the abstract state and preserves `inv`. -/ +structure Refinement (D E : StateTransitionSpec.{u, v, w}) where + /-- Bodies implementing the upper interface using lower-interface calls. -/ + methods : Methods D E + /-- The implementation invariant on lower states. -/ + inv : E.State → Prop + /-- The abstraction function from lower states to upper states. -/ + abs : E.State → D.State + /-- Each method is demonically admissible from a state satisfying the invariant. -/ + valid : ∀ {e} o, inv e → D.valid (abs e) o → E.DemonicValid e (methods o) + /-- Each method run realizes the specified step through `abs` and preserves `inv`. -/ + correct : ∀ {e} o {a e' tr}, inv e → D.valid (abs e) o → + E.ClientRun e (methods o) a e' tr → D.step (abs e) o (abs e') a ∧ inv e' + +namespace Refinement + +/-- The constructor for deterministic specifications: each method's history is admissible, and +`D.stepFn (abs e) o = (abs e', a)` for its final state `e'` and result `a`. -/ +abbrev ofFn {fD : (s : D.State) → (o : D.Op) → D.State × D.Result o} + {fE : (e : E.State) → (o : E.Op) → E.State × E.Result o} + [D.HasStepFn fD] [E.HasStepFn fE] + (methods : Methods D E) (inv : E.State → Prop) (abs : E.State → D.State) + (valid : ∀ {e} o, inv e → D.valid (abs e) o → + E.ValidHistory e (E.clientHistory e (methods o))) + (correct : ∀ {e} o, inv e → D.valid (abs e) o → + D.stepFn (abs e) o = (abs (E.clientState e (methods o)), E.clientResult e (methods o)) ∧ + inv (E.clientState e (methods o))) : + Refinement D E where + methods := methods + inv := inv + abs := abs + valid o hi hv := (E.demonicValid_iff_validHistory_runClient _ _).mpr (valid o hi hv) + correct {e} o {a e' tr} hi hv hrun := by + obtain ⟨_, rfl, rfl, _⟩ := (E.clientRun_iff_runClient e (methods o) a e' tr).mp hrun + obtain ⟨hstep, hi'⟩ := correct o hi hv + exact ⟨(D.step_iff_stepFn _ _ _ _).mpr hstep.symm, hi'⟩ + +variable (M : Refinement D E) + +/-- The underlying relational module: `s` is represented by `e` when `e` satisfies the invariant +and abstracts to `s`. -/ +def toModule : Module D E where + methods := M.methods + rep s e := M.inv e ∧ M.abs e = s + valid {_ _} o hr hv := by + obtain ⟨hi, rfl⟩ := hr + exact M.valid o hi hv + correct {_ _} o {_ _ _} hr hv hrun := by + obtain ⟨hi, rfl⟩ := hr + obtain ⟨hstep, hi'⟩ := M.correct o hi hv hrun + exact ⟨_, hstep, hi', rfl⟩ + +/-- Every run of a linked admissible client corresponds to a run of the client at the abstract +state, ending at the abstraction of the final lower state. -/ +theorem simulates_demonic (p : D.Client α) {e : E.State} (he : M.inv e) + (hv : D.DemonicValid (M.abs e) p) : + E.DemonicValid e (link M.methods p) ∧ + ∀ a e' tr_E, E.ClientRun e (link M.methods p) a e' tr_E → + M.inv e' ∧ ∃ tr_D, D.ClientRun (M.abs e) p a (M.abs e') tr_D := by + obtain ⟨hvE, hrun⟩ := M.toModule.simulates_demonic p ⟨he, rfl⟩ hv + refine ⟨hvE, fun a e' tr hr => ?_⟩ + obtain ⟨_, tr_D, hD, hi', rfl⟩ := hrun a e' tr hr + exact ⟨hi', tr_D, hD⟩ + +/-- On deterministic specifications, a linked client returns the specified result, and its final +lower state satisfies the invariant and abstracts to the specified final state. -/ +theorem simulates_client {fD : (s : D.State) → (o : D.Op) → D.State × D.Result o} + {fE : (e : E.State) → (o : E.Op) → E.State × E.Result o} + [D.HasStepFn fD] [E.HasStepFn fE] (p : D.Client α) {e : E.State} (he : M.inv e) + (hv : D.ValidHistory (M.abs e) (D.clientHistory (M.abs e) p)) : + E.ValidHistory e (E.clientHistory e (link M.methods p)) ∧ + E.clientResult e (link M.methods p) = D.clientResult (M.abs e) p ∧ + M.abs (E.clientState e (link M.methods p)) = D.clientState (M.abs e) p ∧ + M.inv (E.clientState e (link M.methods p)) := by + obtain ⟨hvE, hres, hi, hs⟩ := M.toModule.simulates_client p ⟨he, rfl⟩ hv + exact ⟨hvE, hres, hs, hi⟩ + +/-- The identity refinement: each operation calls itself, with no invariant. -/ +def id (D : StateTransitionSpec.{u, v, w}) : Refinement D D where + methods o := .liftBind o fun a => .pure a + inv _ := True + abs e := e + valid o _ hv := .liftBind o _ hv fun s' a _ => .pure s' a + correct {_} o {_ _ _} _ _ hrun := by + cases hrun with + | liftBind _ _ a _ hstep hrest => + cases hrest + exact ⟨hstep, trivial⟩ + +/-- Composition: the upper methods are linked through the lower ones, the invariants conjoin, +and the abstraction functions compose. -/ +def comp (M : Refinement D E) (N : Refinement E F) : Refinement D F where + methods o := link N.methods (M.methods o) + inv f := N.inv f ∧ M.inv (N.abs f) + abs f := M.abs (N.abs f) + valid o hi hv := (N.simulates_demonic (M.methods o) hi.1 (M.valid o hi.2 hv)).1 + correct {_} o {a f' tr} hi hv hrun := by + obtain ⟨hN', _, hE⟩ := + (N.simulates_demonic (M.methods o) hi.1 (M.valid o hi.2 hv)).2 a f' tr hrun + obtain ⟨hstep, hM'⟩ := M.correct o hi.2 hv hE + exact ⟨hstep, hN', hM'⟩ + +/-- Composing refinements represents the same states as composing their modules. -/ +theorem comp_rep_iff (M : Refinement D E) (N : Refinement E F) (s : D.State) (f : F.State) : + (M.comp N).toModule.rep s f ↔ (M.toModule.comp N.toModule).rep s f := by + constructor + · rintro ⟨⟨hN, hM⟩, rfl⟩ + exact ⟨_, ⟨hM, rfl⟩, hN, rfl⟩ + · rintro ⟨_, ⟨hM, rfl⟩, hN, rfl⟩ + exact ⟨⟨hN, hM⟩, rfl⟩ + +/-- Linking through a composition links through each refinement in turn. -/ +theorem link_comp (M : Refinement D E) (N : Refinement E F) (p : D.Client α) : + link (M.comp N).methods p = link N.methods (link M.methods p) := + (DataStructure.link_comp M.methods N.methods p).symm + +/-- Two refinements over one lower interface implement the product of their specifications, +provided the methods of each leave the other's abstraction and invariant unchanged. -/ +def prod (M₁ : Refinement D₁ E) (M₂ : Refinement D₂ E) + (frame₁ : ∀ {e} o {a e' tr}, M₁.inv e → M₂.inv e → D₁.valid (M₁.abs e) o → + E.ClientRun e (M₁.methods o) a e' tr → M₂.abs e' = M₂.abs e ∧ M₂.inv e') + (frame₂ : ∀ {e} o {a e' tr}, M₁.inv e → M₂.inv e → D₂.valid (M₂.abs e) o → + E.ClientRun e (M₂.methods o) a e' tr → M₁.abs e' = M₁.abs e ∧ M₁.inv e') : + Refinement (product D₁ D₂) E where + methods + | .inl o => M₁.methods o + | .inr o => M₂.methods o + inv e := M₁.inv e ∧ M₂.inv e + abs e := (M₁.abs e, M₂.abs e) + valid {_} o hi hv := by + cases o with + | inl o => exact M₁.valid o hi.1 hv + | inr o => exact M₂.valid o hi.2 hv + correct {_} o {_ _ _} hi hv hrun := by + cases o with + | inl o => + obtain ⟨hstep, hi₁⟩ := M₁.correct o hi.1 hv hrun + obtain ⟨habs, hi₂⟩ := frame₁ o hi.1 hi.2 hv hrun + exact ⟨⟨hstep, habs⟩, hi₁, hi₂⟩ + | inr o => + obtain ⟨hstep, hi₂⟩ := M₂.correct o hi.2 hv hrun + obtain ⟨habs, hi₁⟩ := frame₂ o hi.1 hi.2 hv hrun + exact ⟨⟨habs, hstep⟩, hi₁, hi₂⟩ + +/-! ## Amortized costs -/ + +/-- Amortized cost refinement: the lower charges of every method run, plus the potential after it, +are at most the upper charge of the operation plus the potential before it. Potentials are +natural numbers, hence nonnegative; a client bound subtracts nothing when the initial potential +is zero. -/ +def Amortized (lower : E.State → E.Op → ℕ) (upper : D.State → D.Op → ℕ) + (potential : E.State → ℕ) : Prop := + ∀ {e} o {a e' tr}, M.inv e → D.valid (M.abs e) o → E.ClientRun e (M.methods o) a e' tr → + E.totalCostTranscript lower e tr + potential e' ≤ upper (M.abs e) o + potential e + +variable {M} {lower : E.State → E.Op → ℕ} {upper : D.State → D.Op → ℕ} + {potential : E.State → ℕ} + +/-- The amortized inequality on a deterministic lower specification, along each method's +history. -/ +theorem Amortized.ofFn {fE : (e : E.State) → (o : E.Op) → E.State × E.Result o} + [E.HasStepFn fE] + (h : ∀ {e} o, M.inv e → D.valid (M.abs e) o → + E.totalCost lower e (E.clientHistory e (M.methods o)) + + potential (E.clientState e (M.methods o)) ≤ + upper (M.abs e) o + potential e) : + M.Amortized lower upper potential := by + intro e o a e' tr hi hv hrun + obtain ⟨_, _, rfl, rfl⟩ := (E.clientRun_iff_runClient e (M.methods o) a e' tr).mp hrun + rw [E.totalCostTranscript_canonicalTranscript] + exact h o hi hv + +/-- Potentials telescope along any run of a linked admissible client. -/ +theorem Amortized.demonic (A : M.Amortized lower upper potential) (p : D.Client α) + {e e' : E.State} {a : α} {tr_E : E.Transcript} (he : M.inv e) + (hv : D.DemonicValid (M.abs e) p) (hrun : E.ClientRun e (link M.methods p) a e' tr_E) : + M.inv e' ∧ ∃ tr_D, D.ClientRun (M.abs e) p a (M.abs e') tr_D ∧ + E.totalCostTranscript lower e tr_E + potential e' ≤ + D.totalCostTranscript upper (M.abs e) tr_D + potential e := by + induction p generalizing e tr_E with + | pure b => + cases hrun + exact ⟨he, [], .pure _ _, by simp⟩ + | 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 ⟨res, e₁, tr₁, tr₂, hrun₁, hrun₂, rfl⟩ := E.clientRun_bind_iff.mp hrun + obtain ⟨hstep₁, he₁⟩ := M.correct o he hv_o hrun₁ + have hc₁ := A o he hv_o hrun₁ + obtain ⟨he₂, tr_D, hrun_D, hc₂⟩ := ih res he₁ (hv_k _ res hstep₁) hrun₂ + refine ⟨he₂, ⟨o, res, M.abs e₁⟩ :: tr_D, .liftBind o k res hv_o hstep₁ hrun_D, ?_⟩ + rw [E.totalCostTranscript_append lower hrun₁.validTranscript tr₂] + simp only [StateTransitionSpec.totalCostTranscript_cons] + omega + +/-- On deterministic specifications, the lower charges of a linked client plus the final +potential are at most the upper charges of its history plus the initial potential. -/ +theorem Amortized.client {fD : (s : D.State) → (o : D.Op) → D.State × D.Result o} + {fE : (e : E.State) → (o : E.Op) → E.State × E.Result o} + [D.HasStepFn fD] [E.HasStepFn fE] (A : M.Amortized lower upper potential) + (p : D.Client α) {e : E.State} (he : M.inv e) + (hv : D.ValidHistory (M.abs e) (D.clientHistory (M.abs e) p)) : + E.totalCost lower e (E.clientHistory e (link M.methods p)) + + potential (E.clientState e (link M.methods p)) ≤ + D.totalCost upper (M.abs e) (D.clientHistory (M.abs e) p) + potential e := by + have hvD := (D.demonicValid_iff_validHistory_runClient _ p).mpr hv + have hvE := (M.simulates_client p he hv).1 + obtain ⟨_, tr_D, hrun_D, hcost⟩ := A.demonic p he hvD (E.clientRun_canonical e _ hvE) + obtain ⟨_, _, _, rfl⟩ := (D.clientRun_iff_runClient _ p _ _ tr_D).mp hrun_D + simpa only [StateTransitionSpec.totalCostTranscript_canonicalTranscript] using hcost + +/-- **Potentials stack across composition.** If the upper refinement is amortized against the +middle charges and the lower refinement is amortized from the middle charges, the composite is +amortized with the sum of the upper potential, read through the lower abstraction, and the +lower potential. -/ +theorem Amortized.comp {N : Refinement E F} {lower : F.State → F.Op → ℕ} + {middle : E.State → E.Op → ℕ} {Φ : E.State → ℕ} {Ψ : F.State → ℕ} + (A : M.Amortized middle upper Φ) (B : N.Amortized lower middle Ψ) : + (M.comp N).Amortized lower upper (fun f => Φ (N.abs f) + Ψ f) := by + intro f o a f' tr hi hv hrun + obtain ⟨_, tr_E, hrun_E, hN⟩ := B.demonic (M.methods o) hi.1 (M.valid o hi.2 hv) hrun + have hM := A o hi.2 hv hrun_E + change F.totalCostTranscript lower f tr + (Φ (N.abs f') + Ψ f') ≤ + upper (M.abs (N.abs f)) o + (Φ (N.abs f) + Ψ f) + omega + +/-- Componentwise charges of a product specification. -/ +def productCharge (c₁ : D₁.State → D₁.Op → ℕ) (c₂ : D₂.State → D₂.Op → ℕ) : + (product D₁ D₂).State → (product D₁ D₂).Op → ℕ + | (s₁, _), .inl o => c₁ s₁ o + | (_, s₂), .inr o => c₂ s₂ o + +/-- **Potentials add across non-interfering products**, provided the methods of each side leave +the other side's potential unchanged. -/ +theorem Amortized.prod {M₁ : Refinement D₁ E} {M₂ : Refinement D₂ E} + {frame₁ : ∀ {e} o {a e' tr}, M₁.inv e → M₂.inv e → D₁.valid (M₁.abs e) o → + E.ClientRun e (M₁.methods o) a e' tr → M₂.abs e' = M₂.abs e ∧ M₂.inv e'} + {frame₂ : ∀ {e} o {a e' tr}, M₁.inv e → M₂.inv e → D₂.valid (M₂.abs e) o → + E.ClientRun e (M₂.methods o) a e' tr → M₁.abs e' = M₁.abs e ∧ M₁.inv e'} + {upper₁ : D₁.State → D₁.Op → ℕ} {upper₂ : D₂.State → D₂.Op → ℕ} + {Φ₁ Φ₂ : E.State → ℕ} + (A₁ : M₁.Amortized lower upper₁ Φ₁) (A₂ : M₂.Amortized lower upper₂ Φ₂) + (potential₁ : ∀ {e} o {a e' tr}, M₁.inv e → M₂.inv e → D₁.valid (M₁.abs e) o → + E.ClientRun e (M₁.methods o) a e' tr → Φ₂ e' = Φ₂ e) + (potential₂ : ∀ {e} o {a e' tr}, M₁.inv e → M₂.inv e → D₂.valid (M₂.abs e) o → + E.ClientRun e (M₂.methods o) a e' tr → Φ₁ e' = Φ₁ e) : + (M₁.prod M₂ frame₁ frame₂).Amortized lower (productCharge upper₁ upper₂) + (fun e => Φ₁ e + Φ₂ e) := by + intro e o a e' tr hi hv hrun + cases o with + | inl o => + have h := A₁ o hi.1 hv hrun + have hΦ := potential₁ o hi.1 hi.2 hv hrun + change E.totalCostTranscript lower e tr + (Φ₁ e' + Φ₂ e') ≤ + upper₁ (M₁.abs e) o + (Φ₁ e + Φ₂ e) + omega + | inr o => + have h := A₂ o hi.2 hv hrun + have hΦ := potential₂ o hi.1 hi.2 hv hrun + change E.totalCostTranscript lower e tr + (Φ₁ e' + Φ₂ e') ≤ + upper₂ (M₂.abs e) o + (Φ₁ e + Φ₂ e) + omega + +/-- **Potentials stack through a realization.** An amortized refinement over a native +implementation with an amortized certificate yields an amortized certificate of the realized +module, provided the native representation is functional: the represented lower state is +`absR c`. -/ +theorem Amortized.realize (A : M.Amortized lower upper potential) + {C τ : Type x} {exec : Execution E C τ} {R : StateTransitionImpl E exec} + {weight : τ → ℕ} {ψ : E.State → C → ℕ} (B : DataStructure.Amortized R weight ψ lower) + (absR : C → E.State) (hR : ∀ {e c}, R.rep e c → e = absR c) : + DataStructure.Amortized (M.toModule.realize R) (total weight) + (fun _ c => potential (absR c) + ψ (absR c) c) upper where + step {_ c o a c' ts} hr hv he := by + obtain ⟨e, ⟨hi, rfl⟩, hR₀⟩ := hr + obtain ⟨e', tr, hrun, hR', _, hcost⟩ := B.demonic hR₀ (M.valid o hi hv) he + obtain ⟨hstep, hi'⟩ := M.correct o hi hv hrun + have hc := A o hi hv hrun + refine ⟨M.abs e', hstep, ⟨e', ⟨hi', rfl⟩, hR'⟩, ?_⟩ + rw [← hR hR₀, ← hR hR'] + omega + +/-- The identity refinement passes each charge through unchanged. -/ +theorem Amortized.id (charge : D.State → D.Op → ℕ) : + (Refinement.id D).Amortized charge charge fun _ => 0 := by + intro e o a e' tr _ _ hrun + cases hrun with + | liftBind _ _ r _ _ hrest => + cases hrest + simp [Refinement.id] + +/-- With zero potential, an amortized refinement is a worst-case `Module.ChargeBound` of its +module. -/ +theorem Amortized.chargeBound (A : M.Amortized lower upper fun _ => 0) : + M.toModule.ChargeBound lower upper := by + rintro s e o a e' tr ⟨hi, rfl⟩ hv hrun + simpa using A o hi hv hrun + +/-- A worst-case `Module.ChargeBound` of the module is an amortized refinement with zero +potential. -/ +theorem Amortized.of_chargeBound (B : M.toModule.ChargeBound lower upper) : + M.Amortized lower upper fun _ => 0 := by + intro e o a e' tr hi hv hrun + simpa using B o ⟨hi, rfl⟩ hv hrun + +end Refinement + +end Cslib.DataStructure diff --git a/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean b/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean new file mode 100644 index 0000000000..d17a2b7965 --- /dev/null +++ b/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean @@ -0,0 +1,81 @@ +/- +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.Analysis.Asymptotics.Ring + +/-! +# Asymptotic cost bounds + +`Cslib.CostIsBigO l g size cost` says that the cost of every input is bounded by one cost +function of its size, chosen before the input: some monotone, nonnegative `f` with `f =O[l] g` +satisfies `cost a ≤ f (size a)` for all `a`. This is the form of asymptotic cost specification +used by Guéneau, Charguéraud and Pottier [GueneauChargueraudPottier2018]. Because `f` is chosen +once, the statement is `∃ f, ∀ a`. Inductive reasoning with "`O(1) + O(1) = O(1)`" proves +`∀ a, ∃ c` instead, which is unsound as a cost claim. The filter makes multivariate bounds +explicit: for example, `atTop` on `ℕ × ℕ` for a bound in two size parameters. + +Exact constants are proved internally and exported in this form: `CostIsBigO.of_le_nat` turns an +exact natural-number bound into an asymptotic one. + +## Main definitions + +* `Cslib.CostIsBigO`: a cost bounded by a monotone, nonnegative function that is `O(g)` along a + filter. + +## Main results + +* `Cslib.CostIsBigO.of_le_nat`: export an exact monotone natural-number bound. +* `Cslib.CostIsBigO.mono`: a smaller cost has the same bound. +* `Cslib.CostIsBigO.trans_isBigO`: weaken the comparison function. + +## References + +* [A. Guéneau, A. Charguéraud and F. Pottier, *A Fistful of Dollars: Formalizing Asymptotic + Complexity Claims via Deductive Program Verification*][GueneauChargueraudPottier2018] +-/ + +@[expose] public section + +open Asymptotics + +namespace Cslib + +variable {α ι : Type*} [Preorder ι] + +/-- The cost of every input `a` is at most `f (size a)` for one monotone, nonnegative cost +function `f` with `f =O[l] g`. -/ +def CostIsBigO (l : Filter ι) (g : ι → ℝ) (size : α → ι) (cost : α → ℕ) : Prop := + ∃ f : ι → ℝ, Monotone f ∧ 0 ≤ f ∧ f =O[l] g ∧ ∀ a, (cost a : ℝ) ≤ f (size a) + +namespace CostIsBigO + +variable {l : Filter ι} {g : ι → ℝ} {size : α → ι} {cost : α → ℕ} + +/-- An exact monotone natural-number bound that is `O(g)` gives an asymptotic cost bound. -/ +theorem of_le_nat {F : ι → ℕ} (hF : Monotone F) (hO : (fun n => (F n : ℝ)) =O[l] g) + (h : ∀ a, cost a ≤ F (size a)) : CostIsBigO l g size cost := + ⟨fun n => F n, fun _ _ hab => Nat.cast_le.mpr (hF hab), fun _ => Nat.cast_nonneg _, hO, + fun a => Nat.cast_le.mpr (h a)⟩ + +/-- A cost below a bounded cost has the same bound. -/ +theorem mono {cost' : α → ℕ} (h : CostIsBigO l g size cost) (hle : ∀ a, cost' a ≤ cost a) : + CostIsBigO l g size cost' := by + obtain ⟨f, hf, hf0, hO, hb⟩ := h + exact ⟨f, hf, hf0, hO, fun a => (Nat.cast_le.mpr (hle a)).trans (hb a)⟩ + +/-- A cost that is `O(g)` is `O(g')` whenever `g =O[l] g'`. -/ +theorem trans_isBigO {g' : ι → ℝ} (h : CostIsBigO l g size cost) (hg : g =O[l] g') : + CostIsBigO l g' size cost := by + obtain ⟨f, hf, hf0, hO, hb⟩ := h + exact ⟨f, hf, hf0, hO.trans hg, hb⟩ + +end CostIsBigO + +end Cslib diff --git a/ComplexityTests/StateTransitionRefinement.lean b/ComplexityTests/StateTransitionRefinement.lean new file mode 100644 index 0000000000..7288b6efcc --- /dev/null +++ b/ComplexityTests/StateTransitionRefinement.lean @@ -0,0 +1,143 @@ +/- +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.Queue.Spec +public import Complexity.DataStructure.StateTransition.Refinement +public import Complexity.Foundations.Analysis.Asymptotics.CostBound + +/-! +# Amortized refinements with a nonzero potential + +A bag supports adding an element and clearing. It is implemented over the stack interface: +`add` pushes, and `clear` asks for the size and pops that many times. A clear can cost +arbitrarily many stack calls, but each element pays for its own pop when it is added, so with +the potential "one credit per stacked element" every bag operation costs at most two stack calls. +The tests check this per-operation certificate, telescope it along a concrete client, stack it +over the identity refinement, and export the linear bound as `CostIsBigO`. +-/ + +@[expose] public section + +namespace ComplexityTests.StateTransitionRefinement + +open Cslib Cslib.DataStructure Cslib.DataStructure.Queue + +/-- Bag operations. -/ +inductive BagOp where + | add (n : ℕ) + | clear + deriving DecidableEq + +/-- A bag with `clear`, recording its elements newest first. -/ +abbrev bag : StateTransitionSpec := + StateTransitionSpec.ofFn (State := List ℕ) (Op := BagOp) (Result := fun _ => Unit) + fun s o => match o with + | .add n => (n :: s, ()) + | .clear => ([], ()) + +/-- Pop `n` times. -/ +def popAll : ℕ → (stack ℕ).Client Unit + | 0 => pure () + | n + 1 => .liftBind .pop fun _ => popAll n + +/-- Bag operations as stack programs. -/ +def methods : Methods bag (stack ℕ) + | .add n => .liftBind (.push n) fun _ => .pure () + | .clear => .liftBind .size fun n => popAll n + +/-- Popping as many times as the stack is long empties it, one call per element. -/ +theorem runClient_popAll (s : List ℕ) : + (stack ℕ).runClient s (popAll s.length) = ((), [], List.replicate s.length .pop) := by + induction s with + | nil => rfl + | cons a s ih => + change (stack ℕ).runClient (a :: s) (.liftBind StackOp.pop fun _ => popAll s.length) = _ + rw [StateTransitionSpec.runClient_liftBind] + change (let (v, s', os) := (stack ℕ).runClient s (popAll s.length) + (v, s', StackOp.pop :: os)) = _ + rw [ih] + rfl + +/-- The stack holds the bag itself; there is no invariant. -/ +def refinement : Refinement bag (stack ℕ) := + Refinement.ofFn methods (fun _ => True) id + (fun _ _ _ => (stack ℕ).validHistory_of_forall_valid (fun _ _ => trivial) _ _) + (by + intro s o _ _ + cases o with + | add n => exact ⟨rfl, trivial⟩ + | clear => + refine ⟨?_, trivial⟩ + simp [methods, StateTransitionSpec.clientState, runClient_popAll]) + +/-- Two calls per `add`, one per `clear`. -/ +def bagCharge (_ : List ℕ) : BagOp → ℕ + | .add _ => 2 + | .clear => 1 + +/-- One credit per stacked element pays for its eventual pop. -/ +theorem amortized : refinement.Amortized (fun _ _ => 1) bagCharge List.length := by + apply Refinement.Amortized.ofFn + intro s o _ _ + cases o with + | add n => + simp [refinement, methods, bagCharge, StateTransitionSpec.clientState, + StateTransitionSpec.clientHistory] + omega + | clear => + simp [refinement, methods, bagCharge, StateTransitionSpec.clientState, + StateTransitionSpec.clientHistory, runClient_popAll, StateTransitionSpec.totalCost_const] + +/-- A client with one expensive clear. -/ +def client : bag.Client Unit := do + bag.call (.add 1) + bag.call (.add 2) + bag.call (.add 3) + bag.call .clear + bag.call (.add 4) + +/-- The clear costs four stack calls, yet the five bag operations stay within their nine +amortized units, with one credit left for the remaining element. -/ +example : (stack ℕ).totalCost (fun _ _ => 1) [] + ((stack ℕ).clientHistory [] (link refinement.methods client)) = 8 ∧ + bag.totalCost bagCharge [] (bag.clientHistory [] client) = 9 ∧ + ((stack ℕ).clientState [] (link refinement.methods client)).length = 1 := by + decide + +/-- The general telescoped bound from an empty stack. -/ +theorem client_bound (p : bag.Client Unit) : + (stack ℕ).totalCost (fun _ _ => 1) [] ((stack ℕ).clientHistory [] (link refinement.methods p)) + + ((stack ℕ).clientState [] (link refinement.methods p)).length ≤ + bag.totalCost bagCharge [] (bag.clientHistory [] p) := by + have h := amortized.client p (e := []) trivial + (bag.validHistory_of_forall_valid (fun _ _ => trivial) _ _) + exact h + +/-- Stacking over the identity refinement adds a zero potential. -/ +example : (refinement.comp (Refinement.id (stack ℕ))).Amortized (fun _ _ => 1) bagCharge + (fun s => s.length + 0) := + amortized.comp (Refinement.Amortized.id _) + +/-- The exported form: the stack calls of a bag client from an empty stack are `O(m)` in the +number `m` of bag operations, with the constant `2`. -/ +example : CostIsBigO Filter.atTop (fun m : ℕ => (m : ℝ)) + (fun p : bag.Client Unit => (bag.clientHistory [] p).length) + (fun p => (stack ℕ).totalCost (fun _ _ => 1) [] + ((stack ℕ).clientHistory [] (link refinement.methods p))) := by + refine CostIsBigO.of_le_nat (F := fun m => 2 * m) (fun _ _ h => Nat.mul_le_mul_left 2 h) + ?_ fun p => ?_ + · simpa using (Asymptotics.isBigO_refl (fun m : ℕ => (m : ℝ)) _).const_mul_left 2 + · have h := client_bound p + have hc : bag.totalCost bagCharge [] (bag.clientHistory [] p) ≤ + (bag.clientHistory [] p).length * 2 := + bag.totalCost_le_length_mul bagCharge 2 (fun _ o _ => by cases o <;> simp [bagCharge]) + (bag.validHistory_of_forall_valid (fun _ _ => trivial) _ _) + omega + +end ComplexityTests.StateTransitionRefinement From 2f12c49d3c05a6905a3484b2b0efa0591cda0021 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:23:20 -0500 Subject: [PATCH 04/18] feat(DataStructure/StateTransition): weaken and rescale amortized refinements Amortized.mono and Amortized.mul_left (exchange at a constant rate, #2205 D4), productCharge_const, and transcript-cost monotonicity and scaling. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../StateTransition/Refinement.lean | 60 ++++++++++++++++++- 1 file changed, 58 insertions(+), 2 deletions(-) diff --git a/Complexity/DataStructure/StateTransition/Refinement.lean b/Complexity/DataStructure/StateTransition/Refinement.lean index a70028a61c..ee80ab1581 100644 --- a/Complexity/DataStructure/StateTransition/Refinement.lean +++ b/Complexity/DataStructure/StateTransition/Refinement.lean @@ -43,6 +43,10 @@ methods of each side leave the other side's abstraction, invariant and potential * `Refinement.Amortized`: per-method amortized cost refinement with a potential on lower states. * `productCharge`: componentwise charges of a product specification. +The two transcript-cost lemmas `StateTransitionSpec.totalCostTranscript_mono` and +`StateTransitionSpec.totalCostTranscript_mul_left` sit here, beside their only clients, rather +than in the widely imported `StateTransition` module. + ## Main results * `Refinement.simulates_demonic`, `Refinement.simulates_client`: whole adaptive clients run @@ -54,6 +58,12 @@ methods of each side leave the other side's abstraction, invariant and potential * `Refinement.Amortized.prod`: potentials add across non-interfering products. * `Refinement.Amortized.realize`: an amortized certificate for the realized module. * `Refinement.Amortized.id`: the identity refinement passes charges through. +* `Refinement.Amortized.mono`, `Refinement.Amortized.mul_left`: weaken charges, and exchange + both currencies at a constant rate. +* `productCharge_const`: equal constant charges on a product. +* `StateTransitionSpec.totalCostTranscript_mono`, + `StateTransitionSpec.totalCostTranscript_mul_left`: monotonicity and scaling of transcript + costs. * `Refinement.Amortized.chargeBound`, `Refinement.Amortized.of_chargeBound`: with zero potential, the existing worst-case `Module.ChargeBound`. @@ -86,6 +96,25 @@ structure Refinement (D E : StateTransitionSpec.{u, v, w}) where correct : ∀ {e} o {a e' tr}, inv e → D.valid (abs e) o → E.ClientRun e (methods o) a e' tr → D.step (abs e) o (abs e') a ∧ inv e' +/-- Smaller charges total less along any transcript. -/ +theorem StateTransitionSpec.totalCostTranscript_mono {c c' : D.State → D.Op → ℕ} + (h : ∀ s o, c s o ≤ c' s o) (s : D.State) (tr : D.Transcript) : + D.totalCostTranscript c s tr ≤ D.totalCostTranscript c' s tr := by + induction tr generalizing s with + | nil => simp + | cons st tr ih => + simp only [StateTransitionSpec.totalCostTranscript_cons] + exact Nat.add_le_add (h _ _) (ih _) + +/-- Scaling every charge by `K` scales the total by `K`. -/ +theorem StateTransitionSpec.totalCostTranscript_mul_left (K : ℕ) (c : D.State → D.Op → ℕ) + (s : D.State) (tr : D.Transcript) : + D.totalCostTranscript (fun s o => K * c s o) s tr = K * D.totalCostTranscript c s tr := by + induction tr generalizing s with + | nil => simp + | cons st tr ih => + simp only [StateTransitionSpec.totalCostTranscript_cons, ih, Nat.mul_add] + namespace Refinement /-- The constructor for deterministic specifications: each method's history is admissible, and @@ -244,6 +273,27 @@ theorem Amortized.ofFn {fE : (e : E.State) → (o : E.Op) → E.State × E.Resul rw [E.totalCostTranscript_canonicalTranscript] exact h o hi hv +/-- Weaker charges: cheaper lower charges and dearer upper charges on admissible operations. -/ +theorem Amortized.mono (A : M.Amortized lower upper potential) + {lower' : E.State → E.Op → ℕ} {upper' : D.State → D.Op → ℕ} + (hlower : ∀ e o, lower' e o ≤ lower e o) + (hupper : ∀ s o, D.valid s o → upper s o ≤ upper' s o) : + M.Amortized lower' upper' potential := by + intro e o a e' tr hi hv hrun + have h := A o hi hv hrun + have hl := E.totalCostTranscript_mono hlower e tr + have hu := hupper _ o hv + omega + +/-- **Exchange at a constant rate.** Scaling both currencies and the potential by `K` preserves +the amortized inequality. -/ +theorem Amortized.mul_left (A : M.Amortized lower upper potential) (K : ℕ) : + M.Amortized (fun e o => K * lower e o) (fun s o => K * upper s o) + (fun e => K * potential e) := by + intro e o a e' tr hi hv hrun + rw [E.totalCostTranscript_mul_left, ← Nat.mul_add, ← Nat.mul_add] + exact Nat.mul_le_mul_left K (A o hi hv hrun) + /-- Potentials telescope along any run of a linked admissible client. -/ theorem Amortized.demonic (A : M.Amortized lower upper potential) (p : D.Client α) {e e' : E.State} {a : α} {tr_E : E.Transcript} (he : M.inv e) @@ -303,8 +353,14 @@ theorem Amortized.comp {N : Refinement E F} {lower : F.State → F.Op → ℕ} /-- Componentwise charges of a product specification. -/ def productCharge (c₁ : D₁.State → D₁.Op → ℕ) (c₂ : D₂.State → D₂.Op → ℕ) : (product D₁ D₂).State → (product D₁ D₂).Op → ℕ - | (s₁, _), .inl o => c₁ s₁ o - | (_, s₂), .inr o => c₂ s₂ o + | s, .inl o => c₁ s.1 o + | s, .inr o => c₂ s.2 o + +/-- Equal constant charges on both components are that constant charge on the product. -/ +@[simp] theorem productCharge_const (K : ℕ) : + productCharge (D₁ := D₁) (D₂ := D₂) (fun _ _ => K) (fun _ _ => K) = fun _ _ => K := by + funext s o + cases o <;> rfl /-- **Potentials add across non-interfering products**, provided the methods of each side leave the other side's potential unchanged. -/ From 98e3290dbc1bda9719bde60ccf0b57ecc992f5da Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:27:24 -0500 Subject: [PATCH 05/18] fix(DataStructure/StateTransition): place productCharge beside product, outside Refinement Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../StateTransition/Refinement.lean | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/Complexity/DataStructure/StateTransition/Refinement.lean b/Complexity/DataStructure/StateTransition/Refinement.lean index ee80ab1581..08e10929f6 100644 --- a/Complexity/DataStructure/StateTransition/Refinement.lean +++ b/Complexity/DataStructure/StateTransition/Refinement.lean @@ -96,6 +96,18 @@ structure Refinement (D E : StateTransitionSpec.{u, v, w}) where correct : ∀ {e} o {a e' tr}, inv e → D.valid (abs e) o → E.ClientRun e (methods o) a e' tr → D.step (abs e) o (abs e') a ∧ inv e' +/-- Componentwise charges of a product specification. -/ +def productCharge (c₁ : D₁.State → D₁.Op → ℕ) (c₂ : D₂.State → D₂.Op → ℕ) : + (product D₁ D₂).State → (product D₁ D₂).Op → ℕ + | s, .inl o => c₁ s.1 o + | s, .inr o => c₂ s.2 o + +/-- Equal constant charges on both components are that constant charge on the product. -/ +@[simp] theorem productCharge_const (K : ℕ) : + productCharge (D₁ := D₁) (D₂ := D₂) (fun _ _ => K) (fun _ _ => K) = fun _ _ => K := by + funext s o + cases o <;> rfl + /-- Smaller charges total less along any transcript. -/ theorem StateTransitionSpec.totalCostTranscript_mono {c c' : D.State → D.Op → ℕ} (h : ∀ s o, c s o ≤ c' s o) (s : D.State) (tr : D.Transcript) : @@ -350,18 +362,6 @@ theorem Amortized.comp {N : Refinement E F} {lower : F.State → F.Op → ℕ} upper (M.abs (N.abs f)) o + (Φ (N.abs f) + Ψ f) omega -/-- Componentwise charges of a product specification. -/ -def productCharge (c₁ : D₁.State → D₁.Op → ℕ) (c₂ : D₂.State → D₂.Op → ℕ) : - (product D₁ D₂).State → (product D₁ D₂).Op → ℕ - | s, .inl o => c₁ s.1 o - | s, .inr o => c₂ s.2 o - -/-- Equal constant charges on both components are that constant charge on the product. -/ -@[simp] theorem productCharge_const (K : ℕ) : - productCharge (D₁ := D₁) (D₂ := D₂) (fun _ _ => K) (fun _ _ => K) = fun _ _ => K := by - funext s o - cases o <;> rfl - /-- **Potentials add across non-interfering products**, provided the methods of each side leave the other side's potential unchanged. -/ theorem Amortized.prod {M₁ : Refinement D₁ E} {M₂ : Refinement D₂ E} From 56232f9738389bd1f3c285dfddc6b4cd1048c766 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:28:34 -0500 Subject: [PATCH 06/18] refactor(DataStructure/StateTransition): make Refinement.Amortized a structure A Prop-valued def whose body starts with an implicit binder is unfolded and auto-introduced during elaboration against an expected type, which broke term-mode uses such as Amortized.prod. A one-field structure, like the existing DataStructure.Amortized, avoids this. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../StateTransition/Refinement.lean | 40 ++++++++++--------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/Complexity/DataStructure/StateTransition/Refinement.lean b/Complexity/DataStructure/StateTransition/Refinement.lean index 08e10929f6..e6d94e5d59 100644 --- a/Complexity/DataStructure/StateTransition/Refinement.lean +++ b/Complexity/DataStructure/StateTransition/Refinement.lean @@ -263,10 +263,12 @@ def prod (M₁ : Refinement D₁ E) (M₂ : Refinement D₂ E) are at most the upper charge of the operation plus the potential before it. Potentials are natural numbers, hence nonnegative; a client bound subtracts nothing when the initial potential is zero. -/ -def Amortized (lower : E.State → E.Op → ℕ) (upper : D.State → D.Op → ℕ) - (potential : E.State → ℕ) : Prop := - ∀ {e} o {a e' tr}, M.inv e → D.valid (M.abs e) o → E.ClientRun e (M.methods o) a e' tr → - E.totalCostTranscript lower e tr + potential e' ≤ upper (M.abs e) o + potential e +structure Amortized (lower : E.State → E.Op → ℕ) (upper : D.State → D.Op → ℕ) + (potential : E.State → ℕ) : Prop where + /-- The physicist's inequality for one method run. -/ + step : ∀ {e} o {a e' tr}, M.inv e → D.valid (M.abs e) o → + E.ClientRun e (M.methods o) a e' tr → + E.totalCostTranscript lower e tr + potential e' ≤ upper (M.abs e) o + potential e variable {M} {lower : E.State → E.Op → ℕ} {upper : D.State → D.Op → ℕ} {potential : E.State → ℕ} @@ -280,7 +282,7 @@ theorem Amortized.ofFn {fE : (e : E.State) → (o : E.Op) → E.State × E.Resul potential (E.clientState e (M.methods o)) ≤ upper (M.abs e) o + potential e) : M.Amortized lower upper potential := by - intro e o a e' tr hi hv hrun + refine ⟨fun {e} o {a e' tr} hi hv hrun => ?_⟩ obtain ⟨_, _, rfl, rfl⟩ := (E.clientRun_iff_runClient e (M.methods o) a e' tr).mp hrun rw [E.totalCostTranscript_canonicalTranscript] exact h o hi hv @@ -291,8 +293,8 @@ theorem Amortized.mono (A : M.Amortized lower upper potential) (hlower : ∀ e o, lower' e o ≤ lower e o) (hupper : ∀ s o, D.valid s o → upper s o ≤ upper' s o) : M.Amortized lower' upper' potential := by - intro e o a e' tr hi hv hrun - have h := A o hi hv hrun + refine ⟨fun {e} o {a e' tr} hi hv hrun => ?_⟩ + have h := A.step o hi hv hrun have hl := E.totalCostTranscript_mono hlower e tr have hu := hupper _ o hv omega @@ -302,9 +304,9 @@ the amortized inequality. -/ theorem Amortized.mul_left (A : M.Amortized lower upper potential) (K : ℕ) : M.Amortized (fun e o => K * lower e o) (fun s o => K * upper s o) (fun e => K * potential e) := by - intro e o a e' tr hi hv hrun + refine ⟨fun {e} o {a e' tr} hi hv hrun => ?_⟩ rw [E.totalCostTranscript_mul_left, ← Nat.mul_add, ← Nat.mul_add] - exact Nat.mul_le_mul_left K (A o hi hv hrun) + exact Nat.mul_le_mul_left K (A.step o hi hv hrun) /-- Potentials telescope along any run of a linked admissible client. -/ theorem Amortized.demonic (A : M.Amortized lower upper potential) (p : D.Client α) @@ -324,7 +326,7 @@ theorem Amortized.demonic (A : M.Amortized lower upper potential) (p : D.Client rw [heq] at hrun obtain ⟨res, e₁, tr₁, tr₂, hrun₁, hrun₂, rfl⟩ := E.clientRun_bind_iff.mp hrun obtain ⟨hstep₁, he₁⟩ := M.correct o he hv_o hrun₁ - have hc₁ := A o he hv_o hrun₁ + have hc₁ := A.step o he hv_o hrun₁ obtain ⟨he₂, tr_D, hrun_D, hc₂⟩ := ih res he₁ (hv_k _ res hstep₁) hrun₂ refine ⟨he₂, ⟨o, res, M.abs e₁⟩ :: tr_D, .liftBind o k res hv_o hstep₁ hrun_D, ?_⟩ rw [E.totalCostTranscript_append lower hrun₁.validTranscript tr₂] @@ -355,9 +357,9 @@ theorem Amortized.comp {N : Refinement E F} {lower : F.State → F.Op → ℕ} {middle : E.State → E.Op → ℕ} {Φ : E.State → ℕ} {Ψ : F.State → ℕ} (A : M.Amortized middle upper Φ) (B : N.Amortized lower middle Ψ) : (M.comp N).Amortized lower upper (fun f => Φ (N.abs f) + Ψ f) := by - intro f o a f' tr hi hv hrun + refine ⟨fun {f} o {a f' tr} hi hv hrun => ?_⟩ obtain ⟨_, tr_E, hrun_E, hN⟩ := B.demonic (M.methods o) hi.1 (M.valid o hi.2 hv) hrun - have hM := A o hi.2 hv hrun_E + have hM := A.step o hi.2 hv hrun_E change F.totalCostTranscript lower f tr + (Φ (N.abs f') + Ψ f') ≤ upper (M.abs (N.abs f)) o + (Φ (N.abs f) + Ψ f) omega @@ -378,16 +380,16 @@ theorem Amortized.prod {M₁ : Refinement D₁ E} {M₂ : Refinement D₂ E} E.ClientRun e (M₂.methods o) a e' tr → Φ₁ e' = Φ₁ e) : (M₁.prod M₂ frame₁ frame₂).Amortized lower (productCharge upper₁ upper₂) (fun e => Φ₁ e + Φ₂ e) := by - intro e o a e' tr hi hv hrun + refine ⟨fun {e} o {a e' tr} hi hv hrun => ?_⟩ cases o with | inl o => - have h := A₁ o hi.1 hv hrun + have h := A₁.step o hi.1 hv hrun have hΦ := potential₁ o hi.1 hi.2 hv hrun change E.totalCostTranscript lower e tr + (Φ₁ e' + Φ₂ e') ≤ upper₁ (M₁.abs e) o + (Φ₁ e + Φ₂ e) omega | inr o => - have h := A₂ o hi.2 hv hrun + have h := A₂.step o hi.2 hv hrun have hΦ := potential₂ o hi.1 hi.2 hv hrun change E.totalCostTranscript lower e tr + (Φ₁ e' + Φ₂ e') ≤ upper₂ (M₂.abs e) o + (Φ₁ e + Φ₂ e) @@ -407,7 +409,7 @@ theorem Amortized.realize (A : M.Amortized lower upper potential) obtain ⟨e, ⟨hi, rfl⟩, hR₀⟩ := hr obtain ⟨e', tr, hrun, hR', _, hcost⟩ := B.demonic hR₀ (M.valid o hi hv) he obtain ⟨hstep, hi'⟩ := M.correct o hi hv hrun - have hc := A o hi hv hrun + have hc := A.step o hi hv hrun refine ⟨M.abs e', hstep, ⟨e', ⟨hi', rfl⟩, hR'⟩, ?_⟩ rw [← hR hR₀, ← hR hR'] omega @@ -415,7 +417,7 @@ theorem Amortized.realize (A : M.Amortized lower upper potential) /-- The identity refinement passes each charge through unchanged. -/ theorem Amortized.id (charge : D.State → D.Op → ℕ) : (Refinement.id D).Amortized charge charge fun _ => 0 := by - intro e o a e' tr _ _ hrun + refine ⟨fun {e} o {a e' tr} _ _ hrun => ?_⟩ cases hrun with | liftBind _ _ r _ _ hrest => cases hrest @@ -426,13 +428,13 @@ module. -/ theorem Amortized.chargeBound (A : M.Amortized lower upper fun _ => 0) : M.toModule.ChargeBound lower upper := by rintro s e o a e' tr ⟨hi, rfl⟩ hv hrun - simpa using A o hi hv hrun + simpa using A.step o hi hv hrun /-- A worst-case `Module.ChargeBound` of the module is an amortized refinement with zero potential. -/ theorem Amortized.of_chargeBound (B : M.toModule.ChargeBound lower upper) : M.Amortized lower upper fun _ => 0 := by - intro e o a e' tr hi hv hrun + refine ⟨fun {e} o {a e' tr} hi hv hrun => ?_⟩ simpa using B o ⟨hi, rfl⟩ hv hrun end Refinement From fe7d60dfa1f451062f231851e21fa89d4b413f61 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:31:13 -0500 Subject: [PATCH 07/18] wip: array stack over memory and queue method lemmas Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity/DataStructure/Queue/Spec.lean | 59 +-- Complexity/DataStructure/Stack/Memory.lean | 397 +++++++++++++++++++++ 2 files changed, 434 insertions(+), 22 deletions(-) create mode 100644 Complexity/DataStructure/Stack/Memory.lean diff --git a/Complexity/DataStructure/Queue/Spec.lean b/Complexity/DataStructure/Queue/Spec.lean index 7a0ec18c25..ef315844d5 100644 --- a/Complexity/DataStructure/Queue/Spec.lean +++ b/Complexity/DataStructure/Queue/Spec.lean @@ -28,6 +28,8 @@ method is described in Chapter 17. ## Main results * `transfer_run`: stack operations reverse the rear contents into the front stack. +* `runClient_dequeue_nil`, `stepFn_methods`: the methods realize the FIFO step on the represented + list. * `potential_step`: at most three amortized stack calls, including the size query. * `realized_client`: every adaptive client has a correct backend execution with its bound. * `realized_client_bound`: every supplied linked execution satisfies correctness and the bound. @@ -123,6 +125,36 @@ theorem transfer_run (front back : List α) : (fun r : Unit × (stackPair α).State × List (stackPair α).Op => (r.1, r.2.1, .inr .pop :: .inl (.push a) :: r.2.2)) (ih (a :: front)) +/-- A dequeue from an empty front stack asks for the rear size, transfers the rear, and pops the +front again. -/ +theorem runClient_dequeue_nil (back : List α) : + (stackPair α).runClient ([], back) (methods .dequeue) = + (back.reverse.head?, (back.reverse.tail, []), + .inl .pop :: .inr .size :: (transferTrace back ++ [.inl .pop])) := by + simp only [methods, bind, StateTransitionSpec.runClient_liftBind, stackPair, stack, + List.tail_nil, List.head?_nil] + rw [StateTransitionSpec.runClient_bind, transfer_run] + simp + +/-- Each method returns the FIFO answer, and the stacks then represent the FIFO successor of the +represented list. -/ +theorem stepFn_methods (front back : List α) (o : QueueOp α) : + (queue α).stepFn (front ++ back.reverse) o = + (((stackPair α).clientState (front, back) (methods o)).1 ++ + ((stackPair α).clientState (front, back) (methods o)).2.reverse, + (stackPair α).clientResult (front, back) (methods o)) := by + cases o with + | enqueue n => + change ((front ++ back.reverse) ++ [n], ()) = (front ++ (n :: back).reverse, ()) + simp [List.reverse_cons, List.append_assoc] + | dequeue => + cases front with + | cons a front => rfl + | nil => + simp only [StateTransitionSpec.clientState, StateTransitionSpec.clientResult] + rw [runClient_dequeue_nil] + simp + /-- Representation and behavior are proved once, before selecting a backend or cost model. -/ def implementation : Module (queue α) (stackPair α) := Module.ofFn @@ -134,21 +166,8 @@ def implementation : Module (queue α) (stackPair α) := intro q s o hr _ subst q obtain ⟨front, back⟩ := s - cases o with - | enqueue n => - constructor - · rfl - · change (front ++ back.reverse) ++ [n] = front ++ (n :: back).reverse - simp [List.reverse_cons, List.append_assoc] - | dequeue => - cases front with - | cons a front => exact ⟨rfl, rfl⟩ - | nil => - simp only [methods, bind, StateTransitionSpec.clientResult, - StateTransitionSpec.clientState, StateTransitionSpec.runClient_liftBind, - stackPair, stack, List.tail_nil, List.head?_nil] - rw [StateTransitionSpec.runClient_bind, transfer_run] - simp) + have h := stepFn_methods front back o + exact ⟨(congrArg Prod.snd h).symm, congrArg Prod.fst h⟩) /-- Each transferred element incurs one pop and one push. -/ theorem transferTrace_length (back : List α) : (transferTrace back).length = 2 * back.length := by @@ -173,13 +192,9 @@ theorem potential_step (s : (stackPair α).State) (o : QueueOp α) : change 1 + 2 * back.length ≤ 3 + 2 * back.length omega | nil => - simp only [methods, bind, StateTransitionSpec.runClient_liftBind, stackPair, - stack, List.tail_nil, List.head?_nil] - rw [StateTransitionSpec.runClient_bind, transfer_run] - simp only [StateTransitionSpec.runClient_liftBind, StateTransitionSpec.runClient_pure] - change (transferTrace back ++ [Sum.inl StackOp.pop]).length + 2 ≤ 3 + 2 * back.length - rw [List.length_append, transferTrace_length] - simp only [List.length_singleton] + rw [runClient_dequeue_nil] + simp only [List.length_cons, List.length_append, List.length_nil] + rw [transferTrace_length] omega private theorem weighted_potential_step (K : Nat) {q : (queue α).State} {s : (stackPair α).State} diff --git a/Complexity/DataStructure/Stack/Memory.lean b/Complexity/DataStructure/Stack/Memory.lean new file mode 100644 index 0000000000..b70e19923f --- /dev/null +++ b/Complexity/DataStructure/Stack/Memory.lean @@ -0,0 +1,397 @@ +/- +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.Field +public import Complexity.DataStructure.StateTransition.Refinement +public import Complexity.DataStructure.Stack.WordRAM.Basic + +/-! +# An array stack over the memory oracle + +The bounded stack `Stack.WordRAM.spec w C` is implemented by three short programs over +`Memory.spec w`. The storage is a `Layout` with two named fields: a one-cell `count` and an +`items` array of `C` cells, bottom first. The abstraction function reads the first `count` items +and reverses them, so the top comes first. Each operation is one read, two writes at most, and a +single branch; its evaluation is definitional (`runClient_push`, `runClient_pop_of_pos`, …), and +the refinement obligations follow from those equations and the list view of the array. + +Every operation costs at most three memory units, with no potential (`amortized`). The methods +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`). Two stacks with disjoint +layouts therefore implement the product of two stacks (`pairRefinement`). + +This is the same specification that `Stack.WordRAM` implements by a hand-stepped nine-register +dispatcher. Here no register, instruction count or word-fit chain appears; fits enter only +through the admissibility of `Memory.spec w`. + +## Main definitions + +* `Layout`, `Layout.footprint`, `Layout.Valid`: the two fields, the cells they own, and their + static well-formedness. +* `push`, `pop`, `size`, `methods`: the operations as memory programs. +* `abs`, `Inv`: the abstraction function and the implementation invariant. +* `refinement`: the array stack as a `Refinement` of the bounded stack. +* `pairRefinement`: two array stacks with disjoint layouts implement the pair of stacks. +* `allocLayout`: allocate an empty stack. + +## Main results + +* `amortized`: every operation costs at most three memory units. +* `pair_amortized`: so does every operation of the pair. +* `modifies_methods`, `abs_congr`, `Inv.congr`: the frame of a stack. +* `runClient_allocLayout_bind`, `inv_allocLayout`, `abs_allocLayout`: allocation yields an empty + stack in three memory units. + +## References + +* [T. H. Cormen, C. E. Leiserson, R. L. Rivest and C. Stein, *Introduction to Algorithms*, + Section 10.1][CLRS2009] +-/ + +@[expose] public section + +namespace Cslib.DataStructure.Stack.Memory + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.Memory Cslib.DataStructure.Queue + +/-- The storage of an array stack: a one-cell field holding the number of items, and the item +array, bottom first. -/ +structure Layout where + /-- One cell holding the number of stored items. -/ + count : Block + /-- The items, bottom first. -/ + items : Block + +namespace Layout + +/-- The cells a stack owns. -/ +def footprint (L : Layout) : Finset ℕ := L.count.footprint ∪ L.items.footprint + +/-- Static well-formedness for capacity `C` at word size `w`: the count field is one cell outside +the item array, the array has `C` cells, and `C` fits a word. -/ +structure Valid (L : Layout) (w C : ℕ) : Prop where + /-- The count field is one cell. -/ + count_length : L.count.length = 1 + /-- The count cell is not an item. -/ + count_not_owns : ¬L.items.Owns L.count.base + /-- The item array has the capacity. -/ + items_length : L.items.length = C + /-- The capacity fits a word, so every count does. -/ + capacity_fits : Fits w C + +/-- The count cell belongs to the footprint. -/ +theorem count_mem_footprint (L : Layout) (hL : L.count.length = 1) : + L.count.base ∈ L.footprint := + Finset.mem_union_left _ (Block.mem_footprint.mpr ⟨le_rfl, by omega⟩) + +/-- Every item cell belongs to the footprint. -/ +theorem item_mem_footprint (L : Layout) {i : ℕ} (hi : i < L.items.length) : + L.items.base + i ∈ L.footprint := + Finset.mem_union_right _ (Block.mem_footprint.mpr (Block.owns_add hi)) + +end Layout + +variable (L : Layout) + +/-- Push: write the item above the top, then increment the count. -/ +def push (v : ℕ) : Prog Unit := do + let n ← L.count.get 0 + L.items.set n v + L.count.set 0 (n + 1) + +/-- Pop: an empty stack returns `none`; otherwise read the top item and decrement the count. -/ +def pop : Prog (Option ℕ) := do + let n ← L.count.get 0 + if n = 0 then pure none else do + let v ← L.items.get (n - 1) + L.count.set 0 (n - 1) + pure (some v) + +/-- Size: read the count. -/ +def size : Prog ℕ := L.count.get 0 + +/-- The stack operations as memory programs. -/ +def methods (w C : ℕ) : Methods (Stack.WordRAM.spec w C) (Memory.spec w) + | .push v => push L v + | .pop => pop L + | .size => size L + +/-- The stored stack, top first: the first `count` items, reversed. -/ +def abs (s : Memory.State) : List ℕ := (L.items.entries (s.mem L.count.base) s.mem).reverse + +/-- The implementation invariant: both fields are allocated and the count is within capacity. -/ +structure Inv (s : Memory.State) : Prop where + /-- The count cell is allocated. -/ + count_allocated : L.count.Allocated s + /-- The item array is allocated. -/ + items_allocated : L.items.Allocated s + /-- The count is at most the capacity. -/ + count_le : s.mem L.count.base ≤ L.items.length + +/-! ## Evaluation -/ + +variable {w : ℕ} + +/-- A push reads the count, writes the item and writes the new count. -/ +theorem runClient_push (s : Memory.State) (v : ℕ) : + (Memory.spec w).runClient s (push L v) = + ((), ⟨Function.update (Function.update s.mem (L.items.base + s.mem L.count.base) v) + L.count.base (s.mem L.count.base + 1), s.frontier⟩, + [.read L.count.base, .write (L.items.base + s.mem L.count.base) v, + .write L.count.base (s.mem L.count.base + 1)]) := rfl + +/-- A pop from an empty stack reads the count only. -/ +theorem runClient_pop_of_eq_zero (s : Memory.State) (h : s.mem L.count.base = 0) : + (Memory.spec w).runClient s (pop L) = (none, s, [.read L.count.base]) := by + simp [pop, h] + +/-- A pop from a nonempty stack reads the count and the top item and writes the new count. -/ +theorem runClient_pop_of_pos (s : Memory.State) (h : s.mem L.count.base ≠ 0) : + (Memory.spec w).runClient s (pop L) = + (some (s.mem (L.items.base + (s.mem L.count.base - 1))), + ⟨Function.update s.mem L.count.base (s.mem L.count.base - 1), s.frontier⟩, + [.read L.count.base, .read (L.items.base + (s.mem L.count.base - 1)), + .write L.count.base (s.mem L.count.base - 1)]) := by + unfold pop + simp only [Block.runClient_get_bind, Nat.add_zero, h, ↓reduceIte] + rfl + +/-- A size query reads the count. -/ +theorem runClient_size (s : Memory.State) : + (Memory.spec w).runClient s (size L) = (s.mem L.count.base, s, [.read L.count.base]) := rfl + +/-! ## The list view -/ + +variable {L} {C : ℕ} + +/-- The stack has as many elements as the count. -/ +@[simp] theorem length_abs (s : Memory.State) : (abs L s).length = s.mem L.count.base := by + simp [abs] + +/-- Writing the count leaves the items in place. -/ +theorem abs_update_count (hL : L.Valid w C) (m : ℕ → ℕ) (f : ℕ) {n : ℕ} (hn : n ≤ C) : + abs L ⟨Function.update m L.count.base n, f⟩ = (L.items.entries n m).reverse := by + simp only [abs, Function.update_self] + rw [Block.entries_update_of_not_owns _ (hL.items_length ▸ hn) hL.count_not_owns] + +/-- The abstraction and the invariant read only the layout's cells and the frontier. -/ +theorem abs_congr {s s' : Memory.State} (hL : L.Valid w C) (hs : Inv L s) + (h : ∀ a ∈ L.footprint, s'.mem a = s.mem a) : abs L s' = abs L s := by + have hc : s'.mem L.count.base = s.mem L.count.base := + h _ (L.count_mem_footprint hL.count_length) + simp only [abs, hc] + rw [Block.entries_congr _ _ fun i hi => h _ (L.item_mem_footprint (by + have := hs.count_le + omega))] + +/-- The invariant reads only the layout's cells and survives a growing frontier. -/ +theorem Inv.congr {s s' : Memory.State} (hL : L.Valid w C) (hs : Inv L s) + (h : ∀ a ∈ L.footprint, s'.mem a = s.mem a) (hf : s.frontier ≤ s'.frontier) : Inv L s' where + count_allocated := hs.count_allocated.mono hf + items_allocated := hs.items_allocated.mono hf + count_le := by + rw [h _ (L.count_mem_footprint hL.count_length)] + exact hs.count_le + +/-! ## The refinement -/ + +/-- The count cell is an admissible address. -/ +theorem Inv.count_lt (hL : L.Valid w C) {s : Memory.State} (hs : Inv L s) : + L.count.base < s.frontier := by + simpa using hs.count_allocated.lt_frontier (i := 0) (by rw [hL.count_length]; omega) + +/-- Item `i` below the capacity is an admissible address. -/ +theorem Inv.item_lt {s : Memory.State} (hs : Inv L s) {i : ℕ} (hi : i < L.items.length) : + L.items.base + i < s.frontier := + hs.items_allocated.lt_frontier hi + +/-- The array stack implements the bounded stack of capacity `C`. -/ +def refinement (hL : L.Valid w C) : Refinement (Stack.WordRAM.spec w C) (Memory.spec w) := + Refinement.ofFn (methods L w C) (Inv L) (abs L) + (by + intro s o hs hv + have hcount := hs.count_lt hL + have hC := hL.items_length + cases o with + | push v => + obtain ⟨hlen, hfit⟩ := hv + rw [length_abs] at hlen + simp only [methods, StateTransitionSpec.clientHistory, runClient_push] + simp only [StateTransitionSpec.validHistory_cons, StateTransitionSpec.stepFn, + step_read, step_write, valid_read, valid_write] + exact ⟨hcount, ⟨hs.item_lt (by omega), hfit⟩, ⟨hcount, + hL.capacity_fits.of_le (by omega)⟩, trivial⟩ + | pop => + by_cases h0 : s.mem L.count.base = 0 + · simp only [methods, StateTransitionSpec.clientHistory, runClient_pop_of_eq_zero L s h0] + exact ⟨hcount, trivial⟩ + · simp only [methods, StateTransitionSpec.clientHistory, runClient_pop_of_pos L s h0] + simp only [StateTransitionSpec.validHistory_cons, StateTransitionSpec.stepFn, + step_read, step_write, valid_read, valid_write] + have := hs.count_le + exact ⟨hcount, hs.item_lt (by omega), ⟨hcount, + hL.capacity_fits.of_le (by omega)⟩, trivial⟩ + | size => + simp only [methods, StateTransitionSpec.clientHistory, runClient_size] + exact ⟨hcount, trivial⟩) + (by + intro s o hs hv + have hle := hs.count_le + have hC := hL.items_length + cases o with + | push v => + obtain ⟨hlen, -⟩ := hv + rw [length_abs] at hlen + simp only [methods, StateTransitionSpec.clientState, StateTransitionSpec.clientResult, + runClient_push] + refine ⟨?_, ⟨hs.count_allocated, hs.items_allocated, by simp; omega⟩⟩ + rw [abs_update_count hL _ _ (by omega), Block.entries_succ, + Block.entries_update_of_le _ le_rfl, Function.update_self] + simp [abs] + | pop => + by_cases h0 : s.mem L.count.base = 0 + · simp only [methods, StateTransitionSpec.clientState, StateTransitionSpec.clientResult, + runClient_pop_of_eq_zero L s h0] + have he : abs L s = [] := List.eq_nil_of_length_eq_zero (by simp [h0]) + simp [he, hs] + · simp only [methods, StateTransitionSpec.clientState, StateTransitionSpec.clientResult, + runClient_pop_of_pos L s h0] + refine ⟨?_, ⟨hs.count_allocated, hs.items_allocated, by simp; omega⟩⟩ + obtain ⟨n, hn⟩ := Nat.exists_eq_succ_of_ne_zero h0 + have habs : abs L s = + s.mem (L.items.base + n) :: (L.items.entries n s.mem).reverse := by + simp [abs, hn, Block.entries_succ] + rw [abs_update_count hL _ _ (by omega), habs] + simp [hn] + | size => + simp only [methods, StateTransitionSpec.clientState, StateTransitionSpec.clientResult, + runClient_size] + exact ⟨by simp, hs⟩) + +/-- Every operation costs at most three memory units, so the stack needs no potential. -/ +theorem amortized (hL : L.Valid w C) : + (refinement hL).Amortized charge (fun _ _ => 3) fun _ => 0 := by + apply Refinement.Amortized.ofFn + intro s o _ _ + cases o with + | push v => simp [refinement, methods, StateTransitionSpec.clientHistory, runClient_push] + | pop => + by_cases h0 : s.mem L.count.base = 0 + · simp [refinement, methods, StateTransitionSpec.clientHistory, + runClient_pop_of_eq_zero L s h0] + · simp [refinement, methods, StateTransitionSpec.clientHistory, runClient_pop_of_pos L s h0] + | size => simp [refinement, methods, StateTransitionSpec.clientHistory, runClient_size] + +/-! ## The frame of a stack -/ + +/-- Each admissible operation writes only the layout's cells and never allocates. -/ +theorem modifies_methods (hL : L.Valid w C) {s : Memory.State} (o : StackOp ℕ) + (hv : (Stack.WordRAM.spec w C).valid (abs L s) o) : + (∀ a ∉ L.footprint, + ((Memory.spec w).clientState s (methods L w C o)).mem a = s.mem a) ∧ + ((Memory.spec w).clientState s (methods L w C o)).frontier = s.frontier := by + have hc : L.count.base ∈ L.footprint := L.count_mem_footprint hL.count_length + cases o with + | push v => + obtain ⟨hlen, -⟩ := hv + rw [length_abs] at hlen + have hi : L.items.base + s.mem L.count.base ∈ L.footprint := + L.item_mem_footprint (by rw [hL.items_length]; exact hlen) + simp only [methods, StateTransitionSpec.clientState, runClient_push] + exact ⟨fun a ha => by + rw [Function.update_of_ne (ne_of_mem_of_not_mem hc ha).symm, + Function.update_of_ne (ne_of_mem_of_not_mem hi ha).symm], trivial⟩ + | pop => + by_cases h0 : s.mem L.count.base = 0 + · simp only [methods, StateTransitionSpec.clientState, runClient_pop_of_eq_zero L s h0] + exact ⟨fun _ _ => trivial, trivial⟩ + · simp only [methods, StateTransitionSpec.clientState, runClient_pop_of_pos L s h0] + exact ⟨fun a ha => Function.update_of_ne (ne_of_mem_of_not_mem hc ha).symm _ _, trivial⟩ + | size => exact ⟨fun _ _ => rfl, rfl⟩ + +/-- A stack's operations leave a stack with a disjoint layout unchanged. -/ +theorem frame {L' : Layout} (hL : L.Valid w C) (hL' : L'.Valid w C) + (hd : Disjoint L.footprint L'.footprint) {s : Memory.State} (hs' : Inv L' s) + (o : StackOp ℕ) (hv : (Stack.WordRAM.spec w C).valid (abs L s) o) : + abs L' ((Memory.spec w).clientState s (methods L w C o)) = abs L' s ∧ + Inv L' ((Memory.spec w).clientState s (methods L w C o)) := by + obtain ⟨hm, hf⟩ := modifies_methods hL o hv + have h : ∀ a ∈ L'.footprint, + ((Memory.spec w).clientState s (methods L w C o)).mem a = s.mem a := + fun a ha => hm a (Finset.disjoint_right.mp hd ha) + exact ⟨abs_congr hL' hs' h, hs'.congr hL' h hf.ge⟩ + +/-! ## Two stacks in one memory -/ + +/-- Two array stacks with disjoint layouts implement a pair of bounded stacks. -/ +def pairRefinement {L₁ L₂ : Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) + (hd : Disjoint L₁.footprint L₂.footprint) : + Refinement (product (Stack.WordRAM.spec w C) (Stack.WordRAM.spec w C)) (Memory.spec w) := + (refinement h₁).prod (refinement h₂) + (fun {s} o {a s' tr} hs₁ hs₂ hv hrun => by + obtain ⟨_, _, rfl, _⟩ := ((Memory.spec w).clientRun_iff_runClient _ _ _ _ _).mp hrun + exact frame h₁ h₂ hd hs₂ o hv) + (fun {s} o {a s' tr} hs₁ hs₂ hv hrun => by + obtain ⟨_, _, rfl, _⟩ := ((Memory.spec w).clientRun_iff_runClient _ _ _ _ _).mp hrun + exact frame h₂ h₁ hd.symm hs₁ o hv) + +/-- Every operation of the pair costs at most three memory units. -/ +theorem pair_amortized {L₁ L₂ : Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) + (hd : Disjoint L₁.footprint L₂.footprint) : + (pairRefinement h₁ h₂ hd).Amortized charge (fun _ _ => 3) fun _ => 0 := by + have h : (pairRefinement h₁ h₂ hd).Amortized charge + (productCharge (fun _ _ => 3) (fun _ _ => 3)) fun _ => 0 := + (amortized h₁).prod (amortized h₂) (fun _ _ _ _ _ _ _ _ => rfl) + (fun _ _ _ _ _ _ _ _ => rfl) + rwa [productCharge_const] at h + +/-! ## Allocation -/ + +/-- Allocate an empty stack of capacity `C`: a zeroed count cell and an item array that is not +cleared. -/ +def allocLayout (C : ℕ) : Prog Layout := do + let count ← allocBlock 1 + let items ← allocBlockDirty C + pure ⟨count, items⟩ + +/-- Allocation places the count at the frontier and the items just above it. -/ +theorem runClient_allocLayout_bind {α : Type} (C : ℕ) (next : Layout → Prog α) + (s : Memory.State) : + (Memory.spec w).runClient s (allocLayout C >>= next) = + let (v, s', os) := (Memory.spec w).runClient + ⟨clear s.mem s.frontier 1, s.frontier + 1 + C⟩ + (next ⟨⟨s.frontier, 1⟩, ⟨s.frontier + 1, C⟩⟩) + (v, s', .alloc 1 :: .allocDirty C :: os) := rfl + +/-- The allocated layout is well formed when its end fits a word. -/ +theorem valid_allocLayout {f : ℕ} (hf : Fits w (f + 1 + C)) : + Layout.Valid ⟨⟨f, 1⟩, ⟨f + 1, C⟩⟩ w C where + count_length := rfl + count_not_owns := by simp [Block.Owns] + items_length := rfl + capacity_fits := hf.of_le (by omega) + +/-- The allocated stack satisfies the invariant and is empty. -/ +theorem inv_allocLayout (s : Memory.State) : + Inv ⟨⟨s.frontier, 1⟩, ⟨s.frontier + 1, C⟩⟩ ⟨clear s.mem s.frontier 1, s.frontier + 1 + C⟩ ∧ + abs ⟨⟨s.frontier, 1⟩, ⟨s.frontier + 1, C⟩⟩ + ⟨clear s.mem s.frontier 1, s.frontier + 1 + C⟩ = [] := by + have h0 : clear s.mem s.frontier 1 s.frontier = 0 := + clear_of_owns ⟨le_rfl, show s.frontier < s.frontier + 1 from Nat.lt_add_one _⟩ + refine ⟨⟨?_, ?_, ?_⟩, ?_⟩ + · change s.frontier + 1 ≤ s.frontier + 1 + C + omega + · change s.frontier + 1 + C ≤ s.frontier + 1 + C + exact le_rfl + · change clear s.mem s.frontier 1 s.frontier ≤ C + rw [h0] + exact Nat.zero_le C + · simp [abs, h0] + +end Cslib.DataStructure.Stack.Memory From aad5f3ee860b445a7bde96ab39ab69d50b6f6a0f Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:31:23 -0500 Subject: [PATCH 08/18] feat(Foundations): affine cost bounds are O(size) Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../Foundations/Analysis/Asymptotics/CostBound.lean | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean b/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean index d17a2b7965..3a99eace52 100644 --- a/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean +++ b/Complexity/Foundations/Analysis/Asymptotics/CostBound.lean @@ -32,6 +32,7 @@ exact natural-number bound into an asymptotic one. ## Main results * `Cslib.CostIsBigO.of_le_nat`: export an exact monotone natural-number bound. +* `Cslib.CostIsBigO.of_le_add_mul`: an affine bound `a + b * size` is `O(size)`. * `Cslib.CostIsBigO.mono`: a smaller cost has the same bound. * `Cslib.CostIsBigO.trans_isBigO`: weaken the comparison function. @@ -76,6 +77,18 @@ theorem trans_isBigO {g' : ι → ℝ} (h : CostIsBigO l g size cost) (hg : g =O obtain ⟨f, hf, hf0, hO, hb⟩ := h exact ⟨f, hf, hf0, hO.trans hg, hb⟩ +/-- A cost at most `a + b * size` is `O(size)` along `atTop`. -/ +theorem of_le_add_mul {size : α → ℕ} (a b : ℕ) (h : ∀ x, cost x ≤ a + b * size x) : + CostIsBigO Filter.atTop (fun n : ℕ => (n : ℝ)) size cost := by + refine of_le_nat (F := fun n => a + b * n) + (fun _ _ hmn => Nat.add_le_add_left (Nat.mul_le_mul_left b hmn) a) ?_ h + refine IsBigO.of_bound (a + b) ?_ + filter_upwards [Filter.eventually_ge_atTop 1] with n hn + have hn' : (1 : ℝ) ≤ n := by exact_mod_cast hn + rw [Real.norm_of_nonneg (by positivity), Real.norm_of_nonneg (by positivity)] + push_cast + nlinarith + end CostIsBigO end Cslib From 6698e86529717d14e635feadf264726885f9cbb9 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:34:38 -0500 Subject: [PATCH 09/18] wip: queue over memory Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity/DataStructure/Queue/Memory.lean | 185 +++++++++++++++++++++ Complexity/DataStructure/Stack/Memory.lean | 17 +- 2 files changed, 201 insertions(+), 1 deletion(-) create mode 100644 Complexity/DataStructure/Queue/Memory.lean diff --git a/Complexity/DataStructure/Queue/Memory.lean b/Complexity/DataStructure/Queue/Memory.lean new file mode 100644 index 0000000000..28a37a7a87 --- /dev/null +++ b/Complexity/DataStructure/Queue/Memory.lean @@ -0,0 +1,185 @@ +/- +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.Queue.WordRAM.Model +public import Complexity.DataStructure.Stack.Memory +public import Complexity.Foundations.Analysis.Asymptotics.CostBound + +/-! +# A queue over two array stacks over the memory oracle + +The bounded FIFO queue `Queue.WordRAM.spec w C` is implemented in two refinement steps, each +proved once: + +1. `refinement`: the two-stack queue `Queue.methods` over a pair of bounded stacks. It reuses the + queue's existing methods and their behavior (`Queue.stepFn_methods`) and potential argument + (`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. `Stack.Memory.pairRefinement`: two array stacks with disjoint layouts over `Memory.spec w`, + 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; +`run_correct` and `run_cost` state its result and its exact memory cost from any well-formed memory, +and `run_cost_isBigO` exports the cost as `O(m)` in the number `m` of queue operations. + +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 +programs on the word RAM is the separate realization step of #2205. + +## Main definitions + +* `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. +* `memRefinement`: the queue over two array stacks over memory. +* `run`: allocate the stacks, then run a queue client. + +## Main results + +* `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. +* `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_isBigO`: the same cost as `O(m)`. + +## References + +* [T. H. Cormen, C. E. Leiserson, R. L. Rivest and C. Stein, *Introduction to Algorithms*, + Exercise 10.1-6 and Chapter 17][CLRS2009] +-/ + +@[expose] public section + +namespace Cslib.DataStructure.Queue.Memory + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.Memory Cslib.DataStructure.Queue + +/-- Two bounded stacks of capacity `C` at word size `w`. -/ +abbrev boundedStacks (w C : ℕ) : StateTransitionSpec := + product (Stack.WordRAM.spec w C) (Stack.WordRAM.spec w C) + +/-- A FIFO list within capacity `C` whose entries fit a `w`-bit word. -/ +structure Inv (w C : ℕ) (q : List ℕ) : Prop where + /-- The list is within capacity. -/ + length_le : q.length ≤ C + /-- Every entry fits a word. -/ + fits : ∀ x ∈ q, Fits w x + +namespace Inv + +variable {w C : ℕ} + +/-- Admissible FIFO steps keep the list within capacity and made of words. -/ +theorem step {q : List ℕ} (h : Inv w C q) {o : QueueOp ℕ} + (hv : (Queue.WordRAM.spec w C).valid q o) : Inv w C ((queue ℕ).stepFn q o).1 := by + cases o with + | enqueue n => + obtain ⟨hlen, hfit⟩ := hv + refine ⟨by simp; omega, fun x hx => ?_⟩ + simp only [List.mem_append, List.mem_singleton] at hx + rcases hx with hx | rfl + · exact h.fits x hx + · exact hfit + | dequeue => + exact ⟨by simp; have := h.length_le; omega, fun x hx => h.fits x (List.mem_of_mem_tail hx)⟩ + +end Inv + +variable {w C : ℕ} + +/-- The bounded stacks step exactly as the unbounded ones; only admissibility differs. -/ +theorem runClient_boundedStacks {β : Type} (s : List ℕ × List ℕ) (p : (stackPair ℕ).Client β) : + (boundedStacks w C).runClient s p = (stackPair ℕ).runClient s p := by + induction p generalizing s with + | pure a => rfl + | liftBind o k ih => + have hstep : (boundedStacks w C).stepFn s o = (stackPair ℕ).stepFn s o := by cases o <;> rfl + simp only [StateTransitionSpec.runClient_liftBind, hstep, ih] + +/-- Moving the rear into the front is admissible for bounded stacks when both fit together and +the rear holds words. -/ +theorem validHistory_transferTrace {front back : List ℕ} (hlen : front.length + back.length ≤ C) + (hfit : ∀ x ∈ back, Fits w x) : (boundedStacks w C).ValidHistory (front, back) (transferTrace back) := by + induction back generalizing front with + | nil => trivial + | cons a back ih => + simp only [List.length_cons] at hlen + refine ⟨trivial, ⟨by simp only; omega, hfit a (by simp)⟩, ?_⟩ + exact ih (front := a :: front) (by simp only [List.length_cons]; omega) + fun x hx => hfit x (by simp [hx]) + +/-- The two-stack queue over a pair of bounded stacks: the stacks represent `front ++ rear⁻¹`. -/ +def refinement (w C : ℕ) : Refinement (Queue.WordRAM.spec w C) (boundedStacks w C) := + Refinement.ofFn (methods (α := ℕ)) (fun s => Inv w C (Queue.WordRAM.contents s)) + Queue.WordRAM.contents + (by + rintro ⟨front, back⟩ o hs hv + have hlen := hs.length_le + simp only [Queue.WordRAM.contents, List.length_append, List.length_reverse] at hlen + cases o with + | enqueue n => + obtain ⟨hq, hfit⟩ := hv + simp only [Queue.WordRAM.contents, List.length_append, List.length_reverse] at hq + exact ⟨⟨by omega, hfit⟩, trivial⟩ + | dequeue => + cases front with + | cons a front => exact ⟨trivial, trivial⟩ + | nil => + change (boundedStacks w C).ValidHistory ([], back) + ((boundedStacks w C).runClient ([], back) (methods .dequeue)).2.2 + rw [runClient_boundedStacks, runClient_dequeue_nil] + refine ⟨trivial, trivial, ?_⟩ + rw [StateTransitionSpec.validHistory_append] + refine ⟨validHistory_transferTrace (by simpa using hlen) fun x hx => + hs.fits x (by simp [Queue.WordRAM.contents, hx]), trivial, trivial⟩) + (by + rintro ⟨front, back⟩ o hs hv + have h := stepFn_methods front back o + refine ⟨h, ?_⟩ + have hstep := hs.step hv + rw [show Queue.WordRAM.contents (front, back) = front ++ back.reverse from rfl, h] at hstep + exact hstep) + +/-- Each queue operation costs at most three stack calls, amortized, with two credits per rear +element. -/ +theorem amortized : + (refinement w C).Amortized (fun _ _ => 1) (fun _ _ => 3) fun s => 2 * s.2.length := + Refinement.Amortized.ofFn fun {s} o _ _ => by + have h := potential_step s o + rw [← runClient_boundedStacks (w := w) (C := C)] at h + rw [StateTransitionSpec.totalCost_one] + exact h + +/-! ## Over memory -/ + +/-- 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) + (hd : Disjoint L₁.footprint L₂.footprint) : + Refinement (Queue.WordRAM.spec w C) (Memory.spec w) := + (refinement w C).comp (Stack.Memory.pairRefinement h₁ h₂ hd) + +/-- **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) + (hd : Disjoint L₁.footprint L₂.footprint) : + (memRefinement h₁ h₂ hd).Amortized charge (fun _ _ => 9) + fun s => 6 * (Stack.Memory.abs L₂ s).length := by + have h := (amortized.mul_left 3).comp (Stack.Memory.pair_amortized h₁ h₂ hd) + have hΦ : (fun s : Memory.State => + 3 * (2 * (Stack.Memory.abs L₂ s).length) + 0) = + fun s => 6 * (Stack.Memory.abs L₂ s).length := by + funext s + omega + exact hΦ ▸ h + +end Cslib.DataStructure.Queue.Memory diff --git a/Complexity/DataStructure/Stack/Memory.lean b/Complexity/DataStructure/Stack/Memory.lean index b70e19923f..8f5069fe44 100644 --- a/Complexity/DataStructure/Stack/Memory.lean +++ b/Complexity/DataStructure/Stack/Memory.lean @@ -37,13 +37,15 @@ through the admissibility of `Memory.spec w`. * `push`, `pop`, `size`, `methods`: the operations as memory programs. * `abs`, `Inv`: the abstraction function and the implementation invariant. * `refinement`: the array stack as a `Refinement` of the bounded stack. -* `pairRefinement`: two array stacks with disjoint layouts implement the pair of stacks. +* `pairMethods`, `pairRefinement`: two array stacks with disjoint layouts implement the pair of + stacks. * `allocLayout`: allocate an empty stack. ## Main results * `amortized`: every operation costs at most three memory units. * `pair_amortized`: so does every operation of the pair. +* `pairRefinement_methods`: the pair's methods do not depend on the proofs about its layouts. * `modifies_methods`, `abs_congr`, `Inv.congr`: the frame of a stack. * `runClient_allocLayout_bind`, `inv_allocLayout`, `abs_allocLayout`: allocation yields an empty stack in three memory units. @@ -329,6 +331,12 @@ theorem frame {L' : Layout} (hL : L.Valid w C) (hL' : L'.Valid w C) /-! ## Two stacks in one memory -/ +/-- The operations of two stacks, each on its own layout. -/ +def pairMethods (L₁ L₂ : Layout) (w C : ℕ) : + Methods (product (Stack.WordRAM.spec w C) (Stack.WordRAM.spec w C)) (Memory.spec w) + | .inl o => methods L₁ w C o + | .inr o => methods L₂ w C o + /-- Two array stacks with disjoint layouts implement a pair of bounded stacks. -/ def pairRefinement {L₁ L₂ : Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) (hd : Disjoint L₁.footprint L₂.footprint) : @@ -341,6 +349,13 @@ def pairRefinement {L₁ L₂ : Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Val obtain ⟨_, _, rfl, _⟩ := ((Memory.spec w).clientRun_iff_runClient _ _ _ _ _).mp hrun exact frame h₂ h₁ hd.symm hs₁ o hv) +/-- The pair's methods are `pairMethods`, whatever the proofs about the layouts. -/ +theorem pairRefinement_methods {L₁ L₂ : Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) + (hd : Disjoint L₁.footprint L₂.footprint) : + (pairRefinement h₁ h₂ hd).methods = pairMethods L₁ L₂ w C := by + funext o + cases o <;> rfl + /-- Every operation of the pair costs at most three memory units. -/ theorem pair_amortized {L₁ L₂ : Layout} (h₁ : L₁.Valid w C) (h₂ : L₂.Valid w C) (hd : Disjoint L₁.footprint L₂.footprint) : From 7dda2489654c6b0a3a10ca4687f4147aae32e819 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:35:57 -0500 Subject: [PATCH 10/18] refactor(DataStructure/StateTransition): product answer types via Sum.elim With a match, the answer types of product D E mention D and E through the matcher's parameters, so the elaborator cannot identify clients of two products whose components differ only in admissibility (for example the pair of stacks and the pair of bounded stacks). Sum.elim D.Result E.Result depends only on the component answer types. Queue.Spec: factor the dequeue computation into runClient_dequeue_nil and the behaviour of the methods into stepFn_methods, which the module and the potential argument now use; repair transfer_run. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity/DataStructure/Queue/Spec.lean | 67 ++++++++++++------- Complexity/DataStructure/StateTransition.lean | 9 +-- 2 files changed, 46 insertions(+), 30 deletions(-) diff --git a/Complexity/DataStructure/Queue/Spec.lean b/Complexity/DataStructure/Queue/Spec.lean index 7a0ec18c25..0986e07b05 100644 --- a/Complexity/DataStructure/Queue/Spec.lean +++ b/Complexity/DataStructure/Queue/Spec.lean @@ -28,6 +28,8 @@ method is described in Chapter 17. ## Main results * `transfer_run`: stack operations reverse the rear contents into the front stack. +* `runClient_dequeue_nil`, `stepFn_methods`: the methods realize the FIFO step on the represented + list. * `potential_step`: at most three amortized stack calls, including the size query. * `realized_client`: every adaptive client has a correct backend execution with its bound. * `realized_client_bound`: every supplied linked execution satisfies correctness and the bound. @@ -118,10 +120,40 @@ theorem transfer_run (front back : List α) : induction back generalizing front with | nil => rfl | cons a back ih => - simpa [transfer, stackPair, stack, transferTrace, - List.reverse_cons, List.append_assoc] using congrArg - (fun r : Unit × (stackPair α).State × List (stackPair α).Op => - (r.1, r.2.1, .inr .pop :: .inl (.push a) :: r.2.2)) (ih (a :: front)) + change (let (v, s, os) := (stackPair α).runClient (a :: front, back) (transfer back.length) + (v, s, (Sum.inr StackOp.pop : (stackPair α).Op) :: Sum.inl (StackOp.push a) :: os)) = _ + rw [ih] + simp [transferTrace, List.reverse_cons, List.append_assoc] + +/-- A dequeue from an empty front stack asks for the rear size, transfers the rear, and pops the +front again. -/ +theorem runClient_dequeue_nil (back : List α) : + (stackPair α).runClient ([], back) (methods .dequeue) = + (back.reverse.head?, (back.reverse.tail, []), + .inl .pop :: .inr .size :: (transferTrace back ++ [.inl .pop])) := by + simp only [methods, bind, StateTransitionSpec.runClient_liftBind, stackPair, stack, + List.tail_nil, List.head?_nil] + rw [StateTransitionSpec.runClient_bind, transfer_run, List.append_nil] + rfl + +/-- Each method returns the FIFO answer, and the stacks then represent the FIFO successor of the +represented list. -/ +theorem stepFn_methods (front back : List α) (o : QueueOp α) : + (queue α).stepFn (front ++ back.reverse) o = + (((stackPair α).clientState (front, back) (methods o)).1 ++ + ((stackPair α).clientState (front, back) (methods o)).2.reverse, + (stackPair α).clientResult (front, back) (methods o)) := by + cases o with + | enqueue n => + change ((front ++ back.reverse) ++ [n], ()) = (front ++ (n :: back).reverse, ()) + simp [List.reverse_cons, List.append_assoc] + | dequeue => + cases front with + | cons a front => rfl + | nil => + simp only [StateTransitionSpec.clientState, StateTransitionSpec.clientResult] + rw [runClient_dequeue_nil] + simp /-- Representation and behavior are proved once, before selecting a backend or cost model. -/ def implementation : Module (queue α) (stackPair α) := @@ -134,21 +166,8 @@ def implementation : Module (queue α) (stackPair α) := intro q s o hr _ subst q obtain ⟨front, back⟩ := s - cases o with - | enqueue n => - constructor - · rfl - · change (front ++ back.reverse) ++ [n] = front ++ (n :: back).reverse - simp [List.reverse_cons, List.append_assoc] - | dequeue => - cases front with - | cons a front => exact ⟨rfl, rfl⟩ - | nil => - simp only [methods, bind, StateTransitionSpec.clientResult, - StateTransitionSpec.clientState, StateTransitionSpec.runClient_liftBind, - stackPair, stack, List.tail_nil, List.head?_nil] - rw [StateTransitionSpec.runClient_bind, transfer_run] - simp) + have h := stepFn_methods front back o + exact ⟨(congrArg Prod.snd h).symm, congrArg Prod.fst h⟩) /-- Each transferred element incurs one pop and one push. -/ theorem transferTrace_length (back : List α) : (transferTrace back).length = 2 * back.length := by @@ -173,13 +192,9 @@ theorem potential_step (s : (stackPair α).State) (o : QueueOp α) : change 1 + 2 * back.length ≤ 3 + 2 * back.length omega | nil => - simp only [methods, bind, StateTransitionSpec.runClient_liftBind, stackPair, - stack, List.tail_nil, List.head?_nil] - rw [StateTransitionSpec.runClient_bind, transfer_run] - simp only [StateTransitionSpec.runClient_liftBind, StateTransitionSpec.runClient_pure] - change (transferTrace back ++ [Sum.inl StackOp.pop]).length + 2 ≤ 3 + 2 * back.length - rw [List.length_append, transferTrace_length] - simp only [List.length_singleton] + rw [runClient_dequeue_nil] + simp only [List.length_cons, List.length_append, List.length_nil] + rw [transferTrace_length] omega private theorem weighted_potential_step (K : Nat) {q : (queue α).State} {s : (stackPair α).State} diff --git a/Complexity/DataStructure/StateTransition.lean b/Complexity/DataStructure/StateTransition.lean index 114e38b86c..8c0ae6041b 100644 --- a/Complexity/DataStructure/StateTransition.lean +++ b/Complexity/DataStructure/StateTransition.lean @@ -1098,13 +1098,14 @@ theorem eval_eq_liftM {D : StateTransitionSpec.{u, v, u}} | pure a => rfl | liftBind o k ih => exact ih (D.stepFn s o).2 (D.stepFn s o).1 -/-- Two independent abstract components. A backend must separately justify their independence. -/ +/-- Two independent abstract components. A backend must separately justify their independence. +The answer types are `Sum.elim D.Result E.Result`, so the signature of a product depends only on +the signatures of its components: clients of `product D E` are clients of `product D' E'` when +`D`, `D'` and `E`, `E'` differ only in their states' admissibility. -/ abbrev product (D E : StateTransitionSpec.{u, v, w}) : StateTransitionSpec where State := D.State × E.State Op := D.Op ⊕ E.Op - Result - | .inl o => D.Result o - | .inr o => E.Result o + Result := Sum.elim D.Result E.Result step s | .inl o, s', a => D.step s.1 o s'.1 a ∧ s'.2 = s.2 | .inr o, s', a => s'.1 = s.1 ∧ E.step s.2 o s'.2 a From 412ad374dc88c09a00992d8f8318792accd69144 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 17:42:57 -0500 Subject: [PATCH 11/18] feat(DataStructure): queue over two array stacks over the memory oracle The M1 slice of #2205. Stack.Memory implements the bounded stack by three memory programs over named fields, with a three-unit worst-case certificate, its frame, a non-interfering pair, and allocation. Queue.Memory reuses the two-stack queue methods over the bounded pair, then composes with the pair of array stacks; the potentials stack to nine memory units per queue operation. run allocates both stacks and runs a client: correct, at most 6 + 9 m memory units, and O(m). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity.lean | 2 + Complexity/DataStructure/Queue/Memory.lean | 181 ++++++++++++++++-- Complexity/DataStructure/Queue/Spec.lean | 30 --- Complexity/DataStructure/Stack/Memory.lean | 18 +- ComplexityTests/DataStructureQueueMemory.lean | 79 ++++++++ 5 files changed, 259 insertions(+), 51 deletions(-) create mode 100644 ComplexityTests/DataStructureQueueMemory.lean diff --git a/Complexity.lean b/Complexity.lean index b6a10c1394..8599d2709f 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -2902,6 +2902,7 @@ public import Complexity.DataStructure.PriorityQueue.WordRAM.FibonacciHeap.MinPQ public import Complexity.DataStructure.PriorityQueue.WordRAM.FibonacciHeap.Model public import Complexity.DataStructure.PriorityQueue.WordRAM.FibonacciHeap.Program public import Complexity.DataStructure.PriorityQueue.WordRAM.FibonacciHeap.Trees +public import Complexity.DataStructure.Queue.Memory public import Complexity.DataStructure.Queue.Spec public import Complexity.DataStructure.Queue.WordRAM.Basic public import Complexity.DataStructure.Queue.WordRAM.Dynamic @@ -2914,6 +2915,7 @@ public import Complexity.DataStructure.SearchTree.Impl public import Complexity.DataStructure.SplayTree.AccessLemma public import Complexity.DataStructure.SplayTree.Basic public import Complexity.DataStructure.SplayTree.Impl +public import Complexity.DataStructure.Stack.Memory public import Complexity.DataStructure.Stack.WordRAM.Basic public import Complexity.DataStructure.Stack.WordRAM.Controller public import Complexity.DataStructure.StateTransition diff --git a/Complexity/DataStructure/Queue/Memory.lean b/Complexity/DataStructure/Queue/Memory.lean index 28a37a7a87..d3fa6805cf 100644 --- a/Complexity/DataStructure/Queue/Memory.lean +++ b/Complexity/DataStructure/Queue/Memory.lean @@ -27,24 +27,28 @@ proved once: `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; -`run_correct` and `run_cost` state its result and its exact memory cost from any well-formed memory, -and `run_cost_isBigO` exports the cost as `O(m)` in the number `m` of queue operations. +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)`. 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 -programs on the word RAM is the separate realization step of #2205. +instruction. Here the proofs mention neither registers nor instructions. Executing the memory +programs on the word RAM is a separate, generic realization step, which this file does not +provide. ## Main definitions * `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. -* `memRefinement`: the queue over two array stacks over memory. +* `memRefinement`, `memMethods`: the queue over two array stacks over memory, and its methods as + plain memory programs. * `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. * `run_correct`, `run_cost`: the allocated queue answers like the specification and costs at @@ -105,10 +109,29 @@ theorem runClient_boundedStacks {β : Type} (s : List ℕ × List ℕ) (p : (sta have hstep : (boundedStacks w C).stepFn s o = (stackPair ℕ).stepFn s o := by cases o <;> rfl simp only [StateTransitionSpec.runClient_liftBind, hstep, ih] +/-- The final state of a client of the bounded stacks. -/ +theorem clientState_boundedStacks {β : Type} (s : List ℕ × List ℕ) + (p : (stackPair ℕ).Client β) : + (boundedStacks w C).clientState s p = (stackPair ℕ).clientState s p := by + simp only [StateTransitionSpec.clientState, runClient_boundedStacks] + +/-- The result of a client of the bounded stacks. -/ +theorem clientResult_boundedStacks {β : Type} (s : List ℕ × List ℕ) + (p : (stackPair ℕ).Client β) : + (boundedStacks w C).clientResult s p = (stackPair ℕ).clientResult s p := by + simp only [StateTransitionSpec.clientResult, runClient_boundedStacks] + +/-- The history of a client of the bounded stacks. -/ +theorem clientHistory_boundedStacks {β : Type} (s : List ℕ × List ℕ) + (p : (stackPair ℕ).Client β) : + (boundedStacks w C).clientHistory s p = (stackPair ℕ).clientHistory s p := by + simp only [StateTransitionSpec.clientHistory, runClient_boundedStacks] + /-- Moving the rear into the front is admissible for bounded stacks when both fit together and the rear holds words. -/ theorem validHistory_transferTrace {front back : List ℕ} (hlen : front.length + back.length ≤ C) - (hfit : ∀ x ∈ back, Fits w x) : (boundedStacks w C).ValidHistory (front, back) (transferTrace back) := by + (hfit : ∀ x ∈ back, Fits w x) : + (boundedStacks w C).ValidHistory (front, back) (transferTrace back) := by induction back generalizing front with | nil => trivial | cons a back ih => @@ -129,14 +152,15 @@ def refinement (w C : ℕ) : Refinement (Queue.WordRAM.spec w C) (boundedStacks | enqueue n => obtain ⟨hq, hfit⟩ := hv simp only [Queue.WordRAM.contents, List.length_append, List.length_reverse] at hq - exact ⟨⟨by omega, hfit⟩, trivial⟩ + refine ⟨⟨?_, hfit⟩, trivial⟩ + change back.length < C + omega | dequeue => cases front with | cons a front => exact ⟨trivial, trivial⟩ | nil => - change (boundedStacks w C).ValidHistory ([], back) - ((boundedStacks w C).runClient ([], back) (methods .dequeue)).2.2 - rw [runClient_boundedStacks, runClient_dequeue_nil] + rw [clientHistory_boundedStacks, StateTransitionSpec.clientHistory, + runClient_dequeue_nil] refine ⟨trivial, trivial, ?_⟩ rw [StateTransitionSpec.validHistory_append] refine ⟨validHistory_transferTrace (by simpa using hlen) fun x hx => @@ -144,6 +168,7 @@ def refinement (w C : ℕ) : Refinement (Queue.WordRAM.spec w C) (boundedStacks (by rintro ⟨front, back⟩ o hs hv have h := stepFn_methods front back o + rw [clientState_boundedStacks, clientResult_boundedStacks] refine ⟨h, ?_⟩ have hstep := hs.step hv rw [show Queue.WordRAM.contents (front, back) = front ++ back.reverse from rfl, h] at hstep @@ -155,8 +180,10 @@ theorem amortized : (refinement w C).Amortized (fun _ _ => 1) (fun _ _ => 3) fun s => 2 * s.2.length := Refinement.Amortized.ofFn fun {s} o _ _ => by have h := potential_step s o - rw [← runClient_boundedStacks (w := w) (C := C)] at h - rw [StateTransitionSpec.totalCost_one] + change (boundedStacks w C).totalCost (fun _ _ => 1) s + ((boundedStacks w C).clientHistory s (methods o)) + + 2 * ((boundedStacks w C).clientState s (methods o)).2.length ≤ 3 + 2 * s.2.length + rw [StateTransitionSpec.totalCost_one, clientHistory_boundedStacks, clientState_boundedStacks] exact h /-! ## Over memory -/ @@ -182,4 +209,132 @@ theorem mem_amortized {L₁ L₂ : Stack.Memory.Layout} (h₁ : L₁.Valid w C) 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 (Stack.Memory.pairMethods L₁ 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) (hd : Disjoint L₁.footprint L₂.footprint) : + (memRefinement h₁ h₂ hd).methods = memMethods L₁ L₂ w C := by + funext o + change link (Stack.Memory.pairRefinement h₁ h₂ hd).methods (methods o) = _ + rw [Stack.Memory.pairRefinement_methods] + rfl + +/-- 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) + (hd : Disjoint (frontLayout s C).footprint (rearLayout s C).footprint), + (memRefinement h₁ h₂ hd).inv (allocated s C) ∧ + (memRefinement h₁ h₂ hd).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)) + have hd : Disjoint (frontLayout s C).footprint (rearLayout s C).footprint := by + rw [Finset.disjoint_left] + intro a ha hb + simp only [Stack.Memory.Layout.footprint, Finset.mem_union, Block.mem_footprint, + Block.Owns] at ha hb + omega + -- The first stack, as allocated, before the second allocation. + obtain ⟨hi₁, ha₁⟩ := Stack.Memory.inv_allocLayout (C := C) s + -- The second stack, allocated from the state after the first. + obtain ⟨hi₂, ha₂⟩ := Stack.Memory.inv_allocLayout (C := C) + ⟨clear s.mem s.frontier 1, s.frontier + 1 + C⟩ + -- The second allocation leaves the first stack's cells alone. + have hframe : ∀ a ∈ (frontLayout s C).footprint, + (allocated s C).mem a = clear s.mem s.frontier 1 a := by + intro a ha + simp only [Stack.Memory.Layout.footprint, Finset.mem_union, Block.mem_footprint, + Block.Owns] at ha + exact clear_of_not_owns (by simp only [Block.Owns]; omega) + have hi₁' := hi₁.congr h₁ hframe (by simp only; omega) + have ha₁' := (Stack.Memory.abs_congr h₁ hi₁ hframe).trans ha₁ + refine ⟨h₁, h₂, hd, ⟨⟨hi₁', hi₂⟩, ?_⟩, ?_, ha₂⟩ + · change Inv w C (Queue.WordRAM.contents + (Stack.Memory.abs (frontLayout s C) (allocated s C), + Stack.Memory.abs (rearLayout s C) (allocated s C))) + rw [ha₁', ha₂] + exact ⟨by simp [Queue.WordRAM.contents], by simp [Queue.WordRAM.contents]⟩ + · change Queue.WordRAM.contents + (Stack.Memory.abs (frontLayout s C) (allocated s C), + Stack.Memory.abs (rearLayout s C) (allocated s C)) = [] + rw [ha₁', ha₂] + rfl + +/-- **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 +specified answer. -/ +theorem run_correct {β : Type} (p : (Queue.WordRAM.spec w C).Client β) {s : Memory.State} + (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₂, hd, hinv, habs, -⟩ := setup s hfit + obtain ⟨hvE, hres, -, -⟩ := + (memRefinement h₁ h₂ hd).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])⟩ + +/-- **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. -/ +theorem run_cost {β : Type} (p : (Queue.WordRAM.spec w C).Client β) {s : Memory.State} + (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₂, hd, hinv, habs, hrear⟩ := setup s hfit + have h := (mem_amortized h₁ h₂ hd).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 + +/-- **The exported form.** Over admissible clients, the memory cost of a run is `O(m)` in the +number `m` of queue operations. -/ +theorem run_cost_isBigO (s : Memory.State) (hfit : Fits w (s.frontier + 2 * (C + 1))) : + CostIsBigO Filter.atTop (fun m : ℕ => (m : ℝ)) + (fun p : {p : (Queue.WordRAM.spec w C).Client Unit // + (Queue.WordRAM.spec w C).ValidHistory [] ((Queue.WordRAM.spec w C).clientHistory [] p)} => + ((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 + end Cslib.DataStructure.Queue.Memory diff --git a/Complexity/DataStructure/Queue/Spec.lean b/Complexity/DataStructure/Queue/Spec.lean index a420660819..0986e07b05 100644 --- a/Complexity/DataStructure/Queue/Spec.lean +++ b/Complexity/DataStructure/Queue/Spec.lean @@ -155,36 +155,6 @@ theorem stepFn_methods (front back : List α) (o : QueueOp α) : rw [runClient_dequeue_nil] simp -/-- A dequeue from an empty front stack asks for the rear size, transfers the rear, and pops the -front again. -/ -theorem runClient_dequeue_nil (back : List α) : - (stackPair α).runClient ([], back) (methods .dequeue) = - (back.reverse.head?, (back.reverse.tail, []), - .inl .pop :: .inr .size :: (transferTrace back ++ [.inl .pop])) := by - simp only [methods, bind, StateTransitionSpec.runClient_liftBind, stackPair, stack, - List.tail_nil, List.head?_nil] - rw [StateTransitionSpec.runClient_bind, transfer_run] - simp - -/-- Each method returns the FIFO answer, and the stacks then represent the FIFO successor of the -represented list. -/ -theorem stepFn_methods (front back : List α) (o : QueueOp α) : - (queue α).stepFn (front ++ back.reverse) o = - (((stackPair α).clientState (front, back) (methods o)).1 ++ - ((stackPair α).clientState (front, back) (methods o)).2.reverse, - (stackPair α).clientResult (front, back) (methods o)) := by - cases o with - | enqueue n => - change ((front ++ back.reverse) ++ [n], ()) = (front ++ (n :: back).reverse, ()) - simp [List.reverse_cons, List.append_assoc] - | dequeue => - cases front with - | cons a front => rfl - | nil => - simp only [StateTransitionSpec.clientState, StateTransitionSpec.clientResult] - rw [runClient_dequeue_nil] - simp - /-- Representation and behavior are proved once, before selecting a backend or cost model. -/ def implementation : Module (queue α) (stackPair α) := Module.ofFn diff --git a/Complexity/DataStructure/Stack/Memory.lean b/Complexity/DataStructure/Stack/Memory.lean index 8f5069fe44..cf79d42258 100644 --- a/Complexity/DataStructure/Stack/Memory.lean +++ b/Complexity/DataStructure/Stack/Memory.lean @@ -17,9 +17,9 @@ public import Complexity.DataStructure.Stack.WordRAM.Basic The bounded stack `Stack.WordRAM.spec w C` is implemented by three short programs over `Memory.spec w`. The storage is a `Layout` with two named fields: a one-cell `count` and an `items` array of `C` cells, bottom first. The abstraction function reads the first `count` items -and reverses them, so the top comes first. Each operation is one read, two writes at most, and a -single branch; its evaluation is definitional (`runClient_push`, `runClient_pop_of_pos`, …), and -the refinement obligations follow from those equations and the list view of the array. +and reverses them, so the top comes first. Each operation is at most three memory operations and +one branch. Its evaluation is definitional (`runClient_push`, `runClient_pop_of_pos`, …), and the +refinement obligations follow from those equations and the list view of the array. Every operation costs at most three memory units, with no potential (`amortized`). The methods write only the layout's cells and never allocate (`modifies_methods`), and the abstraction and @@ -27,8 +27,8 @@ invariant depend only on those cells (`abs_congr`, `Inv.congr`). Two stacks with layouts therefore implement the product of two stacks (`pairRefinement`). This is the same specification that `Stack.WordRAM` implements by a hand-stepped nine-register -dispatcher. Here no register, instruction count or word-fit chain appears; fits enter only -through the admissibility of `Memory.spec w`. +dispatcher. Here no register or instruction count appears. Word fit enters only through the +admissibility of `Memory.spec w` and one static fact of the layout, that the capacity fits. ## Main definitions @@ -46,9 +46,11 @@ through the admissibility of `Memory.spec w`. * `amortized`: every operation costs at most three memory units. * `pair_amortized`: so does every operation of the pair. * `pairRefinement_methods`: the pair's methods do not depend on the proofs about its layouts. -* `modifies_methods`, `abs_congr`, `Inv.congr`: the frame of a stack. -* `runClient_allocLayout_bind`, `inv_allocLayout`, `abs_allocLayout`: allocation yields an empty - stack in three memory units. +* `runClient_push`, `runClient_pop_of_eq_zero`, `runClient_pop_of_pos`, `runClient_size`: the + operations evaluate definitionally. +* `modifies_methods`, `abs_congr`, `Inv.congr`, `frame`: the frame of a stack. +* `runClient_allocLayout_bind`, `valid_allocLayout`, `inv_allocLayout`: allocation yields a + well-formed empty stack in three memory units. ## References diff --git a/ComplexityTests/DataStructureQueueMemory.lean b/ComplexityTests/DataStructureQueueMemory.lean new file mode 100644 index 0000000000..93a8793360 --- /dev/null +++ b/ComplexityTests/DataStructureQueueMemory.lean @@ -0,0 +1,79 @@ +/- +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.Queue.Memory + +/-! +# A queue over two array stacks, run on concrete memory + +A client enqueues three words and dequeues four times; the third dequeue empties the rear stack +into the front. The run allocates both stacks in empty memory at word size `8` with capacity `3`. +The tests check its answers against the queue specification, its exact memory cost against the +proved bound `6 + 9 m`, the admissibility of every memory operation, and that the general +theorems apply: their room and admissibility hypotheses hold here. +-/ + +@[expose] public section + +namespace ComplexityTests.DataStructureQueueMemory + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.Memory Cslib.DataStructure.Queue + Cslib.DataStructure.Queue.Memory + +/-- Enqueue `1, 2`, dequeue, enqueue `3`, then dequeue three times. -/ +def client : (Queue.WordRAM.spec 8 3).Client (List (Option ℕ)) := do + (Queue.WordRAM.spec 8 3).call (.enqueue 1) + (Queue.WordRAM.spec 8 3).call (.enqueue 2) + let a ← (Queue.WordRAM.spec 8 3).call .dequeue + (Queue.WordRAM.spec 8 3).call (.enqueue 3) + let b ← (Queue.WordRAM.spec 8 3).call .dequeue + let c ← (Queue.WordRAM.spec 8 3).call .dequeue + let d ← (Queue.WordRAM.spec 8 3).call .dequeue + pure [a, b, c, d] + +/-- Empty memory with nothing allocated. -/ +def empty : State := ⟨fun _ => 0, 0⟩ + +/-- FIFO answers, and an empty queue at the end. -/ +example : (Queue.WordRAM.spec 8 3).clientResult [] client = [some 1, some 2, some 3, none] := by + decide + +/-- The run over memory gives the same answers. -/ +example : (spec 8).clientResult empty (run 8 3 client) = [some 1, some 2, some 3, none] := by + decide + +/-- Its exact memory cost: 6 for the allocations and 43 for the seven queue operations, against +the proved bound `6 + 9 · 7 = 69`. The dequeue that moves two elements costs 17 alone. -/ +example : (spec 8).totalCost charge empty ((spec 8).clientHistory empty (run 8 3 client)) = 49 := by + decide + +/-- Every memory operation of the run is admissible. -/ +example : (spec 8).ValidHistory empty ((spec 8).clientHistory empty (run 8 3 client)) := by + decide + +/-- The client is admissible for the bounded queue. -/ +theorem client_valid : + (Queue.WordRAM.spec 8 3).ValidHistory [] ((Queue.WordRAM.spec 8 3).clientHistory [] client) := + ⟨⟨by decide, by decide⟩, ⟨by decide, by decide⟩, trivial, ⟨by decide, by decide⟩, trivial, + trivial, trivial, trivial⟩ + +/-- The general theorems apply: empty memory has room for both stacks at this word size. -/ +theorem room : Fits 8 (empty.frontier + 2 * (3 + 1)) := by decide + +example : (spec 8).clientResult empty (run 8 3 client) = + (Queue.WordRAM.spec 8 3).clientResult [] client := + (run_correct client room client_valid).2 + +example : (spec 8).totalCost charge empty ((spec 8).clientHistory empty (run 8 3 client)) ≤ 69 := + run_cost client room client_valid + +/-- A memory with too little room: the second stack would end past the 4-bit word range. -/ +example : ¬Fits 4 (empty.frontier + 2 * (7 + 1)) := by decide + +end ComplexityTests.DataStructureQueueMemory From e80dd976cefb8d294fc5f055b8e07374e5f4d0e9 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 18:46:16 -0500 Subject: [PATCH 12/18] feat(DataStructure): Fibonacci heap insert over a record of named cells Add Record.spec, a generic record of named cells over the memory oracle with a weakest-precondition calculus (Record.wp) and a one-unit-per-operation refinement into Memory.spec. Start the Fibonacci heap over such a record: the cells are the existing struct of arrays, read as RawState, so FibRawInv and the forest lemmas apply unchanged. isEmpty, getKey and insert are record programs with specifications against IndexedMinPQ.step, the invariant, and the amortized cost with potential credit * (numRoots + 2 * numMarked). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity.lean | 2 + Complexity/DataStructure/Memory/Record.lean | 239 +++++++ .../PriorityQueue/FibonacciHeap/Basic.lean | 626 ++++++++++++++++++ 3 files changed, 867 insertions(+) create mode 100644 Complexity/DataStructure/Memory/Record.lean create mode 100644 Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean diff --git a/Complexity.lean b/Complexity.lean index 8599d2709f..9f1f6dcdd1 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -2874,6 +2874,7 @@ 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.Field +public import Complexity.DataStructure.Memory.Record public import Complexity.DataStructure.Memory.Spec public import Complexity.DataStructure.ObliviousSequence public import Complexity.DataStructure.Online.Basic @@ -2887,6 +2888,7 @@ public import Complexity.DataStructure.PrefixSums.WordRAM.Dynamic public import Complexity.DataStructure.PrefixSums.WordRAM.Query public import Complexity.DataStructure.PrefixSums.WordRAM.Tree public import Complexity.DataStructure.PrefixSums.WordRAM.Update +public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.Basic public import Complexity.DataStructure.PriorityQueue.Spec public import Complexity.DataStructure.PriorityQueue.WordRAM.Basic public import Complexity.DataStructure.PriorityQueue.WordRAM.BinaryHeap diff --git a/Complexity/DataStructure/Memory/Record.lean b/Complexity/DataStructure/Memory/Record.lean new file mode 100644 index 0000000000..9746d46073 --- /dev/null +++ b/Complexity/DataStructure/Memory/Record.lean @@ -0,0 +1,239 @@ +/- +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.Spec +public import Complexity.DataStructure.StateTransition.Refinement + +/-! +# Records of named cells over the memory oracle + +A data structure with a fixed shape, such as a struct of arrays, stores its words in named cells: +`key v`, `par v`, a counter. `Record.spec ok w` is the interface to such a record. Its state gives +each cell of a type `ι` a value; an operation reads or writes one cell. The predicate `ok` says +which cells exist (for instance `v < n` for an array of length `n`), and admissibility asks that +an accessed cell exist and that a written value fit a `w`-bit word. + +A data structure is then a program over its record (`Record.Prog`), and its proofs see named +cells rather than addresses. `Record.wp` is the weakest precondition of such a program under a +postcondition on its answer, its final record and its number of operations. It evaluates by +`simp` one operation at a time (`wp_read_bind`, `wp_write_bind`), composes (`wp_bind`), and +determines admissibility, answer, final state and cost of the run (`wp_iff`). + +A `Record.Layout` places the cells in memory: an address for each cell, injective on the cells +that exist. `Record.refinement` implements the record over `Memory.spec w` by one memory operation +per record operation (`Record.amortized`). Address arithmetic, allocation and word-fit of addresses +are therefore proved once here, for every record. + +## Main definitions + +* `Record.Op`, `Record.step`, `Record.valid`, `Record.spec`: the record interface. +* `Record.Prog`, `Record.read`, `Record.write`: programs over a record. +* `Record.wp`: weakest precondition of a program, with the number of its operations. +* `Record.Layout`, `Record.Layout.abs`, `Record.Layout.Inv`: a placement in memory. +* `Record.refinement`: the record over the memory oracle. + +## Main results + +* `Record.wp_iff`: the weakest precondition is admissibility of the run together with the + postcondition on its answer, final state and length. +* `Record.wp_bind`, `Record.wp_mono`: sequencing and consequence. +* `Record.amortized`: each record operation costs one memory unit. +-/ + +@[expose] public section + +namespace Cslib.DataStructure.Record + +open Cslib.WordRAM + +variable {ι : Type} + +/-- Operations on a record of cells indexed by `ι`. -/ +inductive Op (ι : Type) where + /-- Read a cell. -/ + | read (i : ι) + /-- Write a value to a cell. -/ + | write (i : ι) (value : ℕ) + +/-- A read returns the cell's value. -/ +abbrev Op.Result : Op ι → Type + | .read _ => ℕ + | .write _ _ => Unit + +variable [DecidableEq ι] + +/-- The transition of each record operation. -/ +def step (g : ι → ℕ) : (o : Op ι) → (ι → ℕ) × o.Result + | .read i => (g, g i) + | .write i v => (Function.update g i v, ()) + +/-- Admissibility: the accessed cell exists, and a written value fits a `w`-bit word. -/ +def valid (ok : ι → Prop) (w : ℕ) (_ : ι → ℕ) : Op ι → Prop + | .read i => ok i + | .write i v => ok i ∧ Fits w v + +/-- The record interface with cells `ok` at word size `w`. -/ +abbrev spec (ok : ι → Prop) (w : ℕ) : StateTransitionSpec := + StateTransitionSpec.ofFn (State := ι → ℕ) (Op := Op ι) (Result := Op.Result) step (valid ok w) + +/-- Programs over a record with cells indexed by `ι`. -/ +abbrev Prog (ι : Type) (α : Type) : Type := PFunctor.FreeM ⟨Op ι, Op.Result⟩ α + +/-- Read a cell. -/ +abbrev read (i : ι) : Prog ι ℕ := PFunctor.FreeM.lift (P := ⟨Op ι, Op.Result⟩) (.read i) + +/-- Write a value to a cell. -/ +abbrev write (i : ι) (v : ℕ) : Prog ι Unit := + PFunctor.FreeM.lift (P := ⟨Op ι, Op.Result⟩) (.write i v) + +/-! ## Weakest preconditions -/ + +variable {ok : ι → Prop} {w : ℕ} {α β : Type} + +/-- The weakest precondition of `p` under `Q`: every operation of the run from `g` is admissible, +and `Q` holds of the answer, the final record and the number of operations. -/ +def wp (ok : ι → Prop) (w : ℕ) : Prog ι α → (α → (ι → ℕ) → ℕ → Prop) → (ι → ℕ) → Prop + | .pure a, Q, g => Q a g 0 + | .liftBind o k, Q, g => + valid ok w g o ∧ wp ok w (k (step g o).2) (fun a g' t => Q a g' (t + 1)) (step g o).1 + +@[simp] theorem wp_pure (a : α) (Q : α → (ι → ℕ) → ℕ → Prop) (g : ι → ℕ) : + wp ok w (pure a : Prog ι α) Q g ↔ Q a g 0 := Iff.rfl + +@[simp] theorem wp_read_bind (i : ι) (k : ℕ → Prog ι α) (Q : α → (ι → ℕ) → ℕ → Prop) + (g : ι → ℕ) : + wp ok w (read i >>= k) Q g ↔ ok i ∧ wp ok w (k (g i)) (fun a g' t => Q a g' (t + 1)) g := + Iff.rfl + +@[simp] theorem wp_write_bind (i : ι) (v : ℕ) (k : Unit → Prog ι α) + (Q : α → (ι → ℕ) → ℕ → Prop) (g : ι → ℕ) : + wp ok w (write i v >>= k) Q g ↔ + (ok i ∧ Fits w v) ∧ + wp ok w (k ()) (fun a g' t => Q a g' (t + 1)) (Function.update g i v) := + Iff.rfl + +@[simp] theorem wp_read (i : ι) (Q : ℕ → (ι → ℕ) → ℕ → Prop) (g : ι → ℕ) : + wp ok w (read i) Q g ↔ ok i ∧ Q (g i) g 1 := Iff.rfl + +@[simp] theorem wp_write (i : ι) (v : ℕ) (Q : Unit → (ι → ℕ) → ℕ → Prop) (g : ι → ℕ) : + wp ok w (write i v) Q g ↔ (ok i ∧ Fits w v) ∧ Q () (Function.update g i v) 1 := Iff.rfl + +/-- Consequence: a weaker postcondition. -/ +theorem wp_mono {p : Prog ι α} {Q Q' : α → (ι → ℕ) → ℕ → Prop} + (h : ∀ a g t, Q a g t → Q' a g t) {g : ι → ℕ} (hp : wp ok w p Q g) : wp ok w p Q' g := by + induction p generalizing Q Q' g with + | pure a => exact h _ _ _ hp + | liftBind o k ih => exact ⟨hp.1, ih _ (fun a g' t => h a g' (t + 1)) hp.2⟩ + +/-- Sequencing: the cost of `p >>= k` is the cost of `p` plus the cost of `k`. -/ +theorem wp_bind (p : Prog ι α) (k : α → Prog ι β) (Q : β → (ι → ℕ) → ℕ → Prop) (g : ι → ℕ) : + wp ok w (p >>= k) Q g ↔ + wp ok w p (fun a g' t => wp ok w (k a) (fun b g'' t' => Q b g'' (t + t')) g') g := by + induction p generalizing Q g with + | pure a => + change wp ok w (k a) Q g ↔ wp ok w (k a) (fun b g'' t' => Q b g'' (0 + t')) g + simp only [Nat.zero_add] + | liftBind o f ih => + change valid ok w g o ∧ wp ok w (f (step g o).2 >>= k) _ _ ↔ valid ok w g o ∧ wp ok w _ _ _ + rw [ih] + refine and_congr_right fun _ => Iff.of_eq ?_ + congr + funext a g' t + congr + funext b g'' t' + rw [Nat.add_right_comm] + +/-- The weakest precondition holds exactly when the run is admissible and `Q` holds of its answer, +final record and number of operations. -/ +theorem wp_iff (p : Prog ι α) (Q : α → (ι → ℕ) → ℕ → Prop) (g : ι → ℕ) : + wp ok w p Q g ↔ + (spec ok w).ValidHistory g ((spec ok w).clientHistory g p) ∧ + Q ((spec ok w).clientResult g p) ((spec ok w).clientState g p) + ((spec ok w).clientHistory g p).length := by + induction p generalizing Q g with + | pure a => exact ⟨fun h => ⟨trivial, h⟩, fun h => h.2⟩ + | liftBind o k ih => + simp only [wp, ih, StateTransitionSpec.clientHistory, StateTransitionSpec.clientResult, + StateTransitionSpec.clientState, StateTransitionSpec.runClient_liftBind, + StateTransitionSpec.validHistory_cons, List.length_cons, and_assoc] + +/-! ## Placement in memory -/ + +/-- A placement of the record's cells in memory: an address for each cell, injective on the +cells that exist. -/ +structure Layout (ok : ι → Prop) where + /-- The address of each cell. -/ + addr : ι → ℕ + /-- Distinct existing cells have distinct addresses. -/ + addr_injOn : ∀ i j, ok i → ok j → addr i = addr j → i = j + +namespace Layout + +variable (L : Layout ok) + +/-- The record operations as memory operations at the cells' addresses. -/ +def methods (w : ℕ) : Methods (spec ok w) (Memory.spec w) + | .read i => Memory.read (L.addr i) + | .write i v => Memory.write (L.addr i) v + +variable [DecidablePred ok] + +/-- The record stored in memory; cells that do not exist read as `0`. -/ +def abs (m : Memory.State) (i : ι) : ℕ := if ok i then m.mem (L.addr i) else 0 + +/-- Every existing cell is allocated. -/ +def Inv (m : Memory.State) : Prop := ∀ i, ok i → L.addr i < m.frontier + +/-- Writing an existing cell writes its address. -/ +theorem abs_write {m : Memory.State} {i : ι} (hi : ok i) (v : ℕ) : + L.abs ⟨Function.update m.mem (L.addr i) v, m.frontier⟩ = Function.update (L.abs m) i v := by + funext j + by_cases hj : ok j + · by_cases hji : j = i + · subst hji + simp [abs, hj] + · have ha : L.addr j ≠ L.addr i := fun h => hji (L.addr_injOn j i hj hi h) + simp [abs, hj, hji, Function.update_of_ne ha] + · have hji : j ≠ i := fun h => hj (h ▸ hi) + simp [abs, hj, hji] + +end Layout + +/-- The record over the memory oracle: each operation is the memory operation at the cell's +address. -/ +def refinement [DecidablePred ok] (L : Layout ok) (w : ℕ) : + Refinement (spec ok w) (Memory.spec w) := + Refinement.ofFn (L.methods w) L.Inv L.abs + (by + intro m o hm hv + cases o with + | read i => exact ⟨hm i hv, trivial⟩ + | write i v => exact ⟨⟨hm i hv.1, hv.2⟩, trivial⟩) + (by + intro m o hm hv + cases o with + | read i => + refine ⟨?_, hm⟩ + simp [Layout.methods, Layout.abs, StateTransitionSpec.clientState, + StateTransitionSpec.clientResult, step, show ok i from hv] + | write i v => + refine ⟨?_, hm⟩ + simp only [Layout.methods, StateTransitionSpec.clientState, + StateTransitionSpec.clientResult, StateTransitionSpec.runClient_lift, + StateTransitionSpec.stepFn, Memory.step_write, step] + rw [L.abs_write hv.1]) + +/-- Each record operation costs one memory unit; no potential is needed. -/ +theorem amortized [DecidablePred ok] (L : Layout ok) (w : ℕ) : + (refinement L w).Amortized Memory.charge (fun _ _ => 1) fun _ => 0 := by + apply Refinement.Amortized.ofFn + intro m o _ _ + cases o <;> simp [refinement, Layout.methods, StateTransitionSpec.clientHistory] + +end Cslib.DataStructure.Record diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean new file mode 100644 index 0000000000..29e9c92dd1 --- /dev/null +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean @@ -0,0 +1,626 @@ +/- +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.Record +public import Complexity.DataStructure.PriorityQueue.WordRAM.FibonacciHeap.Consolidate +public import Complexity.DataStructure.PriorityQueue.WordRAM.FibonacciHeap.Cut + +/-! +# A Fibonacci heap as a record of named cells + +This file sets up the Fibonacci heap [Fredman and Tarjan][FredmanTarjan1987] of +`Cslib.DataStructure.PriorityQueue.WordRAM.FibonacciHeap` as a program over a record of named +cells (`Record.spec`), rather than as hand-stepped word-RAM code. The record has the same struct +of arrays: per handle `key`, `par`, `child`, `left`, `right`, `deg`, `mark` and `inHeap`, a +consolidation table `cons`, and four scalars. `view` reads a record as the existing +`RawState n`, so the existing invariant `FibRawInv` and its forest lemmas apply unchanged. + +* `absRaw` and `abs` decode the abstract `IndexedMinPQ.State n`; `Inv` is `FibRawInv` of the + decoded state. The abstraction is a function, as `FibRawInv.unique` shows it must be. +* `potential` is `unit * (numRoots + 2 * numMarked)`, the textbook potential + [Cormen et al., Section 19.1][CLRS2009] counted in record operations. +* `isEmpty`, `getKey` and `insert` are programs over the record, and their specifications + (`wp_isEmpty`, `wp_getKey`, `wp_insert`) are stated with `Record.wp`: the operations are + admissible, the result and the decoded state are those of `IndexedMinPQ.step`, the invariant is + preserved, and the amortized cost is bounded. + +The forest reasoning behind `insert` is `RootList.addRoot`, a statement about `RawState n` +alone: adding a valid root tree to a valid root list. The program-level proofs evaluate the +programs with `simp` and apply it. + +## Main definitions + +* `Cell`, `Cell.ok`, `view`: the record's cells and its reading as `RawState n`. +* `absRaw`, `abs`, `Inv`, `potential`: abstraction, invariant and potential. +* `RootList`: the root-list part of `FibRawInv`. +* `spliceAfter`, `addRoot`, `isEmpty`, `getKey`, `insert`: record programs. + +## Main results + +* `view_update_key`, …: writes as updates of `RawState n`. +* `absRaw_eq_of_fibRawInv`: the invariant determines the abstract state. +* `RootList.addRoot`: adding a valid root tree keeps a valid root list. +* `wp_isEmpty`, `wp_getKey`, `wp_insert`: the first three operations. + +## 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*, + Chapter 19][CLRS2009] +-/ + +@[expose] public section + +namespace Cslib.DataStructure.PriorityQueue.FibonacciHeap + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.PriorityQueue +open Cslib.DataStructure.PriorityQueue.WordRAM.FibonacciHeap + +/-! ## The record -/ + +/-- The cells of a Fibonacci heap: eight per-handle arrays, the consolidation table and four +scalars. Indices are words; `Cell.ok` says which cells exist. -/ +inductive Cell where + /-- The key of a handle. -/ + | key (v : ℕ) + /-- The parent of a handle: `0` for a root, `p + 1` for parent `p`. -/ + | par (v : ℕ) + /-- Some child of a handle: `0` for none, `c + 1` for child `c`. -/ + | child (v : ℕ) + /-- The predecessor of a handle in its circular sibling list. -/ + | left (v : ℕ) + /-- The successor of a handle in its circular sibling list. -/ + | right (v : ℕ) + /-- The number of children of a handle. -/ + | deg (v : ℕ) + /-- The cascading-cut mark of a handle. -/ + | mark (v : ℕ) + /-- Whether a handle is present. -/ + | inHeap (v : ℕ) + /-- The consolidation table entry for degree `d`: `0` for none, `u + 1` for root `u`. -/ + | cons (d : ℕ) + /-- The minimum root: `0` for an empty heap, `m + 1` for root `m`. -/ + | minRoot + /-- The number of roots. -/ + | numRoots + /-- The number of marked handles. -/ + | numMarked + /-- The number of handles present. -/ + | sz + deriving DecidableEq + +/-- The cells of a heap on `n` handles: array entries below `n`, table entries up to `n`, and the +scalars. -/ +def Cell.ok (n : ℕ) : Cell → Prop + | .key v | .par v | .child v | .left v | .right v | .deg v | .mark v | .inHeap v => v < n + | .cons d => d ≤ n + | .minRoot | .numRoots | .numMarked | .sz => True + +instance (n : ℕ) : DecidablePred (Cell.ok n) := fun c => by + cases c <;> unfold Cell.ok <;> infer_instance + +/-- The record as the existing raw view of a Fibonacci heap. -/ +def view (n : ℕ) (g : Cell → ℕ) : RawState n where + key v := g (.key v) + par v := g (.par v) + child v := g (.child v) + left v := g (.left v) + right v := g (.right v) + deg v := g (.deg v) + mark v := g (.mark v) + inHeap v := g (.inHeap v) + cons d := g (.cons d) + minRoot := g .minRoot + numRoots := g .numRoots + numMarked := g .numMarked + sz := g .sz + +/-- Programs over the heap's record. -/ +abbrev Prog (α : Type) : Type := Record.Prog Cell α + +/-- Read a cell. -/ +abbrev rd (c : Cell) : Prog ℕ := Record.read c + +/-- Write a cell. -/ +abbrev wr (c : Cell) (x : ℕ) : Prog Unit := Record.write c x + +/-! ## Writes as updates of the raw view -/ + +section View + +variable {n : ℕ} (g : Cell → ℕ) (x : ℕ) + +@[simp] theorem view_update_key (v : Fin n) : + view n (Function.update g (.key v) x) = + { view n g with key := Function.update (view n g).key v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_par (v : Fin n) : + view n (Function.update g (.par v) x) = + { view n g with par := Function.update (view n g).par v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_child (v : Fin n) : + view n (Function.update g (.child v) x) = + { view n g with child := Function.update (view n g).child v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_left (v : Fin n) : + view n (Function.update g (.left v) x) = + { view n g with left := Function.update (view n g).left v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_right (v : Fin n) : + view n (Function.update g (.right v) x) = + { view n g with right := Function.update (view n g).right v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_deg (v : Fin n) : + view n (Function.update g (.deg v) x) = + { view n g with deg := Function.update (view n g).deg v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_mark (v : Fin n) : + view n (Function.update g (.mark v) x) = + { view n g with mark := Function.update (view n g).mark v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_inHeap (v : Fin n) : + view n (Function.update g (.inHeap v) x) = + { view n g with inHeap := Function.update (view n g).inHeap v x } := by + simp only [view] + congr 1 + funext u + simp [Function.update_apply, Fin.val_inj] + +@[simp] theorem view_update_cons (d : ℕ) : + view n (Function.update g (.cons d) x) = + { view n g with cons := Function.update (view n g).cons d x } := by + simp only [view] + congr 1 + funext e + simp [Function.update_apply] + +@[simp] theorem view_update_minRoot : + view n (Function.update g .minRoot x) = { view n g with minRoot := x } := rfl + +@[simp] theorem view_update_numRoots : + view n (Function.update g .numRoots x) = { view n g with numRoots := x } := rfl + +@[simp] theorem view_update_numMarked : + view n (Function.update g .numMarked x) = { view n g with numMarked := x } := rfl + +@[simp] theorem view_update_sz : + view n (Function.update g .sz x) = { view n g with sz := x } := rfl + +end View + +/-! ## Abstraction, invariant and potential -/ + +/-- The priority queue a raw state stores: present handles with their keys. -/ +def absRaw {n : ℕ} (st : RawState n) : IndexedMinPQ.State n := + fun v => if st.inHeap v = 0 then none else some (st.key v) + +/-- The priority queue a record stores. -/ +abbrev abs (n : ℕ) (g : Cell → ℕ) : IndexedMinPQ.State n := absRaw (view n g) + +/-- The implementation invariant: the existing Fibonacci-heap invariant, of the decoded queue. -/ +def Inv (n K : ℕ) (g : Cell → ℕ) : Prop := FibRawInv n K (abs n g) (view n g) + +/-- The invariant determines the stored queue. -/ +theorem absRaw_eq_of_fibRawInv {n K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + (h : FibRawInv n K s st) : absRaw st = s := by + obtain ⟨_, _, _, _, hin, hkeys, _⟩ := h + funext v + cases hs : s v with + | none => + have : st.inHeap v = 0 := by + by_contra h0 + simpa [hs] using (hin v).1.mp h0 + simp [absRaw, this] + | some k => + have h0 : st.inHeap v ≠ 0 := (hin v).1.mpr (by simp [hs]) + simp [absRaw, h0, (hkeys v k hs).1] + +/-- A record satisfies the invariant when its raw view satisfies `FibRawInv` of any queue. -/ +theorem inv_of_fibRawInv {n K : ℕ} {s : IndexedMinPQ.State n} {g : Cell → ℕ} + (h : FibRawInv n K s (view n g)) : Inv n K g ∧ abs n g = s := by + have he := absRaw_eq_of_fibRawInv h + refine ⟨?_, he⟩ + unfold Inv abs + rw [he] + exact h + +/-- Credits per root and per two marks, in record operations. -/ +abbrev credit : ℕ := 24 + +/-- The Fibonacci-heap potential `credit * (numRoots + 2 * numMarked)`. -/ +def potential (n : ℕ) (g : Cell → ℕ) : ℕ := + credit * ((view n g).numRoots + 2 * (view n g).numMarked) + +/-! ## The root list -/ + +/-- The root-list part of `FibRawInv`: an empty heap has no minimum root; otherwise the roots +form a circular list headed by the minimum root `m`. -/ +def RootList {n : ℕ} (st : RawState n) (ts : List (FHTree n)) : Prop := + (ts = [] ∧ st.minRoot = 0) ∨ + ∃ (m : Fin n) (rtail : List (Fin n)), + st.minRoot = m.val + 1 ∧ + IsCircList st.left st.right (m :: rtail) ∧ + (m :: rtail).Perm (ts.map FHTree.root) ∧ + ∀ T ∈ ts, IndexedMinPQ.PrioLE (m, st.key m) (T.root, st.key T.root) + +/-- The effect of adding root `u`: on an empty heap, `u` forms the root list alone; otherwise `u` +is spliced in after the minimum root `m` and becomes the minimum if it precedes `m`. Either way the +number of roots grows by one. -/ +def AddsRoot {n : ℕ} (st : RawState n) (u : Fin n) (st' : RawState n) : Prop := + (st.minRoot = 0 ∧ + st' = { st with + left := Function.update st.left u u.val + right := Function.update st.right u u.val + minRoot := u.val + 1 + numRoots := st.numRoots + 1 }) ∨ + ∃ m r : Fin n, st.minRoot = m.val + 1 ∧ st.right m = r.val ∧ + st' = { st with + left := Function.update (Function.update st.left u m.val) r u.val + right := Function.update (Function.update st.right u r.val) m u.val + minRoot := if IndexedMinPQ.PrioLT (u, st.key u) (m, st.key m) then u.val + 1 else m.val + 1 + numRoots := st.numRoots + 1 } + +/-- Adding a valid root tree to a forest of valid root trees with a valid root list keeps every tree +a valid root and the root list valid. Only roots change their sibling pointers, and +`ValidSubtree` reads sibling pointers only below the root. -/ +theorem RootList.addRoot {n : ℕ} {st st' : RawState n} {T_u : FHTree n} {ts : List (FHTree n)} + (hnd : (forestNodes (T_u :: ts)).Nodup) (hTu : ValidRoot st none T_u) + (hts : ∀ T ∈ ts, ValidRoot st none T) (hrl : RootList st ts) + (hadd : AddsRoot st T_u.root st') : + (∀ T ∈ T_u :: ts, ValidRoot st' none T) ∧ RootList st' (T_u :: ts) := by + have hvalid : ∀ T ∈ T_u :: ts, ValidRoot st none T := by + intro T hT + rcases List.mem_cons.mp hT with rfl | hT + exacts [hTu, hts T hT] + -- A strict descendant is no root, so the frame of `ValidRoot` excludes the changed pointers. + have hdesc : ∀ T ∈ T_u :: ts, ∀ x ∈ forestNodes T.children, ∀ R ∈ T_u :: ts, x ≠ R.root := + fun T hT x hx R hR => descendant_ne_root_of_nodup hnd hT hR hx + have hroot_ts : ∀ x ∈ ts.map FHTree.root, ∃ R ∈ T_u :: ts, x = R.root := fun x hx => by + obtain ⟨R, hR, rfl⟩ := List.mem_map.mp hx + exact ⟨R, List.mem_cons_of_mem _ hR, rfl⟩ + have hu_ts : T_u.root ∉ ts.map FHTree.root := fun hx => by + obtain ⟨R, hR, hRu⟩ := List.mem_map.mp hx + obtain ⟨-, -, hdisj⟩ := List.nodup_append.mp hnd + exact hdisj _ T_u.root_mem_nodes _ + (mem_forestNodes_iff.mpr ⟨R, hR, hRu ▸ R.root_mem_nodes⟩) rfl + rcases hadd with ⟨h0, rfl⟩ | ⟨m, r, hm, hr, rfl⟩ + · have hts0 : ts = [] := by + rcases hrl with ⟨h, _⟩ | ⟨_, _, hm', _⟩ + · exact h + · omega + subst hts0 + refine ⟨fun T hT => (hvalid T hT).frame_tree (fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩) + fun x hx => ?_, Or.inr ⟨T_u.root, [], rfl, IsCircList.singleton _ _ _, by simp, + fun T hT => by simp only [List.mem_singleton] at hT; subst hT; exact .refl _⟩⟩ + have hx := hdesc T hT x hx T_u List.mem_cons_self + simp [Function.update_of_ne hx] + · obtain ⟨m', rtail, hm', hcirc, hperm, hle⟩ := hrl.resolve_left fun ⟨_, h0⟩ => by omega + obtain rfl : m' = m := Fin.ext (by omega) + obtain ⟨r', hr', hr'_mem⟩ := hcirc.right_head + obtain rfl : r' = r := Fin.ext (by omega) + obtain ⟨Rm, hRm, hRm_eq⟩ := hroot_ts m' (hperm.subset List.mem_cons_self) + obtain ⟨Rr, hRr, hRr_eq⟩ := hroot_ts r' (hperm.subset hr'_mem) + have hu_mr : T_u.root ∉ m' :: rtail := fun h => hu_ts (hperm.subset h) + have hcirc' := hcirc.insertAfter hu_mr hr + refine ⟨fun T hT => (hvalid T hT).frame_tree (fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩) + fun x hx => ?_, Or.inr ?_⟩ + · have hxu := hdesc T hT x hx T_u List.mem_cons_self + have hxm := hdesc T hT x hx Rm hRm + have hxr := hdesc T hT x hx Rr hRr + rw [← hRm_eq] at hxm + rw [← hRr_eq] at hxr + simp [Function.update_of_ne hxu, Function.update_of_ne hxm, Function.update_of_ne hxr] + · have hperm' : (T_u.root :: m' :: rtail).Perm ((T_u :: ts).map FHTree.root) := + List.Perm.cons _ hperm + by_cases hlt : IndexedMinPQ.PrioLT (T_u.root, st.key T_u.root) (m', st.key m') + · refine ⟨T_u.root, rtail ++ [m'], by simp [hlt], ?_, ?_, fun T hT => ?_⟩ + · simpa using hcirc'.rotate_one + · exact (List.Perm.cons _ (List.perm_append_singleton _ _)).trans hperm' + · rcases List.mem_cons.mp hT with rfl | hT + · exact .refl _ + · exact hlt.le.trans (hle T hT) + · refine ⟨m', T_u.root :: rtail, by simp [hlt], hcirc', (List.Perm.swap _ _ _).trans hperm', + fun T hT => ?_⟩ + rcases List.mem_cons.mp hT with rfl | hT + · exact IndexedMinPQ.not_prioLT_iff_prioLE.mp hlt + · exact hle T hT + +/-- Adding a root changes only the root list and the number of roots. -/ +theorem AddsRoot.exists_eq {n : ℕ} {st st' : RawState n} {u : Fin n} (h : AddsRoot st u st') : + ∃ (left right : Fin n → ℕ) (minRoot : ℕ), st' = { st with + left := left + right := right + minRoot := minRoot + numRoots := st.numRoots + 1 } := by + rcases h with ⟨_, rfl⟩ | ⟨_, _, _, _, rfl⟩ <;> exact ⟨_, _, _, rfl⟩ + +/-- A new handle `v` with key `k`, as a childless unmarked root, before it joins the root list. -/ +def newNode {n : ℕ} (st : RawState n) (v : Fin n) (k : ℕ) : RawState n := + { st with + key := Function.update st.key v k + par := Function.update st.par v 0 + child := Function.update st.child v 0 + deg := Function.update st.deg v 0 + mark := Function.update st.mark v 0 + inHeap := Function.update st.inHeap v 1 } + +/-- **Insertion preserves the invariant.** Creating `v` as a singleton tree and adding it to the +root list stores `v` with key `k`, with one more root and one more handle. -/ +theorem FibRawInv.insert {n K : ℕ} {s : IndexedMinPQ.State n} {st st' : RawState n} {v : Fin n} + {k : ℕ} (h : FibRawInv n K s st) (hv : s v = none) (hk : k ≤ K) + (hadd : AddsRoot (newNode st v k) v st') : + FibRawInv n K (Function.update s v (some k)) { st' with sz := st'.sz + 1 } := by + obtain ⟨ts, hts, hnd, hdom, hin, hkeys, hsz, hnr, hnm, hcons, hrl⟩ := h + have hv_fn : v ∉ forestNodes ts := fun hm => by simpa [hv] using (hdom v).mp hm + have hin_v : st.inHeap v = 0 := by + by_contra h0 + simpa [hv] using (hin v).1.mp h0 + have hnd' : (forestNodes (.node v [] :: ts)).Nodup := by + simpa [forestNodes, FHTree.nodes] using ⟨hv_fn, hnd⟩ + have hne : ∀ T ∈ ts, ∀ x ∈ T.nodes, x ≠ v := fun T hT x hx hxv => + hv_fn (mem_forestNodes_iff.mpr ⟨T, hT, hxv ▸ hx⟩) + have hTv : ValidRoot (newNode st v k) none (.node v []) := + ValidRoot.singleton (by simp [newNode]) (by simp [newNode]) + (by simp [newNode]) (by simp [newNode]) (by simp [newNode]) + have hts₁ : ∀ T ∈ ts, ValidRoot (newNode st v k) none T := fun T hT => + (hts T hT).frame_tree (fun x hx => by + simp [newNode, Function.update_of_ne (hne T hT x hx)]) fun _ _ => ⟨rfl, rfl⟩ + have hrl₁ : RootList (newNode st v k) ts := by + rcases hrl with h0 | ⟨m, rtail, hm, hcirc, hperm, hle⟩ + · exact Or.inl h0 + · have hroot : ∀ T ∈ ts, T.root ≠ v := fun T hT => hne T hT _ T.root_mem_nodes + obtain ⟨Tm, hTm, rfl⟩ := List.mem_map.mp (hperm.subset List.mem_cons_self) + refine Or.inr ⟨Tm.root, rtail, hm, hcirc, hperm, fun T hT => ?_⟩ + simpa [newNode, Function.update_of_ne (hroot T hT), + Function.update_of_ne (hroot Tm hTm)] using hle T hT + obtain ⟨hts', hrl'⟩ := RootList.addRoot hnd' hTv hts₁ hrl₁ hadd + obtain ⟨left, right, minRoot, rfl⟩ := hadd.exists_eq + refine ⟨.node v [] :: ts, fun T hT => (hts' T hT).frame_tree + (fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩) (fun _ _ => ⟨rfl, rfl⟩), hnd', fun x => ?_, + fun x => ?_, fun x kx hx => ?_, ?_, by simp [newNode, hnr], ?_, + fun d hd => hcons d hd, hrl'⟩ + · by_cases hxv : x = v + · subst hxv; simp [forestNodes, FHTree.nodes] + · simp [forestNodes, FHTree.nodes, hxv, hdom x] + · by_cases hxv : x = v + · subst hxv; simp [newNode] + · simpa [newNode, hxv] using hin x + · by_cases hxv : x = v + · subst hxv + simp only [Function.update_self, Option.some.injEq] at hx + subst hx + simp [newNode, hk] + · rw [Function.update_of_ne hxv] at hx + simpa [newNode, hxv] using hkeys x kx hx + · have hvd : v ∉ IndexedMinPQ.dom s := IndexedMinPQ.notMem_dom_iff.mpr hv + simp [newNode, hsz, Finset.card_insert_of_notMem hvd] + · refine hnm.trans (markedCount_congr fun x => ?_).symm + by_cases hxv : x = v + · subst hxv; simp [newNode, hin_v] + · simp [newNode, hxv] + +/-! ## Programs -/ + +/-- Splice `u` into a circular list right after `h`. -/ +def spliceAfter (h u : ℕ) : Prog Unit := do + let r ← rd (.right h) + wr (.left u) h + wr (.left r) u + wr (.right u) r + wr (.right h) u + +/-- Add root `u` to the root list, updating the minimum root and the number of roots. -/ +def addRoot (u : ℕ) : Prog Unit := do + let m ← rd .minRoot + if m = 0 then + wr (.left u) u + wr (.right u) u + wr .minRoot (u + 1) + else + spliceAfter (m - 1) u + let ku ← rd (.key u) + let km ← rd (.key (m - 1)) + if IndexedMinPQ.RawPrioLT (u, ku) (m - 1, km) then wr .minRoot (u + 1) + let r ← rd .numRoots + wr .numRoots (r + 1) + +/-- Whether the heap is empty: whether there is no minimum root. -/ +def isEmpty : Prog Bool := do + let m ← rd .minRoot + pure (decide (m = 0)) + +/-- The key of handle `v`, if present. -/ +def getKey (v : ℕ) : Prog (Option ℕ) := do + let b ← rd (.inHeap v) + if b = 0 then pure none else do + let k ← rd (.key v) + pure (some k) + +/-- Insert handle `v` with key `k` as a new singleton root. -/ +def insert (v k : ℕ) : Prog Unit := do + wr (.key v) k + wr (.par v) 0 + wr (.child v) 0 + wr (.deg v) 0 + wr (.mark v) 0 + wr (.inHeap v) 1 + addRoot v + let c ← rd .sz + wr .sz (c + 1) + +/-! ## Evaluating the programs -/ + +section Programs + +variable {n w : ℕ} + +/-- Adding a root evaluates to `AddsRoot` in at most eleven operations. -/ +theorem wp_addRoot {g : Cell → ℕ} {u : Fin n} + (hroot : (view n g).minRoot = 0 ∨ ∃ (m : Fin n) (rtail : List (Fin n)), + (view n g).minRoot = m.val + 1 ∧ IsCircList (view n g).left (view n g).right (m :: rtail)) + (hfit : Fits w n) (hnr : Fits w ((view n g).numRoots + 1)) + {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g' t, t ≤ 11 → AddsRoot (view n g) u (view n g') → Q () g' t) : + Record.wp (Cell.ok n) w (addRoot u) Q g := by + have hu := u.isLt + rcases hroot with h0 | ⟨m, rtail, hm, hcirc⟩ + · have h0' : g .minRoot = 0 := h0 + simp only [addRoot, Record.wp_bind, Record.wp_read, Record.wp_write, h0', ite_true, + Function.update_apply, reduceCtorEq, ite_false, Cell.ok, true_and] + refine ⟨⟨hu, hfit.of_le hu.le⟩, ⟨hu, hfit.of_le hu.le⟩, hfit.of_le hu, hnr, + hQ _ _ (by omega) (Or.inl ⟨h0, ?_⟩)⟩ + simp only [view_update_left, view_update_right, view_update_minRoot, view_update_numRoots] + rfl + · obtain ⟨r, hr, -⟩ := hcirc.right_head + have hm' : g .minRoot = m.val + 1 := hm + have hr' : g (.right m) = r.val := hr + have hmn := m.isLt + have hrn := r.isLt + simp only [addRoot, spliceAfter, Record.wp_bind, Record.wp_read, Record.wp_write, hm', + Nat.add_one_ne_zero, ite_false, Nat.add_sub_cancel, hr', Function.update_apply, + reduceCtorEq, Cell.ok, true_and] + refine ⟨hmn, ⟨hu, hfit.of_le hmn.le⟩, ⟨hrn, hfit.of_le hu.le⟩, ⟨hu, hfit.of_le hrn.le⟩, + ⟨hmn, hfit.of_le hu.le⟩, hu, hmn, ?_⟩ + have hview : ∀ x, view n (Function.update (Function.update (Function.update (Function.update + (Function.update (Function.update g (.left u) m) (.left r) u) (.right u) r) (.right m) u) + .minRoot x) .numRoots (g .numRoots + 1)) = { view n g with + left := Function.update (Function.update (view n g).left u m.val) r u.val + right := Function.update (Function.update (view n g).right u r.val) m u.val + minRoot := x + numRoots := (view n g).numRoots + 1 } := fun x => by + simp only [view_update_left, view_update_right, view_update_minRoot, view_update_numRoots] + rfl + by_cases hlt : IndexedMinPQ.RawPrioLT (↑u, g (Cell.key ↑u)) (↑m, g (Cell.key ↑m)) + · simp only [hlt, ite_true, Record.wp_bind, Record.wp_read, Record.wp_write, + Function.update_apply, reduceCtorEq, ite_false, Cell.ok, true_and] + refine ⟨hfit.of_le hu, hnr, hQ _ _ (by omega) (Or.inr ⟨m, r, hm, hr, ?_⟩)⟩ + simp only [show IndexedMinPQ.PrioLT (u, (view n g).key u) (m, (view n g).key m) from hlt, + ite_true] + exact hview _ + · simp only [hlt, ite_false, Record.wp_bind, Record.wp_read, Record.wp_write, + Function.update_apply, reduceCtorEq, Cell.ok, true_and] + refine ⟨hnr, hQ _ _ (by omega) (Or.inr ⟨m, r, hm, hr, ?_⟩)⟩ + simp only [show ¬IndexedMinPQ.PrioLT (u, (view n g).key u) (m, (view n g).key m) from hlt, + ite_false, view_update_left, view_update_right, view_update_numRoots, ← hm] + rfl + +/-- The root list of a valid heap is empty or headed by the minimum root, as `addRoot` needs. -/ +theorem minRoot_cases {K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + (h : FibRawInv n K s st) : st.minRoot = 0 ∨ ∃ (m : Fin n) (rtail : List (Fin n)), + st.minRoot = m.val + 1 ∧ IsCircList st.left st.right (m :: rtail) := by + obtain ⟨_, _, _, _, _, _, _, _, _, _, hrl⟩ := h + rcases hrl with ⟨_, h0⟩ | ⟨m, rtail, hm, hcirc, _⟩ + exacts [Or.inl h0, Or.inr ⟨m, rtail, hm, hcirc⟩] + +/-- With a handle absent, there is room for one more root and one more handle. -/ +theorem counts_lt_of_absent {K : ℕ} {s : IndexedMinPQ.State n} {st : RawState n} + (h : FibRawInv n K s st) {v : Fin n} (hv : s v = none) : + st.numRoots + 1 ≤ n ∧ st.sz + 1 ≤ n := by + obtain ⟨ts, _, hnd, hdom, _, _, hsz, hnr, _⟩ := h + have hv_fn : v ∉ forestNodes ts := fun hm => by simpa [hv] using (hdom v).mp hm + have hlen : (v :: forestNodes ts).length ≤ n := by + simpa using (List.nodup_cons.mpr ⟨hv_fn, hnd⟩).length_le_card + have hts := forestNodes_length_ge ts + have hdom_lt : (IndexedMinPQ.dom s).card < n := by + have hsub : IndexedMinPQ.dom s ⊂ Finset.univ := + Finset.ssubset_iff_subset_ne.mpr ⟨Finset.subset_univ _, fun he => by + have := IndexedMinPQ.notMem_dom_iff.mpr hv + rw [he] at this + exact this (Finset.mem_univ v)⟩ + simpa using Finset.card_lt_card hsub + simp only [List.length_cons] at hlen + omega + +/-- **Emptiness.** `isEmpty` reads the minimum root once. -/ +theorem wp_isEmpty {K : ℕ} {g : Cell → ℕ} (hI : Inv n K g) : + Record.wp (Cell.ok n) w isEmpty (fun b g' t => + b = decide (IndexedMinPQ.dom (abs n g) = ∅) ∧ g' = g ∧ t = 1) g := by + simp only [isEmpty, Record.wp_read_bind, Record.wp_pure, Cell.ok, true_and, and_true] + refine decide_eq_decide.mpr ⟨fun h0 => (FibRawInv.findMin_eq_none hI h0).1, fun hemp => ?_⟩ + rcases minRoot_cases hI with h0 | ⟨m, _, hm, _⟩ + · exact h0 + · have hmem := IndexedMinPQ.mem_dom_iff.mpr ⟨_, (FibRawInv.findMin_eq_some hI hm).2.1⟩ + simp [hemp] at hmem + +/-- **Key lookup.** `getKey v` reads the presence flag and, if present, the key. No invariant is +needed: the abstraction reads the same two cells. -/ +theorem wp_getKey {g : Cell → ℕ} (v : Fin n) : + Record.wp (Cell.ok n) w (getKey v) (fun a g' t => a = abs n g v ∧ g' = g ∧ t ≤ 2) g := by + have hv := v.isLt + by_cases h0 : g (.inHeap v) = 0 + · simp only [getKey, Record.wp_read_bind, h0, ite_true, Record.wp_pure, Cell.ok] + exact ⟨hv, by simp [abs, absRaw, view, h0], trivial, by omega⟩ + · simp only [getKey, Record.wp_read_bind, h0, ite_false, Record.wp_pure, Cell.ok] + exact ⟨hv, hv, by simp [abs, absRaw, view, h0], trivial, by omega⟩ + +/-- **Insertion.** `insert v k` stores `v` with key `k`, preserves the invariant, and costs at most +`19` operations plus one credit for the new root. -/ +theorem wp_insert {K : ℕ} {g : Cell → ℕ} {v : Fin n} {k : ℕ} (hI : Inv n K g) + (hv : abs n g v = none) (hk : k ≤ K) (hn : Fits w n) (hK : Fits w K) : + Record.wp (Cell.ok n) w (insert v k) (fun _ g' t => + abs n g' = Function.update (abs n g) v (some k) ∧ Inv n K g' ∧ + t + potential n g' ≤ 19 + credit + potential n g) g := by + have hvn := v.isLt + obtain ⟨hnr, hsz⟩ := counts_lt_of_absent hI hv + simp only [insert, Record.wp_bind, Record.wp_write, Cell.ok, true_and] + refine ⟨⟨hvn, hK.of_le hk⟩, ⟨hvn, fits_zero w⟩, ⟨hvn, fits_zero w⟩, ⟨hvn, fits_zero w⟩, + ⟨hvn, fits_zero w⟩, ⟨hvn, hn.of_le (by omega)⟩, ?_⟩ + refine wp_addRoot ?_ hn ?_ fun g₂ t ht hadd => ?_ + · simpa only [view_update_key, view_update_par, view_update_child, view_update_deg, + view_update_mark, view_update_inHeap] using minRoot_cases hI + · simpa only [view_update_key, view_update_par, view_update_child, view_update_deg, + view_update_mark, view_update_inHeap] using hn.of_le hnr + simp only [view_update_key, view_update_par, view_update_child, view_update_deg, + view_update_mark, view_update_inHeap] at hadd + change AddsRoot (newNode (view n g) v k) v (view n g₂) at hadd + obtain ⟨left, right, minRoot, heq⟩ := hadd.exists_eq + have hsz₂ : g₂ .sz = (view n g).sz := congrArg RawState.sz heq + simp only [Record.wp_read, Cell.ok, true_and, hsz₂] + refine ⟨hn.of_le hsz, ?_⟩ + have hinv := FibRawInv.insert hI hv hk hadd + obtain ⟨hI', habs'⟩ := inv_of_fibRawInv (g := Function.update g₂ .sz ((view n g).sz + 1)) + (by rw [view_update_sz, ← hsz₂]; exact hinv) + refine ⟨habs', hI', ?_⟩ + have hnr₂ : (view n g₂).numRoots = (view n g).numRoots + 1 := by rw [heq]; rfl + have hnm₂ : (view n g₂).numMarked = (view n g).numMarked := by rw [heq]; rfl + simp only [potential, credit, view_update_sz, hnr₂, hnm₂] + omega + +end Programs + +end Cslib.DataStructure.PriorityQueue.FibonacciHeap From 7fde8d6582e1885170e7ec2d11b2015931889cb4 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 19:02:41 -0500 Subject: [PATCH 13/18] feat(DataStructure): Fibonacci heap decreaseKey with cascading cuts over a record decreaseKey cuts v from its parent when heap order breaks, cascades up the marked ancestors (fuel bounded by the number of marks), then stores the key and updates the minimum root. Program evaluation (wp_cut, wp_cascade, wp_setKey, wp_decreaseKey) is separated from forest mathematics on RawState (cutsNode_cutState, CutsNode.cascading, Cascading.mark, ...), which reuses ValidSubtree.exists_cut, mark_pending, lower_key_no_cut and CutInv.to_fibRawInv unchanged. Amortized cost: 104 record operations. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity.lean | 1 + .../FibonacciHeap/DecreaseKey.lean | 955 ++++++++++++++++++ 2 files changed, 956 insertions(+) create mode 100644 Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean diff --git a/Complexity.lean b/Complexity.lean index 9f1f6dcdd1..dd6ef485d9 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -2889,6 +2889,7 @@ public import Complexity.DataStructure.PrefixSums.WordRAM.Query public import Complexity.DataStructure.PrefixSums.WordRAM.Tree public import Complexity.DataStructure.PrefixSums.WordRAM.Update 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 diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean new file mode 100644 index 0000000000..932561163e --- /dev/null +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean @@ -0,0 +1,955 @@ +/- +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.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. + +## 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 From 9e906e71cd5a24194a410b9a1b11c1be34bca94d Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 19:26:54 -0500 Subject: [PATCH 14/18] feat(DataStructure): Fibonacci heap extractMin with consolidation over a record extractMin detaches the minimum root, scatters its children and the other roots into the degree table (linking equal degrees), and gathers the table into a new root list. The loops carry the existing SlotInv; linking goes through ValidRoot.link; RootList.addRoot builds the new root list. The largest degree is a program value. Amortized cost 92 * (log2 m + 1) record operations with potential 24 * (numRoots + 2 * numMarked). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- Complexity.lean | 1 + .../FibonacciHeap/ExtractMin.lean | 1156 +++++++++++++++++ 2 files changed, 1157 insertions(+) create mode 100644 Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean diff --git a/Complexity.lean b/Complexity.lean index dd6ef485d9..97dbc80c36 100644 --- a/Complexity.lean +++ b/Complexity.lean @@ -2890,6 +2890,7 @@ public import Complexity.DataStructure.PrefixSums.WordRAM.Tree public import Complexity.DataStructure.PrefixSums.WordRAM.Update public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.Basic public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.DecreaseKey +public import Complexity.DataStructure.PriorityQueue.FibonacciHeap.ExtractMin public import Complexity.DataStructure.PriorityQueue.Spec public import Complexity.DataStructure.PriorityQueue.WordRAM.Basic public import Complexity.DataStructure.PriorityQueue.WordRAM.BinaryHeap diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean new file mode 100644 index 0000000000..91f3bcc64e --- /dev/null +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean @@ -0,0 +1,1156 @@ +/- +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.PriorityQueue.FibonacciHeap.DecreaseKey + +/-! +# Fibonacci-heap `extractMin` over a record of named cells + +`extractMin n` removes the minimum root `z` and consolidates +[Fredman and Tarjan][FredmanTarjan1987] [Cormen et al., Section 19.2][CLRS2009]: + +1. `scatterList … true` walks `z`'s children along their sibling list, makes each an unmarked + root, and `scatter`s it into the degree table `cons`. Scattering links the tree with the + table's tree of equal degree (`link`, `linkAs`) until it reaches an empty slot. +2. `scatterList … false` does the same for the other roots, walking the root list from `z`'s + right neighbour. +3. `gather` scans the table up to the largest degree placed, moving each tree to a new root list + with `addRoot`, and empties the table. + +The largest degree placed is a program value, returned by `scatter` and threaded through the +loops, so the record layout is the same as for the other operations. + +The proof splits as in `Basic.lean` and `DecreaseKey.lean`: + +* program evaluation: `wp_linkAs`, `wp_link`, `wp_scatter`, `wp_scatterList`, `wp_gather` and + `wp_extractMin`. Each loop lemma is an induction carrying the existing table invariant + `SlotInv`; +* forest mathematics on `RawState n`: `LinksAs.validRoot` (linking, through the existing + `ValidRoot.link`), `ValidSubtree.unmarkRoot`, `markedCount_unmark`, `AddsRoot.validRoot_other` + and `SlotInv.length_le`. They reuse `SlotInv.empty`, `lookup`, `step_collision`, + `insert_empty`, `done_of_cleared`, `deg_bounds_of_extra`, `ValidSubtree.deg_bounds`, + `RightChain` and `RootList.addRoot` unchanged. `Frames` and `Scattered` describe what a phase + leaves unchanged. + +Each link costs `14` operations and removes a tree; each scattered root costs at most `9` more; +each table slot costs at most `13`. With `credit = 24` per root, the roots' credits pay for +their scattering, and the amortized cost is at most `92 * (log₂ m + 1)` on a queue of `m` +handles (`extractCharge`), by the Fibonacci degree bound. + +## Main definitions + +* `linkAs`, `link`, `scatter`, `scatterList`, `gather`, `extractMin`: record programs. +* `LinksAs`: the effect of linking on the raw view. +* `Frames`, `Scattered`: the fields a phase leaves unchanged. +* `extractCharge`: the amortized charge `92 * (Nat.log 2 m + 1)`. + +## Main results + +* `LinksAs.validRoot`: linking two valid roots of equal degree yields a valid root. +* `wp_scatter`, `wp_scatterList`, `wp_gather`: the three phases. +* `wp_extractMin`: `extractMin` implements `IndexedMinPQ.step` with amortized cost + `extractCharge`. + +## 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.2][CLRS2009] +-/ + +@[expose] public section + +namespace Cslib.DataStructure.PriorityQueue.FibonacciHeap + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.PriorityQueue +open Cslib.DataStructure.PriorityQueue.WordRAM.FibonacciHeap + +/-! ## Linking two roots -/ + +/-- Make root `x` the newest child of root `u`. -/ +def linkAs (u x : ℕ) : Prog Unit := do + wr (.par x) (u + 1) + let d ← rd (.deg u) + if d = 0 then + wr (.left x) x + wr (.right x) x + wr (.child u) (x + 1) + else + let c ← rd (.child u) + spliceAfter (c - 1) x + wr (.deg u) (d + 1) + +/-- The effect of making root `x` the newest child of root `u`: `x` gets parent `u` and joins +`u`'s child list (alone, or after the head child `c`), and `u`'s degree grows by one. -/ +def LinksAs {n : ℕ} (st : RawState n) (u x : Fin n) (st' : RawState n) : Prop := + (st.deg u = 0 ∧ st' = { st with + par := Function.update st.par x (u.val + 1) + left := Function.update st.left x x.val + right := Function.update st.right x x.val + child := Function.update st.child u (x.val + 1) + deg := Function.update st.deg u 1 }) ∨ + ∃ c r : Fin n, st.deg u ≠ 0 ∧ st.child u = c.val + 1 ∧ st.right c = r.val ∧ st' = { st with + par := Function.update st.par x (u.val + 1) + left := Function.update (Function.update st.left x c.val) r x.val + right := Function.update (Function.update st.right x r.val) c x.val + deg := Function.update st.deg u (st.deg u + 1) } + +/-- The degree of a valid subtree's root is its number of children. -/ +theorem ValidSubtree.deg_root {n : ℕ} {st : RawState n} {pending : Option (Fin n)} + {T : FHTree n} (hT : ValidSubtree st pending T) : st.deg T.root = T.children.length := by + cases hT with + | mk _ _ hdeg _ _ _ _ _ => exact hdeg + +/-- The child pointer of a valid subtree's root heads the circular list of its children. -/ +theorem ValidSubtree.child_root {n : ℕ} {st : RawState n} {pending : Option (Fin n)} + {T : FHTree n} (hT : ValidSubtree st pending T) : + (T.children = [] ∧ st.child T.root = 0) ∨ + ∃ (h : Fin n) (tail : List (Fin n)), st.child T.root = h.val + 1 ∧ + IsCircList st.left st.right (h :: tail) ∧ + (h :: tail).Perm (T.children.map FHTree.root) := by + cases hT with + | mk _ _ _ hchild _ _ _ _ => exact hchild + +/-- **Linking keeps a valid root**: if `u` precedes `x` and their trees have equal degrees, making +`x` the newest child of `u` yields a valid root tree; nodes outside the two trees keep every +field. -/ +theorem LinksAs.validRoot {n : ℕ} {st st' : RawState n} {T₁ T₂ : FHTree n} + (h₁ : ValidRoot st none T₁) (h₂ : ValidRoot st none T₂) (hnd : (T₁.nodes ++ T₂.nodes).Nodup) + (hdeg : T₁.deg = T₂.deg) + (hlt : IndexedMinPQ.PrioLT (T₁.root, st.key T₁.root) (T₂.root, st.key T₂.root)) + (hlink : LinksAs st T₁.root T₂.root st') : + ValidRoot st' none (.node T₁.root (T₁.children ++ [T₂])) ∧ + ∀ y ∉ T₁.nodes ++ T₂.nodes, st'.par y = st.par y ∧ st'.left y = st.left y ∧ + st'.right y = st.right y ∧ st'.child y = st.child y ∧ st'.deg y = st.deg y := by + have hu₁ : T₁.root ∈ T₁.nodes ++ T₂.nodes := List.mem_append_left _ T₁.root_mem_nodes + have hx₂ : T₂.root ∈ T₁.nodes ++ T₂.nodes := List.mem_append_right _ T₂.root_mem_nodes + have hux : T₁.root ≠ T₂.root := fun e => + (List.nodup_append.mp hnd).2.2 _ T₁.root_mem_nodes _ T₂.root_mem_nodes e + -- `u`'s children are strict descendants of `T₁`, hence not `u` and not `x`. + have hch_ne : ∀ c ∈ T₁.children, c.root ≠ T₁.root ∧ c.root ≠ T₂.root := fun c hc => by + have hdesc : c.root ∈ forestNodes T₁.children := + mem_forestNodes_iff.mpr ⟨c, hc, c.root_mem_nodes⟩ + have hnd₁ := (List.nodup_append.mp hnd).1 + rw [T₁.nodes_eq] at hnd₁ + refine ⟨fun e => (List.nodup_cons.mp hnd₁).1 (e ▸ hdesc), fun e => + (List.nodup_append.mp hnd).2.2 _ (T₁.nodes_eq ▸ List.mem_cons_of_mem _ hdesc) _ + T₂.root_mem_nodes e⟩ + rcases hlink with ⟨hd0, rfl⟩ | ⟨c, r, hd0, hchild_u, hcr, rfl⟩ + · have hch_nil : T₁.children = [] := by + have := h₁.1 + cases this with + | mk _ _ hdeg' _ _ _ _ _ => simp_all + refine ⟨h₁.link h₂ hnd hdeg hlt (fun _ _ => ⟨rfl, rfl, rfl⟩) + ⟨by simp [FHTree.deg, hch_nil], ?_⟩ + ⟨by simp [Function.update_of_ne hux, h₁.2.1], by simp, fun y _ hy => by simp [hy]⟩ + ⟨⟨T₂.root, [], by simp, IsCircList.singleton _ _ _, by simp [hch_nil]⟩, + fun y _ hy => by simp [hy]⟩ + (fun y _ hy _ => by simp [hy]), fun y hy => ?_⟩ + · intro y _ hy; simp [hy] + · have hyu : y ≠ T₁.root := fun e => hy (e ▸ hu₁) + have hyx : y ≠ T₂.root := fun e => hy (e ▸ hx₂) + simp [hyu, hyx] + · -- `u`'s child list is `c :: tail`, and `x` is spliced in after `c`. + have hcirc : ∃ tail, IsCircList st.left st.right (c :: tail) ∧ + (c :: tail).Perm (T₁.children.map FHTree.root) := by + rcases ValidSubtree.child_root h₁.1 with ⟨hnil, _⟩ | ⟨h, tail, hch, hcirc, hperm⟩ + · exact absurd ((ValidSubtree.deg_root h₁.1).trans (by simp [hnil])) hd0 + · obtain rfl : h = c := Fin.ext (by omega) + exact ⟨tail, hcirc, hperm⟩ + obtain ⟨tail, hcirc, hperm⟩ := hcirc + have hch_mem : ∀ y ∈ c :: tail, ∃ c' ∈ T₁.children, y = c'.root := fun y hy => by + obtain ⟨c', hc', rfl⟩ := List.mem_map.mp (hperm.subset hy) + exact ⟨c', hc', rfl⟩ + obtain ⟨r', hr', hr'_mem⟩ := hcirc.right_head + obtain rfl : r' = r := Fin.ext (hr'.symm.trans hcr) + obtain ⟨Cc, hCc, hc_eq⟩ := hch_mem c List.mem_cons_self + obtain ⟨Cr, hCr, hr_eq⟩ := hch_mem r' hr'_mem + have hx_notin : T₂.root ∉ c :: tail := fun hm => by + obtain ⟨c', hc', e⟩ := hch_mem _ hm + exact (hch_ne c' hc').2 e.symm + have hcx : c ≠ T₂.root := fun e => hx_notin (e ▸ List.mem_cons_self) + have hrx : r' ≠ T₂.root := fun e => hx_notin (e ▸ hr'_mem) + have hcu : c ≠ T₁.root := hc_eq ▸ (hch_ne Cc hCc).1 + have hru : r' ≠ T₁.root := hr_eq ▸ (hch_ne Cr hCr).1 + have hc_nodes : c ∈ T₁.nodes ++ T₂.nodes := List.mem_append_left _ (T₁.nodes_eq ▸ + List.mem_cons_of_mem _ (mem_forestNodes_iff.mpr ⟨Cc, hCc, hc_eq ▸ Cc.root_mem_nodes⟩)) + have hr_nodes : r' ∈ T₁.nodes ++ T₂.nodes := List.mem_append_left _ (T₁.nodes_eq ▸ + List.mem_cons_of_mem _ (mem_forestNodes_iff.mpr ⟨Cr, hCr, hr_eq ▸ Cr.root_mem_nodes⟩)) + refine ⟨h₁.link h₂ hnd hdeg hlt (fun _ _ => ⟨rfl, rfl, rfl⟩) + ⟨by simp [FHTree.deg, ValidSubtree.deg_root h₁.1], fun y _ hy => by simp [hy]⟩ + ⟨by simp [Function.update_of_ne hux, h₁.2.1], by simp, fun y _ hy => by simp [hy]⟩ + ⟨⟨c, T₂.root :: tail, hchild_u, hcirc.insertAfter hx_notin hcr, + ?_⟩, fun _ _ _ => rfl⟩ (fun y _ hy hch => ?_), fun y hy => ?_⟩ + · simp only [List.map_append, List.map_cons, List.map_nil] + exact (List.Perm.swap _ _ _).trans ((List.Perm.cons _ hperm).trans + (List.perm_append_singleton _ _).symm) + · have hyc : y ≠ c := fun e => hch Cc hCc (e.trans hc_eq) + have hyr : y ≠ r' := fun e => hch Cr hCr (e.trans hr_eq) + simp [hy, hyc, hyr] + · have hyu : y ≠ T₁.root := fun e => hy (e ▸ hu₁) + have hyx : y ≠ T₂.root := fun e => hy (e ▸ hx₂) + have hyc : y ≠ c := fun e => hy (e ▸ hc_nodes) + have hyr : y ≠ r' := fun e => hy (e ▸ hr_nodes) + simp [hyu, hyx, hyc, hyr] + +/-- Link the roots `a` and `b` of equal degree: the one that precedes becomes the parent of the +other. Returns the new root. -/ +def link (a b : ℕ) : Prog ℕ := do + let ka ← rd (.key a) + let kb ← rd (.key b) + if IndexedMinPQ.RawPrioLT (b, kb) (a, ka) then + linkAs b a + pure b + else + linkAs a b + pure a + +/-- `st'` agrees with `st` except on the tree fields of `nodes` and on the consolidation table. -/ +structure Frames {n : ℕ} (st st' : RawState n) (nodes : List (Fin n)) : Prop where + key : st'.key = st.key + inHeap : st'.inHeap = st.inHeap + mark : st'.mark = st.mark + minRoot : st'.minRoot = st.minRoot + numRoots : st'.numRoots = st.numRoots + numMarked : st'.numMarked = st.numMarked + sz : st'.sz = st.sz + out : ∀ y ∉ nodes, st'.par y = st.par y ∧ st'.left y = st.left y ∧ st'.right y = st.right y ∧ + st'.child y = st.child y ∧ st'.deg y = st.deg y + +/-- Frames compose. -/ +theorem Frames.trans {n : ℕ} {st st' st'' : RawState n} {A : List (Fin n)} + (h₁ : Frames st st' A) (h₂ : Frames st' st'' A) : Frames st st'' A := by + refine ⟨h₂.key.trans h₁.key, h₂.inHeap.trans h₁.inHeap, h₂.mark.trans h₁.mark, + h₂.minRoot.trans h₁.minRoot, h₂.numRoots.trans h₁.numRoots, h₂.numMarked.trans h₁.numMarked, + h₂.sz.trans h₁.sz, fun y hy => ?_⟩ + obtain ⟨a₁, b₁, c₁, d₁, e₁⟩ := h₁.out y hy + obtain ⟨a₂, b₂, c₂, d₂, e₂⟩ := h₂.out y hy + exact ⟨a₂.trans a₁, b₂.trans b₁, c₂.trans c₁, d₂.trans d₁, e₂.trans e₁⟩ + +/-- Frames grow with the set of changed nodes. -/ +theorem Frames.mono {n : ℕ} {st st' : RawState n} {A B : List (Fin n)} (h : Frames st st' A) + (hAB : ∀ y ∈ A, y ∈ B) : Frames st st' B := + { h with out := fun y hy => h.out y fun hA => hy (hAB y hA) } + +/-- A valid root tree outside the changed nodes stays valid. -/ +theorem Frames.validRoot {n : ℕ} {st st' : RawState n} {A : List (Fin n)} (h : Frames st st' A) + {T : FHTree n} (hT : ValidRoot st none T) (hA : ∀ y ∈ T.nodes, y ∉ A) : ValidRoot st' none T := + hT.frame_nodes fun y hy => by + obtain ⟨a, b, c, d, e⟩ := h.out y (hA y hy) + exact ⟨congrFun h.inHeap y, congrFun h.mark y, e, d, congrFun h.key y, a, b, c⟩ + +/-- Linking changes no key, presence flag, mark, scalar or table entry. -/ +theorem LinksAs.frames {n : ℕ} {st st' : RawState n} {u x : Fin n} {A : List (Fin n)} + (hl : LinksAs st u x st') + (hout : ∀ y ∉ A, st'.par y = st.par y ∧ st'.left y = st.left y ∧ st'.right y = st.right y ∧ + st'.child y = st.child y ∧ st'.deg y = st.deg y) : + Frames st st' A ∧ st'.cons = st.cons := by + refine ⟨⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, hout⟩, ?_⟩ <;> + rcases hl with ⟨-, rfl⟩ | ⟨-, -, -, -, -, rfl⟩ <;> rfl + +/-- Place root `u` in the consolidation table: while the slot of its degree holds a root, empty +the slot, link the two roots and continue with the new root. Returns the largest degree placed, +at least `md`. `fuel` bounds the number of links. -/ +def scatter : ℕ → ℕ → ℕ → Prog ℕ + | 0, _, md => pure md + | fuel + 1, u, md => do + let d ← rd (.deg u) + let c ← rd (.cons d) + if c = 0 then + wr (.cons d) (u + 1) + pure (max md d) + else + wr (.cons d) 0 + let u' ← link u (c - 1) + scatter fuel u' md + +/-- Changing only the table frames every tree field. -/ +theorem frames_cons {n : ℕ} (st : RawState n) (cons : ℕ → ℕ) (A : List (Fin n)) : + Frames st { st with cons := cons } A := + ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl⟩⟩ + +/-- Scatter the `k` roots of a list linked by `right` from `x`. With `prep`, each is first made an +unmarked root: these are the children of the extracted minimum. -/ +def scatterList (fuel : ℕ) (prep : Bool) : ℕ → ℕ → ℕ → Prog ℕ + | 0, _, md => pure md + | k + 1, x, md => do + let nxt ← rd (.right x) + if prep then + wr (.par x) 0 + let mk ← rd (.mark x) + wr (.mark x) 0 + let c ← rd .numMarked + wr .numMarked (c - mk) + let md' ← scatter fuel x md + scatterList fuel prep k nxt md' + +/-- `st'` agrees with `st` except on the tree fields and marks of `nodes`, the table and the number +of marks. -/ +structure Scattered {n : ℕ} (st st' : RawState n) (nodes : List (Fin n)) : Prop where + key : st'.key = st.key + inHeap : st'.inHeap = st.inHeap + minRoot : st'.minRoot = st.minRoot + numRoots : st'.numRoots = st.numRoots + sz : st'.sz = st.sz + out : ∀ y ∉ nodes, st'.par y = st.par y ∧ st'.left y = st.left y ∧ st'.right y = st.right y ∧ + st'.child y = st.child y ∧ st'.deg y = st.deg y ∧ st'.mark y = st.mark y + +/-- `Scattered` composes. -/ +theorem Scattered.trans {n : ℕ} {st st' st'' : RawState n} {A : List (Fin n)} + (h₁ : Scattered st st' A) (h₂ : Scattered st' st'' A) : Scattered st st'' A := by + refine ⟨h₂.key.trans h₁.key, h₂.inHeap.trans h₁.inHeap, h₂.minRoot.trans h₁.minRoot, + h₂.numRoots.trans h₁.numRoots, h₂.sz.trans h₁.sz, fun y hy => ?_⟩ + obtain ⟨a₁, b₁, c₁, d₁, e₁, f₁⟩ := h₁.out y hy + obtain ⟨a₂, b₂, c₂, d₂, e₂, f₂⟩ := h₂.out y hy + exact ⟨a₂.trans a₁, b₂.trans b₁, c₂.trans c₁, d₂.trans d₁, e₂.trans e₁, f₂.trans f₁⟩ + +/-- `Scattered` grows with the set of changed nodes. -/ +theorem Scattered.mono {n : ℕ} {st st' : RawState n} {A B : List (Fin n)} + (h : Scattered st st' A) (hAB : ∀ y ∈ A, y ∈ B) : Scattered st st' B := + { h with out := fun y hy => h.out y fun hA => hy (hAB y hA) } + +/-- A frame is `Scattered`. -/ +theorem Frames.scattered {n : ℕ} {st st' : RawState n} {A : List (Fin n)} + (h : Frames st st' A) : Scattered st st' A := by + refine ⟨h.key, h.inHeap, h.minRoot, h.numRoots, h.sz, fun y hy => ?_⟩ + obtain ⟨a, b, c, d, e⟩ := h.out y hy + exact ⟨a, b, c, d, e, congrFun h.mark y⟩ + +/-- A valid subtree outside the changed nodes stays valid. -/ +theorem Frames.validSubtree {n : ℕ} {st st' : RawState n} {A : List (Fin n)} + (h : Frames st st' A) {T : FHTree n} (hT : ValidSubtree st none T) + (hA : ∀ y ∈ T.nodes, y ∉ A) : ValidSubtree st' none T := + hT.frame (fun y hy => by + obtain ⟨-, -, -, d, e⟩ := h.out y (hA y hy) + exact ⟨congrFun h.inHeap y, congrFun h.mark y, e, d, congrFun h.key y⟩) + fun y hy => by + obtain ⟨a, b, c, -, -⟩ := h.out y (hA y (T.nodes_eq ▸ List.mem_cons_of_mem _ hy)) + exact ⟨a, b, c, Iff.rfl⟩ + +/-- The root of a valid subtree has mark at most one. -/ +theorem ValidSubtree.mark_root_le {n : ℕ} {st : RawState n} {pending : Option (Fin n)} + {T : FHTree n} (hT : ValidSubtree st pending T) : st.mark T.root ≤ 1 := by + cases hT with + | mk _ hmark _ _ _ _ _ _ => exact hmark + +/-- Clearing the parent and mark of a valid subtree's root makes it a valid root tree. -/ +theorem ValidSubtree.unmarkRoot {n : ℕ} {st : RawState n} {T : FHTree n} + (hT : ValidSubtree st none T) (hnd : T.nodes.Nodup) (numMarked : ℕ) : + ValidRoot { st with + par := Function.update st.par T.root 0 + mark := Function.update st.mark T.root 0 + numMarked := numMarked } none T := by + have hne : ∀ x ∈ forestNodes T.children, x ≠ T.root := fun x hx e => by + rw [T.nodes_eq] at hnd + exact (List.nodup_cons.mp hnd).1 (e ▸ hx) + refine ⟨hT.frame_root_mark hnd (by simp) ⟨rfl, rfl, rfl, rfl⟩ + (fun x hx => by simp [hne x hx]) (fun x hx => by simp [hne x hx]), by simp, by simp⟩ + +/-- Unmarking one present handle lowers the number of marks by its mark. -/ +theorem markedCount_unmark {n : ℕ} {st st' : RawState n} {x : Fin n} (hin : st.inHeap x ≠ 0) + (hmk : st.mark x ≤ 1) (hx : st'.mark x = 0) (hinh : st'.inHeap = st.inHeap) + (hother : ∀ y, y ≠ x → st'.mark y = st.mark y) : + markedCount st' = markedCount st - st.mark x := by + have hiff : ∀ y, y ≠ x → ((st'.inHeap y ≠ 0 ∧ st'.mark y ≠ 0) ↔ + (st.inHeap y ≠ 0 ∧ st.mark y ≠ 0)) := fun y hy => by rw [hinh, hother y hy] + by_cases hm0 : st.mark x = 0 + · rw [hm0, Nat.sub_zero] + refine markedCount_congr fun y => ?_ + by_cases hy : y = x + · subst hy; simp [hx, hm0] + · exact hiff y hy + · have := markedCount_clear_one hin hm0 hx hiff + omega + +/-- Move the table's roots at degrees `d, d + 1, …` (`k` slots) to the root list. -/ +def gather : ℕ → ℕ → Prog Unit + | 0, _ => pure () + | k + 1, d => do + let c ← rd (.cons d) + if c = 0 then gather k (d + 1) + else + wr (.cons d) 0 + addRoot (c - 1) + gather k (d + 1) + +/-- Adding a root keeps every other valid root tree valid: only roots change sibling pointers. -/ +theorem AddsRoot.validRoot_other {n : ℕ} {st st' : RawState n} {u : Fin n} + {ts : List (FHTree n)} (hadd : AddsRoot st u st') (hrl : RootList st ts) + (hts : ∀ T ∈ ts, ValidRoot st none T) (hu : st.par u = 0) {R : FHTree n} + (hR : ValidRoot st none R) : ValidRoot st' none R := by + have hpar : ∀ y ∈ forestNodes R.children, st.par y ≠ 0 := fun y hy => by + obtain ⟨q, -, hq⟩ := hR.1.par_of_mem_children y hy + omega + have hroot0 : ∀ m : Fin n, ∀ rtail, (m :: rtail).Perm (ts.map FHTree.root) → + ∀ y ∈ m :: rtail, st.par y = 0 := fun m rtail hperm y hy => by + obtain ⟨T, hT, rfl⟩ := List.mem_map.mp (hperm.subset hy) + exact (hts T hT).2.1 + rcases hadd with ⟨-, rfl⟩ | ⟨m, r, hm, hr, rfl⟩ + · refine hR.frame_tree (fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩) fun y hy => ?_ + have hyu : y ≠ u := fun e => hpar y hy (e ▸ hu) + simp [hyu] + · obtain ⟨m', rtail, hm', hcirc, hperm, -⟩ := hrl.resolve_left fun ⟨_, h0⟩ => by omega + obtain rfl : m' = m := Fin.ext (by omega) + obtain ⟨r', hr', hr'_mem⟩ := hcirc.right_head + obtain rfl : r' = r := Fin.ext (hr'.symm.trans hr) + refine hR.frame_tree (fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩) fun y hy => ?_ + have hyu : y ≠ u := fun e => hpar y hy (e ▸ hu) + have hym : y ≠ m' := fun e => hpar y hy (e ▸ hroot0 m' rtail hperm m' List.mem_cons_self) + have hyr : y ≠ r' := fun e => hpar y hy (e ▸ hroot0 m' rtail hperm r' hr'_mem) + simp [hyu, hym, hyr] + +/-- A valid root tree outside the scattered nodes stays valid. -/ +theorem Scattered.validRoot {n : ℕ} {st st' : RawState n} {A : List (Fin n)} + (h : Scattered st st' A) {T : FHTree n} (hT : ValidRoot st none T) + (hA : ∀ y ∈ T.nodes, y ∉ A) : ValidRoot st' none T := + hT.frame_nodes fun y hy => by + obtain ⟨a, b, c, d, e, f⟩ := h.out y (hA y hy) + exact ⟨congrFun h.inHeap y, f, e, d, congrFun h.key y, a, b, c⟩ + +/-- The children of a valid subtree are valid subtrees. -/ +theorem ValidSubtree.sub {n : ℕ} {st : RawState n} {pending : Option (Fin n)} {T : FHTree n} + (hT : ValidSubtree st pending T) : ∀ c ∈ T.children, ValidSubtree st pending c := by + cases hT with + | mk _ _ _ _ _ _ _ hsub => exact hsub + +/-- The table holds at most one tree per degree up to `maxDeg`. -/ +theorem SlotInv.length_le {n sz maxDeg : ℕ} {st : RawState n} {slots : List (FHTree n)} + (h : SlotInv n sz st slots maxDeg) : slots.length ≤ maxDeg + 1 := by + have hsub : (slots.map FHTree.deg).toFinset ⊆ Finset.range (maxDeg + 1) := fun d hd => by + obtain ⟨T, hT, rfl⟩ := List.mem_map.mp (List.mem_toFinset.mp hd) + exact Finset.mem_range.mpr (Nat.lt_succ_of_le (h.2.1 T hT).2) + have := Finset.card_le_card hsub + rw [List.toFinset_card_of_nodup h.1, List.length_map, Finset.card_range] at this + exact this + +/-- Remove and return the minimum of a heap on `n` handles: detach the minimum root `z`, scatter +its children and the other roots into the table, and gather the table into a new root list. -/ +def extractMin (n : ℕ) : Prog (Option (Fin n × ℕ)) := do + let m ← rd .minRoot + if m = 0 then pure none + else + let kz ← rd (.key (m - 1)) + wr (.inHeap (m - 1)) 0 + let c ← rd .sz + wr .sz (c - 1) + let rz ← rd (.right (m - 1)) + let nr ← rd .numRoots + let dz ← rd (.deg (m - 1)) + let cz ← rd (.child (m - 1)) + let md ← scatterList (n + 1) true dz (cz - 1) 0 + let md' ← scatterList (n + 1) false (nr - 1) rz md + wr .minRoot 0 + wr .numRoots 0 + gather (md' + 1) 0 + pure (if h : m - 1 < n then some (⟨m - 1, h⟩, kz) else none) + +/-- The amortized charge of `extractMin` on a queue with `m` handles. -/ +def extractCharge (m : ℕ) : ℕ := 92 * (Nat.log 2 m + 1) + +section Programs + +variable {n w : ℕ} + +/-- Making `x` the newest child of `u` evaluates to `LinksAs` in at most nine operations. -/ +theorem wp_linkAs {g : Cell → ℕ} {u x : Fin n} + (hch : (view n g).deg u ≠ 0 → ∃ c r : Fin n, (view n g).child u = c.val + 1 ∧ + (view n g).right c = r.val) + (hdeg : (view n g).deg u + 1 ≤ n) (hfit : Fits w n) {Q : Unit → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g' t, t ≤ 9 → LinksAs (view n g) u x (view n g') → Q () g' t) : + Record.wp (Cell.ok n) w (linkAs u x) Q g := by + have hun := u.isLt + have hxn := x.isLt + have hd : g (.deg u) = (view n g).deg u := rfl + by_cases h0 : (view n g).deg u = 0 + · simp only [linkAs, Record.wp_write_bind, Record.wp_read_bind, Record.wp_write, + Function.update_apply, reduceCtorEq, ite_false, hd, h0, ite_true, Cell.ok] + split_ands + all_goals try first | omega | exact hfit.of_le (by omega) + refine hQ _ _ (by omega) (Or.inl ⟨h0, ?_⟩) + simp only [view_update_par, view_update_left, view_update_right, view_update_child, + view_update_deg] + · obtain ⟨c, r, hc, hr⟩ := hch h0 + have hc' : g (.child u) = c.val + 1 := hc + simp only [linkAs, Record.wp_write_bind, Record.wp_read_bind, + Function.update_apply, reduceCtorEq, ite_false, hd, h0, hc', Nat.add_sub_cancel, Cell.ok] + refine ⟨⟨hxn, hfit.of_le (by omega)⟩, hun, hun, ?_⟩ + rw [Record.wp_bind] + refine wp_spliceAfter (by simpa using hr) hfit ?_ + simp only [Record.wp_write, Cell.ok] + split_ands + all_goals try first | omega | exact hfit.of_le (by omega) + refine hQ _ _ (by omega) (Or.inr ⟨c, r, h0, hc, hr, ?_⟩) + simp only [view_update_par, view_update_left, view_update_right, view_update_deg] + +/-- **Linking two roots** of equal degree evaluates, in at most eleven operations, to a valid root +tree of one more degree on the same nodes, framing everything else. -/ +theorem wp_link {g : Cell → ℕ} {T₁ T₂ : FHTree n} (h₁ : ValidRoot (view n g) none T₁) + (h₂ : ValidRoot (view n g) none T₂) (hnd : (T₁.nodes ++ T₂.nodes).Nodup) + (hdeg : T₁.deg = T₂.deg) (hdn : T₁.deg + 2 ≤ n) (hfit : Fits w n) + {Q : ℕ → (Cell → ℕ) → ℕ → Prop} + (hQ : ∀ g' t (T : FHTree n), t ≤ 11 → T.deg = T₁.deg + 1 → + T.nodes.Perm (T₁.nodes ++ T₂.nodes) → ValidRoot (view n g') none T → + Frames (view n g) (view n g') (T₁.nodes ++ T₂.nodes) → + (view n g').cons = (view n g).cons → Q T.root g' t) : + Record.wp (Cell.ok n) w (link T₁.root T₂.root) Q g := by + have hch : ∀ T : FHTree n, ValidRoot (view n g) none T → (view n g).deg T.root ≠ 0 → + ∃ c r : Fin n, (view n g).child T.root = c.val + 1 ∧ (view n g).right c = r.val := + fun T hT h0 => by + rcases ValidSubtree.child_root hT.1 with ⟨hnil, _⟩ | ⟨c, tail, hc, hcirc, -⟩ + · exact absurd ((ValidSubtree.deg_root hT.1).trans (by simp [hnil])) h0 + · obtain ⟨r, hr, -⟩ := hcirc.right_head + exact ⟨c, r, hc, hr⟩ + have hd₁ := ValidSubtree.deg_root h₁.1 + have hd₂ := ValidSubtree.deg_root h₂.1 + have e₁ : T₁.deg = T₁.children.length := rfl + have e₂ : T₂.deg = T₂.children.length := rfl + have hux : T₁.root ≠ T₂.root := fun e => + (List.nodup_append.mp hnd).2.2 _ T₁.root_mem_nodes _ T₂.root_mem_nodes e + have hnd' : (T₂.nodes ++ T₁.nodes).Nodup := List.perm_append_comm.nodup_iff.mp hnd + have hsub : ∀ y ∈ T₂.nodes ++ T₁.nodes, y ∈ T₁.nodes ++ T₂.nodes := fun y hy => + List.perm_append_comm.mem_iff.mp hy + simp only [link, Record.wp_read_bind, Cell.ok] + refine ⟨T₁.root.isLt, T₂.root.isLt, ?_⟩ + by_cases hlt : IndexedMinPQ.PrioLT (T₂.root, (view n g).key T₂.root) + (T₁.root, (view n g).key T₁.root) + · have hlt' : IndexedMinPQ.RawPrioLT (↑T₂.root, g (.key ↑T₂.root)) + (↑T₁.root, g (.key ↑T₁.root)) := hlt + simp only [hlt', ite_true] + rw [Record.wp_bind] + refine wp_linkAs (hch T₂ h₂) (by omega) hfit fun g' t ht hl => ?_ + obtain ⟨hv, hout⟩ := LinksAs.validRoot h₂ h₁ hnd' hdeg.symm hlt hl + obtain ⟨hfr, hcons⟩ := LinksAs.frames hl hout + exact hQ g' _ (.node T₂.root (T₂.children ++ [T₁])) (by omega) + (by simp [FHTree.deg]; omega) (by rw [link_nodes_eq, FHTree.eta]; exact List.perm_append_comm) + hv (hfr.mono hsub) hcons + · have hlt' : ¬IndexedMinPQ.RawPrioLT (↑T₂.root, g (.key ↑T₂.root)) + (↑T₁.root, g (.key ↑T₁.root)) := hlt + have hlt₁ := (IndexedMinPQ.prioLT_or_prioLT_of_ne hux ((view n g).key T₁.root) + ((view n g).key T₂.root)).resolve_right hlt + simp only [hlt', ite_false] + rw [Record.wp_bind] + refine wp_linkAs (hch T₁ h₁) (by omega) hfit fun g' t ht hl => ?_ + obtain ⟨hv, hout⟩ := LinksAs.validRoot h₁ h₂ hnd hdeg hlt₁ hl + obtain ⟨hfr, hcons⟩ := LinksAs.frames hl hout + exact hQ g' _ (.node T₁.root (T₁.children ++ [T₂])) (by omega) + (by simp [FHTree.deg]) (by rw [link_nodes_eq, FHTree.eta]) hv hfr hcons + +/-- **Scattering one root.** Placing a valid root tree in the table keeps the table valid, on the +same nodes, framing everything else. Each link costs `14` operations and removes a tree, so the +cost is at most `3` plus `14` per tree removed. -/ +theorem wp_scatter {sz : ℕ} {z : Fin n} (hfit : Fits w n) : + ∀ (fuel : ℕ) {g : Cell → ℕ} {T : FHTree n} {slots : List (FHTree n)} {md : ℕ}, + SlotInv n sz (view n g) slots md → ValidRoot (view n g) none T → + (z :: forestNodes (T :: slots)).Nodup → (forestNodes (T :: slots)).length ≤ sz → + slots.length < fuel → + Record.wp (Cell.ok n) w (scatter fuel T.root md) (fun md' g' t => ∃ slots', + SlotInv n sz (view n g') slots' md' ∧ + (forestNodes slots').Perm (forestNodes (T :: slots)) ∧ + Frames (view n g) (view n g') (forestNodes (T :: slots)) ∧ + t + 14 * slots'.length ≤ 3 + 14 * (slots.length + 1)) g + | 0, _, _, _, _, _, _, _, _, hfuel => absurd hfuel (Nat.not_lt_zero _) + | fuel + 1, g, T, slots, md, hs, hT, hnd, hsz, hfuel => by + have hTnd : (z :: T.nodes).Nodup := + (List.cons_sublist_cons.mpr (List.sublist_append_left _ _)).nodup hnd + have hTsz : T.size ≤ sz := by + have : T.nodes.length ≤ (forestNodes (T :: slots)).length := by + simp [forestNodes] + unfold FHTree.size; omega + obtain ⟨hdlog, hdn⟩ := deg_bounds_of_extra hTsz hT.1 hTnd + have hdeg : g (.deg T.root) = T.deg := ValidSubtree.deg_root hT.1 + simp only [scatter, Record.wp_read_bind, hdeg, Cell.ok] + refine ⟨T.root.isLt, by omega, ?_⟩ + rcases hs.lookup (d := T.deg) (by omega) with ⟨h0, hnone⟩ | ⟨i, hi, hdi, hci, -, hno⟩ + · have h0' : g (.cons T.deg) = 0 := h0 + simp only [h0', ite_true, Record.wp_write_bind, Record.wp_pure, Cell.ok] + refine ⟨⟨by omega, hfit.of_le T.root.isLt⟩, T :: slots, + by simpa using hs.insert_empty hdn hdlog rfl hnone hT, List.Perm.refl _, + by simpa using frames_cons (view n g) _ _, by simp⟩ + · set S := slots[i] with hS + have hci' : g (.cons T.deg) = S.root.val + 1 := hci + simp only [hci', Nat.add_one_ne_zero, ite_false, Record.wp_write_bind, Nat.add_sub_cancel, + Cell.ok] + refine ⟨⟨by omega, fits_zero w⟩, ?_⟩ + rw [Record.wp_bind] + set g₁ := Function.update g (.cons T.deg) 0 + have hv₁ : view n g₁ = { view n g with cons := Function.update (view n g).cons T.deg 0 } := + view_update_cons g 0 T.deg + have hval₁ : ∀ R, ValidRoot (view n g) none R → ValidRoot (view n g₁) none R := fun R hR => + hv₁ ▸ hR.frame_nodes fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + have hS_mem : S ∈ slots := List.getElem_mem hi + have hs₁ := hs.step_collision hi hdi (by omega) hno (by rw [hv₁]) + fun R hR => hval₁ R (hs.2.1 R (List.mem_of_mem_eraseIdx hR)).1 + have hperm_slots := forestNodes_eraseIdx_perm slots i hi + have hnd1 : (T.nodes ++ (S.nodes ++ forestNodes (slots.eraseIdx i))).Nodup := + ((List.Perm.append_left T.nodes hperm_slots).nodup_iff).mpr (List.nodup_cons.mp hnd).2 + rw [← List.append_assoc] at hnd1 + have hnd_TS : (T.nodes ++ S.nodes).Nodup := (List.nodup_append.mp hnd1).1 + have hdisj : ∀ R ∈ slots.eraseIdx i, ∀ y ∈ R.nodes, y ∉ T.nodes ++ S.nodes := + fun R hR y hy hyTS => (List.nodup_append.mp hnd1).2.2 y hyTS y + (mem_forestNodes_iff.mpr ⟨R, hR, hy⟩) rfl + refine wp_link (hval₁ T hT) (hval₁ S (hs.2.1 S hS_mem).1) hnd_TS hdi.symm (by omega) hfit + fun g₂ t₂ T' ht₂ hdeg' hperm' hT' hfr₂ hcons₂ => ?_ + have hpermTE : (forestNodes (T' :: slots.eraseIdx i)).Perm (forestNodes (T :: slots)) := by + change (T'.nodes ++ forestNodes (slots.eraseIdx i)).Perm (T.nodes ++ forestNodes slots) + refine (hperm'.append_right _).trans ?_ + rw [List.append_assoc] + exact hperm_slots.append_left _ + have hs₂ : SlotInv n sz (view n g₂) (slots.eraseIdx i) md := + hs₁.frame hcons₂ fun R hR => hfr₂.validRoot (hs₁.2.1 R hR).1 (hdisj R hR) + have hlen := List.length_eraseIdx_add_one hi + refine Record.wp_mono ?_ (wp_scatter hfit fuel hs₂ hT' + ((hpermTE.cons z).nodup_iff.mpr hnd) (hpermTE.length_eq ▸ hsz) (by omega)) + rintro md' g' t₃ ⟨slots', hs', hp', hfr', hc'⟩ + have hsub₁ : ∀ y ∈ T.nodes ++ S.nodes, y ∈ forestNodes (T :: slots) := fun y hy => + hpermTE.subset (List.mem_append_left _ (hperm'.symm.subset hy)) + refine ⟨slots', hs', hp'.trans hpermTE, ?_, by omega⟩ + exact ((hv₁ ▸ frames_cons (view n g) _ _).trans (hfr₂.mono hsub₁)).trans + (hfr'.mono fun y hy => hpermTE.subset hy) + +/-- **Scattering a list of roots.** Walking `k` roots linked by `right` (each first made an unmarked +root if `prep`) and scattering each into the table leaves a valid table on the same nodes. Apart +from links, each root costs `4` operations, or `9` with `prep`. -/ +theorem wp_scatterList {sz : ℕ} {z : Fin n} (hfit : Fits w n) (prep : Bool) {fuel : ℕ} + (hfuel : n < fuel) : + ∀ (k : ℕ) {g : Cell → ℕ} {x : ℕ} {xs : List (Fin n)} {rest slots : List (FHTree n)} {md : ℕ}, + SlotInv n sz (view n g) slots md → + (∀ T ∈ rest, ValidSubtree (view n g) none T ∧ + (prep = false → (view n g).par T.root = 0 ∧ (view n g).mark T.root = 0)) → + xs.Perm (rest.map FHTree.root) → xs.length = k → + RightChain (view n g).right xs → (∀ y ∈ xs.head?, x = y.val) → + (z :: forestNodes (slots ++ rest)).Nodup → (forestNodes (slots ++ rest)).length ≤ sz → + (∀ y ∈ forestNodes rest, (view n g).inHeap y ≠ 0) → + (view n g).numMarked = markedCount (view n g) → + Record.wp (Cell.ok n) w (scatterList fuel prep k x md) (fun md' g' t => ∃ slots', + SlotInv n sz (view n g') slots' md' ∧ + (forestNodes slots').Perm (forestNodes (slots ++ rest)) ∧ + Scattered (view n g) (view n g') (forestNodes (slots ++ rest)) ∧ + (view n g').numMarked = markedCount (view n g') ∧ + (view n g').numMarked ≤ (view n g).numMarked ∧ + t + 14 * slots'.length ≤ (if prep then 9 else 4) * k + 14 * (slots.length + k)) g + | 0, g, x, xs, rest, slots, md, hs, _, hperm, hlen, _, _, _, _, _, hnm => by + obtain rfl : xs = [] := List.eq_nil_of_length_eq_zero hlen + obtain rfl : rest = [] := List.eq_nil_of_length_eq_zero (by simpa using hperm.length_eq.symm) + simp only [scatterList, Record.wp_pure, List.append_nil] + exact ⟨slots, hs, List.Perm.refl _, ⟨rfl, rfl, rfl, rfl, rfl, + fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩⟩, hnm, le_rfl, by simp⟩ + | k + 1, g, x, xs, rest, slots, md, hs, hrest, hperm, hlen, hchain, hx, hnd, hsz, hin, hnm => by + obtain ⟨x', xs', rfl⟩ : ∃ x' xs', xs = x' :: xs' := by + cases xs with + | nil => simp at hlen + | cons x' xs' => exact ⟨x', xs', rfl⟩ + obtain rfl : x = x'.val := hx x' rfl + obtain ⟨Tx, hTx, hTx_root⟩ := List.mem_map.mp (hperm.subset List.mem_cons_self) + obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp hTx + set rest' := rest.eraseIdx i + have hperm_rest : (rest[i] :: rest').Perm rest := List.getElem_cons_eraseIdx_perm hi + have hxs' : xs'.Perm (rest'.map FHTree.root) := by + have := hperm.trans (hperm_rest.map FHTree.root).symm + rw [List.map_cons, hTx_root] at this + exact (List.perm_cons x').mp this + have hnodes : (forestNodes (slots ++ rest)).Perm + (rest[i].nodes ++ forestNodes (slots ++ rest')) := by + rw [forestNodes_append, forestNodes_append] + refine (List.Perm.append_left _ (forestNodes_perm hperm_rest).symm).trans ?_ + change (forestNodes slots ++ (rest[i].nodes ++ forestNodes rest')).Perm + (rest[i].nodes ++ (forestNodes slots ++ forestNodes rest')) + rw [← List.append_assoc, ← List.append_assoc] + exact List.perm_append_comm.append_right _ + have hTmem : rest[i] ∈ rest := List.getElem_mem hi + have hnd' := (hnodes.cons z).nodup_iff.mp hnd + have hTnd : rest[i].nodes.Nodup := (List.nodup_append.mp (List.nodup_cons.mp hnd').2).1 + have hdisj : ∀ y ∈ rest[i].nodes, y ∉ forestNodes (slots ++ rest') := fun y hy hy' => + (List.nodup_append.mp (List.nodup_cons.mp hnd').2).2.2 y hy y hy' rfl + have hsub_rest : ∀ y ∈ forestNodes rest', y ∈ forestNodes (slots ++ rest') := fun y hy => by + rw [forestNodes_append]; exact List.mem_append_right _ hy + have hsub_slots : ∀ y ∈ forestNodes slots, y ∈ forestNodes (slots ++ rest') := fun y hy => by + rw [forestNodes_append]; exact List.mem_append_left _ hy + have hsubA : ∀ y ∈ forestNodes (slots ++ rest'), y ∈ forestNodes (slots ++ rest) := + fun y hy => hnodes.symm.subset (List.mem_append_right _ hy) + have hsubT : ∀ y ∈ rest[i].nodes, y ∈ forestNodes (slots ++ rest) := + fun y hy => hnodes.symm.subset (List.mem_append_left _ hy) + have hrest'_mem : ∀ T ∈ rest', T ∈ rest := fun T hT => List.mem_of_mem_eraseIdx hT + have hx'_root : x' = rest[i].root := hTx_root.symm + have hnext : ∀ y ∈ xs'.head?, (view n g).right x' = y.val := by + intro y hy + cases xs' with + | nil => simp at hy + | cons y' _ => + simp only [List.head?_cons, Option.mem_def, Option.some.injEq] at hy + subst hy + exact hchain.1 + have hchain' : RightChain (view n g).right xs' := by + cases xs' with + | nil => trivial + | cons _ _ => exact hchain.2 + -- After the optional preparation, scatter `rest[i]` and continue. + have cont : ∀ (g₁ : Cell → ℕ) (c₀ : ℕ), c₀ + 3 ≤ (if prep then 9 else 4) → + ValidRoot (view n g₁) none rest[i] → SlotInv n sz (view n g₁) slots md → + Scattered (view n g) (view n g₁) (forestNodes (slots ++ rest)) → + (view n g₁).numMarked = markedCount (view n g₁) → + (view n g₁).numMarked ≤ (view n g).numMarked → + (∀ T ∈ rest', ValidSubtree (view n g₁) none T ∧ + (prep = false → (view n g₁).par T.root = 0 ∧ (view n g₁).mark T.root = 0)) → + (view n g₁).right = (view n g).right → + Record.wp (Cell.ok n) w (scatter fuel x' md >>= fun md' => + scatterList fuel prep k ((view n g).right x') md') (fun md' g' t => ∃ slots', + SlotInv n sz (view n g') slots' md' ∧ + (forestNodes slots').Perm (forestNodes (slots ++ rest)) ∧ + Scattered (view n g) (view n g') (forestNodes (slots ++ rest)) ∧ + (view n g').numMarked = markedCount (view n g') ∧ + (view n g').numMarked ≤ (view n g).numMarked ∧ + t + c₀ + 14 * slots'.length ≤ (if prep then 9 else 4) * (k + 1) + + 14 * (slots.length + (k + 1))) g₁ := by + intro g₁ c₀ hc₀ hT₁ hs₁ hsc₁ hnm₁ hle₁ hrest₁ hright₁ + rw [Record.wp_bind, hx'_root] + have hnd_s : (z :: forestNodes (rest[i] :: slots)).Nodup := by + refine List.Sublist.nodup ?_ hnd' + refine List.Sublist.cons_cons z ?_ + change (rest[i].nodes ++ forestNodes slots).Sublist _ + rw [forestNodes_append] + exact (List.sublist_append_left _ _).append_left _ + have hlen_s : (forestNodes (rest[i] :: slots)).length ≤ sz := by + have h1 := hnodes.length_eq + simp only [forestNodes_append, List.length_append] at h1 hsz + change (rest[i].nodes ++ forestNodes slots).length ≤ sz + simp only [List.length_append] + omega + have hslots_lt : slots.length < fuel := by + have h1 : slots.length ≤ (forestNodes slots).length := forestNodes_length_ge slots + have h2 : (forestNodes slots).length ≤ n := by + have := (List.nodup_cons.mp hnd_s).2 + change (rest[i].nodes ++ forestNodes slots).Nodup at this + simpa using (List.nodup_append.mp this).2.1.length_le_card + omega + refine wp_scatter (z := z) hfit fuel hs₁ hT₁ hnd_s hlen_s hslots_lt |> Record.wp_mono ?_ + rintro md₂ g₂ t₂ ⟨slots₂, hs₂, hp₂, hfr₂, hc₂⟩ + have hnd_sr : (forestNodes (slots ++ rest')).Nodup := + (List.nodup_append.mp (List.nodup_cons.mp hnd').2).2.1 + have hdisj2 : ∀ T ∈ rest', ∀ y ∈ T.nodes, y ∉ forestNodes (rest[i] :: slots) := by + intro T hT y hy hy' + have hyr : y ∈ forestNodes rest' := mem_forestNodes_iff.mpr ⟨T, hT, hy⟩ + change y ∈ rest[i].nodes ++ forestNodes slots at hy' + rcases List.mem_append.mp hy' with h | h + · exact hdisj y h (hsub_rest y hyr) + · rw [forestNodes_append] at hnd_sr + exact (List.nodup_append.mp hnd_sr).2.2 y h y hyr rfl + have hP : (forestNodes (slots₂ ++ rest')).Perm (rest[i].nodes ++ forestNodes (slots ++ rest')) + := by + rw [forestNodes_append, forestNodes_append, ← List.append_assoc] + exact hp₂.append_right _ + have hsub₂ : ∀ y ∈ forestNodes (rest[i] :: slots), y ∈ forestNodes (slots ++ rest) := by + intro y hy + change y ∈ rest[i].nodes ++ forestNodes slots at hy + rcases List.mem_append.mp hy with h | h + · exact hsubT y h + · exact hsubA y (hsub_slots y h) + have hrest₂ : ∀ T ∈ rest', ValidSubtree (view n g₂) none T ∧ + (prep = false → (view n g₂).par T.root = 0 ∧ (view n g₂).mark T.root = 0) := + fun T hT => ⟨hfr₂.validSubtree (hrest₁ T hT).1 (hdisj2 T hT), fun hp => by + obtain ⟨hp0, hm0⟩ := (hrest₁ T hT).2 hp + obtain ⟨a, -, -, -, -⟩ := hfr₂.out _ (hdisj2 T hT _ T.root_mem_nodes) + exact ⟨a.trans hp0, (congrFun hfr₂.mark _).trans hm0⟩⟩ + have hchain₂ : RightChain (view n g₂).right xs' := hchain'.frame fun y hy => by + obtain ⟨T, hT, rfl⟩ := List.mem_map.mp (hxs'.subset hy) + obtain ⟨-, -, c, -, -⟩ := hfr₂.out _ (hdisj2 T hT _ T.root_mem_nodes) + rw [c, hright₁] + have hnext' : ∀ y ∈ xs'.head?, (view n g).right rest[i].root = y.val := hx'_root ▸ hnext + refine wp_scatterList hfit prep hfuel k hs₂ hrest₂ hxs' (by simpa using hlen) + hchain₂ hnext' ((hP.cons z).nodup_iff.mpr hnd') + (by rw [hP.length_eq]; rw [hnodes.length_eq] at hsz; exact hsz) + (fun y hy => by + rw [hfr₂.inHeap, hsc₁.inHeap] + exact hin y (mem_forestNodes_iff.mpr (by + obtain ⟨T, hT, hyT⟩ := mem_forestNodes_iff.mp hy + exact ⟨T, hrest'_mem T hT, hyT⟩))) + (by + rw [hfr₂.numMarked, hnm₁] + exact markedCount_congr fun u => by rw [hfr₂.inHeap, hfr₂.mark]) |> Record.wp_mono ?_ + rintro md' g' t' ⟨slots', hs', hp', hsc', hnm', hle', hc'⟩ + refine ⟨slots', hs', hp'.trans (hP.trans hnodes.symm), + (hsc₁.trans (hfr₂.scattered.mono hsub₂)).trans (hsc'.mono fun y hy => + hnodes.symm.subset (hP.subset hy)), hnm', ?_, ?_⟩ + · rw [hfr₂.numMarked] at hle'; omega + · rw [Nat.mul_succ]; omega + cases prep + · simp only [scatterList, Record.wp_read_bind, Cell.ok, Bool.false_eq_true, ite_false] + refine ⟨x'.isLt, Record.wp_mono (fun _ _ _ ⟨sl, a, b, c, d, e, f⟩ => ⟨sl, a, b, c, d, e, + by simp only [Bool.false_eq_true, ite_false] at f; omega⟩) + (cont g 1 (by simp) ?_ hs ⟨rfl, rfl, rfl, rfl, rfl, + fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩⟩ hnm le_rfl + (fun T hT => hrest T (hrest'_mem T hT)) rfl)⟩ + obtain ⟨hv, h0⟩ := hrest _ hTmem + exact ⟨hv, (h0 rfl).1, (h0 rfl).2⟩ + · simp only [scatterList, Record.wp_read_bind, Record.wp_write_bind, Cell.ok, ite_true, + Function.update_apply, reduceCtorEq, ite_false] + have hxn := x'.isLt + have hmk := ValidSubtree.mark_root_le (hrest _ hTmem).1 + rw [← hx'_root] at hmk + have hin_x : (view n g).inHeap x' ≠ 0 := + hin x' (mem_forestNodes_iff.mpr ⟨_, hTmem, hx'_root ▸ rest[i].root_mem_nodes⟩) + have hnm_le : (view n g).numMarked ≤ n := hnm ▸ markedCount_le_n _ + set st₁ : RawState n := { view n g with + par := Function.update (view n g).par x' 0 + mark := Function.update (view n g).mark x' 0 + numMarked := (view n g).numMarked - (view n g).mark x' } with hst₁ + have hv₁ : view n (Function.update (Function.update (Function.update g (.par x') 0) + (.mark x') 0) .numMarked (g .numMarked - g (.mark x'))) = st₁ := by + simp only [view_update_par, view_update_mark, view_update_numMarked, hst₁] + rfl + have hx_mem : x' ∈ rest[i].nodes := by rw [hx'_root]; exact rest[i].root_mem_nodes + have hx_ne : ∀ y ∈ forestNodes (slots ++ rest'), y ≠ x' := fun y hy e => + hdisj y (e ▸ hx_mem) hy + refine ⟨hxn, ⟨hxn, fits_zero w⟩, hxn, ⟨hxn, fits_zero w⟩, trivial, + ⟨trivial, hfit.of_le ((Nat.sub_le _ _).trans hnm_le)⟩, ?_⟩ + refine Record.wp_mono (fun _ _ _ ⟨sl, a, b, c, d, e, f⟩ => ⟨sl, a, b, c, d, e, + by simp only [ite_true] at f; omega⟩) (cont _ 6 (by simp) ?_ ?_ ?_ ?_ ?_ ?_ (by rw [hv₁])) + · rw [hv₁] + have := ValidSubtree.unmarkRoot (hrest _ hTmem).1 hTnd + ((view n g).numMarked - (view n g).mark x') + rw [← hx'_root] at this + exact this + · rw [hv₁] + exact hs.frame rfl fun R hR => (hs.2.1 R hR).1.frame_nodes fun y hy => by + have hy' := hx_ne y (hsub_slots y (mem_forestNodes_iff.mpr ⟨R, hR, hy⟩)) + simp [hst₁, hy'] + · rw [hv₁] + refine ⟨rfl, rfl, rfl, rfl, rfl, fun y hy => ?_⟩ + have hy' : y ≠ x' := fun e => hy (hsubT y (e ▸ hx_mem)) + simp [hst₁, hy'] + · rw [hv₁] + change (view n g).numMarked - (view n g).mark x' = markedCount st₁ + rw [hnm] + exact (markedCount_unmark (st' := st₁) hin_x hmk (by simp [hst₁]) rfl fun y hy => by + simp [hst₁, hy]).symm + · rw [hv₁]; exact Nat.sub_le _ _ + · intro T hT + rw [hv₁] + refine ⟨(hrest T (hrest'_mem T hT)).1.frame (fun y hy => ?_) (fun y hy => ?_), + fun h => absurd h (by decide)⟩ + · have hy' := hx_ne y (hsub_rest y (mem_forestNodes_iff.mpr ⟨T, hT, hy⟩)) + simp [hst₁, hy'] + · have hy' := hx_ne y (hsub_rest y (mem_forestNodes_iff.mpr ⟨T, hT, + T.nodes_eq ▸ List.mem_cons_of_mem _ hy⟩)) + simp [hst₁, hy'] + +/-- **Gathering the table.** Scanning the slots `d, …, md` moves every tree of the table to the +root list, leaving the table empty, in at most `13` operations per slot. -/ +theorem wp_gather {sz : ℕ} (hfit : Fits w n) : + ∀ (k : ℕ) {g : Cell → ℕ} {d md : ℕ} {slots gs : List (FHTree n)}, + SlotInv n sz (view n g) slots md → (∀ T ∈ slots, d ≤ T.deg) → d + k = md + 1 → + (∀ T ∈ gs, ValidRoot (view n g) none T) → RootList (view n g) gs → + (view n g).numRoots = gs.length → (forestNodes (gs ++ slots)).Nodup → + Record.wp (Cell.ok n) w (gather k d) (fun _ g' t => ∃ gs', + (∀ T ∈ gs', ValidRoot (view n g') none T) ∧ RootList (view n g') gs' ∧ + (view n g').numRoots = gs'.length ∧ (forestNodes gs').Perm (forestNodes (gs ++ slots)) ∧ + gs'.length = gs.length + slots.length ∧ (∀ d ≤ n, (view n g').cons d = 0) ∧ + (view n g').key = (view n g).key ∧ (view n g').inHeap = (view n g).inHeap ∧ + (view n g').mark = (view n g).mark ∧ (view n g').numMarked = (view n g).numMarked ∧ + (view n g').sz = (view n g).sz ∧ t ≤ 13 * k) g + | 0, g, d, md, slots, gs, hs, hge, hk, hgs, hrl, hnr, _ => by + obtain ⟨rfl, hcons⟩ := hs.done_of_cleared fun d' hd' T hT he => by + have := hge T hT; omega + simp only [gather, Record.wp_pure] + exact ⟨gs, hgs, hrl, hnr, by simp, by simp, hcons, trivial, trivial, trivial, trivial, trivial, + by simp⟩ + | k + 1, g, d, md, slots, gs, hs, hge, hk, hgs, hrl, hnr, hnd => by + have hdn : d ≤ n := by rcases hs.2.2.2.2.2 with h | h <;> omega + simp only [gather, Record.wp_read_bind, Cell.ok] + refine ⟨hdn, ?_⟩ + rcases hs.lookup hdn with ⟨h0, hnone⟩ | ⟨i, hi, hdi, hci, -, hno⟩ + · have h0' : g (.cons d) = 0 := h0 + simp only [h0', ite_true] + refine Record.wp_mono ?_ (wp_gather hfit k hs (fun T hT => ?_) (by omega) hgs hrl hnr hnd) + · rintro _ g' t ⟨gs', a, b, c, e, hl, f, h1, h2, h3, h4, h5, ht⟩ + exact ⟨gs', a, b, c, e, hl, f, h1, h2, h3, h4, h5, by omega⟩ + · have := hge T hT; have := hnone T hT; omega + · set S := slots[i] + have hci' : g (.cons d) = S.root.val + 1 := hci + simp only [hci', Nat.add_one_ne_zero, ite_false, Record.wp_write_bind, Nat.add_sub_cancel, + Cell.ok] + refine ⟨⟨hdn, fits_zero w⟩, ?_⟩ + rw [Record.wp_bind] + set g₁ := Function.update g (.cons d) 0 + have hv₁ : view n g₁ = { view n g with cons := Function.update (view n g).cons d 0 } := + view_update_cons g 0 d + have hval₁ : ∀ R, ValidRoot (view n g) none R → ValidRoot (view n g₁) none R := fun R hR => + hv₁ ▸ hR.frame_nodes fun _ _ => ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + have hSmem : S ∈ slots := List.getElem_mem hi + have hs₁ := hs.step_collision hi hdi hdn hno (by rw [hv₁]) + fun R hR => hval₁ R (hs.2.1 R (List.mem_of_mem_eraseIdx hR)).1 + have hS₁ := hval₁ S (hs.2.1 S hSmem).1 + have hgs₁ : ∀ T ∈ gs, ValidRoot (view n g₁) none T := fun T hT => hval₁ T (hgs T hT) + have hrl₁ : RootList (view n g₁) gs := by rw [hv₁]; exact hrl + have hperm := forestNodes_eraseIdx_perm slots i hi + have hP : (forestNodes ((S :: gs) ++ slots.eraseIdx i)).Perm (forestNodes (gs ++ slots)) := by + rw [forestNodes_append, forestNodes_append] + change (S.nodes ++ forestNodes gs ++ forestNodes (slots.eraseIdx i)).Perm _ + rw [List.append_assoc] + exact (List.perm_append_comm_assoc _ _ _).trans (hperm.append_left _) + have hnd' := hP.nodup_iff.mpr hnd + have hnd_S : (forestNodes (S :: gs)).Nodup := by + rw [forestNodes_append] at hnd' + exact (List.nodup_append.mp hnd').1 + have hlen : gs.length + 1 ≤ n := by + have h1 := forestNodes_length_ge (S :: gs) + have h2 : (forestNodes (S :: gs)).length ≤ n := by simpa using hnd_S.length_le_card + simp only [List.length_cons] at h1 + omega + refine wp_addRoot (u := S.root) ?_ hfit (by rw [hv₁]; exact hfit.of_le (by simp; omega)) + fun g₂ t₂ ht₂ hadd => ?_ + · rcases hrl₁ with ⟨_, h0⟩ | ⟨m, rtail, hm, hcirc, -⟩ + exacts [Or.inl h0, Or.inr ⟨m, rtail, hm, hcirc⟩] + obtain ⟨hall, hrl₂⟩ := RootList.addRoot hnd_S hS₁ hgs₁ hrl₁ hadd + obtain ⟨l₂, r₂, m₂, heq₂⟩ := hadd.exists_eq + have hs₂ : SlotInv n sz (view n g₂) (slots.eraseIdx i) md := + hs₁.frame (by rw [heq₂]) fun R hR => + hadd.validRoot_other hrl₁ hgs₁ hS₁.2.1 (hs₁.2.1 R hR).1 + refine Record.wp_mono ?_ (wp_gather hfit k hs₂ (fun T hT => ?_) (by omega) hall hrl₂ + (by rw [heq₂, hv₁, hnr]; rfl) hnd') + · rintro _ g' t ⟨gs', a, b, c, e, hl, f, h1, h2, h3, h4, h5, ht⟩ + rw [heq₂] at h1 h2 h3 h4 h5 + have hlen' := List.length_eraseIdx_add_one hi + exact ⟨gs', a, b, c, e.trans hP, by simp at hl; omega, f, h1, h2, h3, h4, h5, by omega⟩ + · have := hs.2.1 T (List.mem_of_mem_eraseIdx hT) + have h1 := hge T (List.mem_of_mem_eraseIdx hT) + have h2 := hno T hT + omega + +/-- **Extracting the minimum.** `extractMin n` implements `IndexedMinPQ.step` on `.extractMin`, +preserves the invariant, and costs at most `extractCharge` of the queue's size, amortized. -/ +theorem wp_extractMin {K : ℕ} {g : Cell → ℕ} (hI : Inv n K g) (hfit : Fits w n) : + Record.wp (Cell.ok n) w (extractMin n) (fun a g' t => + IndexedMinPQ.step (abs n g) .extractMin = (abs n g', a) ∧ Inv n K g' ∧ + t + potential n g' ≤ + extractCharge (IndexedMinPQ.dom (abs n g)).card + potential n g) g := by + rcases minRoot_cases hI with h0 | ⟨z, rtail₀, hz, -⟩ + · have h0' : g .minRoot = 0 := h0 + simp only [extractMin, Record.wp_read_bind, h0', ite_true, Record.wp_pure, Cell.ok, true_and] + refine ⟨?_, hI, by simp [extractCharge]; omega⟩ + simp [IndexedMinPQ.step, (FibRawInv.findMin_eq_none hI h0).2] + have hz' : g .minRoot = z.val + 1 := hz + have hzn := z.isLt + obtain ⟨hfind, hsz_some, hkz⟩ := FibRawInv.findMin_eq_some hI hz + have hI' := hI + obtain ⟨ts, hts, hnd, hdom, hin, hkeys, hsz, hnr, hnm, hcons, hrl⟩ := hI' + obtain ⟨m, rtail, hm, hcirc, hperm, hle⟩ := hrl.resolve_left fun ⟨_, h0⟩ => by + change g .minRoot = 0 at h0; omega + obtain rfl : m = z := Fin.ext (by change g .minRoot = m.val + 1 at hm; omega) + obtain ⟨Tz, hTz, hTz_root⟩ := List.mem_map.mp (hperm.subset List.mem_cons_self) + obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp hTz + -- The minimum root's tree, its children `cs`, and the other trees `E`. + set T := ts[i] with hT_def + have hT : T ∈ ts := List.getElem_mem hi + set E := ts.eraseIdx i with hE + have hpermTs : (T :: E).Perm ts := List.getElem_cons_eraseIdx_perm hi + have hfs : (forestNodes ts).Perm (m :: (forestNodes T.children ++ forestNodes E)) := by + refine (forestNodes_perm hpermTs).symm.trans ?_ + change (T.nodes ++ forestNodes E).Perm _ + rw [T.nodes_eq, hTz_root] + rfl + have hnd_all := hfs.nodup_iff.mp hnd + have hm_cs : m ∉ forestNodes T.children ++ forestNodes E := (List.nodup_cons.mp hnd_all).1 + have hnd_cE := (List.nodup_cons.mp hnd_all).2 + have hcard : (IndexedMinPQ.dom (abs n g)).card = (forestNodes ts).length := by + rw [← List.toFinset_card_of_nodup hnd] + congr 1 + ext y + simp [IndexedMinPQ.dom, hdom y] + set s' := Function.update (abs n g) m none with hs' + have hcard' : (IndexedMinPQ.dom s').card + 1 = (forestNodes ts).length := by + rw [hs', IndexedMinPQ.dom_erase_update, ← hcard] + exact Finset.card_erase_add_one (IndexedMinPQ.mem_dom_iff.mpr ⟨_, hsz_some⟩) + have hlen_fs := hfs.length_eq + simp only [List.length_cons, List.length_append] at hlen_fs + -- The heap after detaching `m`. + have hdeg_m : g (.deg m) = T.children.length := by + have := ValidSubtree.deg_root (hts T hT).1 + rw [hTz_root] at this + exact this + have hnr_m : g .numRoots - 1 = rtail.length := by + have h1 := hperm.length_eq + change g .numRoots = ts.length at hnr + simp only [List.length_cons, List.length_map] at h1 + omega + have hcount : (view n g).sz ≤ n := by + rw [hsz]; exact (Finset.card_le_univ _).trans (by simp) + simp only [extractMin, Record.wp_read_bind, Record.wp_write_bind, hz', Nat.add_one_ne_zero, + ite_false, Nat.add_sub_cancel, Function.update_apply, reduceCtorEq, Cell.ok, true_and, + hdeg_m, hnr_m] + refine ⟨hzn, ⟨hzn, fits_zero w⟩, hfit.of_le ((Nat.sub_le _ _).trans hcount), hzn, hzn, hzn, ?_⟩ + rw [Record.wp_bind] + set g₁ := Function.update (Function.update g (.inHeap m) 0) .sz (g .sz - 1) with hg₁ + have hv₁ : view n g₁ = { view n g with + inHeap := Function.update (view n g).inHeap m 0 + sz := (view n g).sz - 1 } := by + simp only [hg₁, view_update_inHeap, view_update_sz]; rfl + -- The children of `m`, in the order of their sibling list. + obtain ⟨xs, hxs, hchainC, hheadC⟩ : ∃ xs : List (Fin n), xs.Perm (T.children.map FHTree.root) ∧ + RightChain (view n g).right xs ∧ ∀ y ∈ xs.head?, g (.child m) - 1 = y.val := by + rcases ValidSubtree.child_root (hts T hT).1 with ⟨hnil, -⟩ | ⟨h, tail, hch, hcircC, hpermC⟩ + · exact ⟨[], by simp [hnil], trivial, by simp⟩ + · refine ⟨h :: tail, hpermC, hcircC.rightChain, fun y hy => ?_⟩ + simp only [List.head?_cons, Option.mem_def, Option.some.injEq] at hy + subst hy + rw [hTz_root] at hch + change g (.child m) = _ at hch + omega + have hne_m : ∀ y ∈ forestNodes T.children ++ forestNodes E, y ≠ m := fun y hy e => + hm_cs (e ▸ hy) + have hin_ne : ∀ y ∈ forestNodes T.children ++ forestNodes E, (view n g₁).inHeap y ≠ 0 := + fun y hy => by + rw [hv₁] + simp only [Function.update_of_ne (hne_m y hy)] + exact (hin y).1.mpr ((hdom y).mp (hfs.symm.subset (List.mem_cons_of_mem _ hy))) + have hvalid₁ : ∀ R : FHTree n, ValidSubtree (view n g) none R → (∀ y ∈ R.nodes, y ≠ m) → + ValidSubtree (view n g₁) none R := fun R hR hRm => + hv₁ ▸ hR.frame (fun y hy => ⟨by simp [Function.update_of_ne (hRm y hy)], rfl, rfl, rfl, rfl⟩) + (fun _ _ => ⟨rfl, rfl, rfl, Iff.rfl⟩) + have hnm₁ : (view n g₁).numMarked = markedCount (view n g₁) := by + rw [hv₁] + refine hnm.trans (markedCount_congr fun y => ?_).symm + by_cases hy : y = m + · subst hy + have := (hts T hT).2.2 + rw [hTz_root] at this + simp [this] + · simp [hy] + have hcs_m : ∀ c ∈ T.children, ∀ y ∈ c.nodes, y ≠ m := fun c hc y hy => + hne_m y (List.mem_append_left _ (mem_forestNodes_iff.mpr ⟨c, hc, hy⟩)) + refine Record.wp_mono ?_ (wp_scatterList (sz := (IndexedMinPQ.dom s').card) (z := m) hfit true + (Nat.lt_succ_self n) T.children.length (g := g₁) (xs := xs) (rest := T.children) + (slots := []) (md := 0) (SlotInv.empty (by rw [hv₁]; exact hcons)) + (fun c hc => ⟨hvalid₁ c (ValidSubtree.sub (hts T hT).1 c hc) (hcs_m c hc), + fun h => absurd h (by decide)⟩) + hxs (by rw [hxs.length_eq, List.length_map]) (by rw [hv₁]; exact hchainC) hheadC + (by simpa [T.nodes_eq, hTz_root] using forestNodes_nodup_tree hnd hT) + (by simp; omega) (fun y hy => hin_ne y (List.mem_append_left _ hy)) hnm₁) + rintro md₁ g₂ t₁ ⟨slots₁, hs₁, hp₁, hsc₁, hnm₂, hle₂, hc₁⟩ + rw [Record.wp_bind] + have hE_disj : ∀ R ∈ E, ∀ y ∈ R.nodes, y ∉ forestNodes ([] ++ T.children) := by + intro R hR y hy hy' + rw [List.nil_append] at hy' + exact (List.nodup_append.mp hnd_cE).2.2 y hy' y (mem_forestNodes_iff.mpr ⟨R, hR, hy⟩) rfl + have hE_m : ∀ R ∈ E, ∀ y ∈ R.nodes, y ≠ m := fun R hR y hy => + hne_m y (List.mem_append_right _ (mem_forestNodes_iff.mpr ⟨R, hR, hy⟩)) + have hE_ts : ∀ R ∈ E, R ∈ ts := fun R hR => List.mem_of_mem_eraseIdx hR + have hvalid₂ : ∀ R ∈ E, ValidRoot (view n g₂) none R := fun R hR => + hsc₁.validRoot ⟨hvalid₁ R (hts R (hE_ts R hR)).1 (hE_m R hR), + by rw [hv₁]; exact (hts R (hE_ts R hR)).2.1, by rw [hv₁]; exact (hts R (hE_ts R hR)).2.2⟩ + (hE_disj R hR) + have hrtail : rtail.Perm (E.map FHTree.root) := by + have := hperm.trans (hpermTs.map FHTree.root).symm + rw [List.map_cons, hTz_root] at this + exact (List.perm_cons m).mp this + have hchain0 := hcirc.rightChain + have hchainR : RightChain (view n g₂).right rtail := by + have h1 : RightChain (view n g).right rtail := by + cases rtail with + | nil => trivial + | cons _ _ => exact hchain0.2 + refine h1.frame fun y hy => ?_ + obtain ⟨R, hR, rfl⟩ := List.mem_map.mp (hrtail.subset hy) + obtain ⟨-, -, c, -, -, -⟩ := hsc₁.out _ (hE_disj R hR _ R.root_mem_nodes) + rw [c, hv₁] + have hheadR : ∀ y ∈ rtail.head?, g (.right m) = y.val := by + intro y hy + cases rtail with + | nil => simp at hy + | cons y' _ => + simp only [List.head?_cons, Option.mem_def, Option.some.injEq] at hy + subst hy + exact hchain0.1 + have hP₂ : (forestNodes (slots₁ ++ E)).Perm (forestNodes T.children ++ forestNodes E) := by + rw [forestNodes_append] + simpa using hp₁.append_right (forestNodes E) + refine Record.wp_mono ?_ (wp_scatterList (sz := (IndexedMinPQ.dom s').card) (z := m) hfit false + (Nat.lt_succ_self n) rtail.length (g := g₂) (xs := rtail) (rest := E) (slots := slots₁) + (md := md₁) hs₁ (fun R hR => ⟨(hvalid₂ R hR).1, fun _ => ⟨(hvalid₂ R hR).2.1, + (hvalid₂ R hR).2.2⟩⟩) hrtail rfl hchainR hheadR ((hP₂.cons m).nodup_iff.mpr hnd_all) + (by rw [hP₂.length_eq]; simp; omega) + (fun y hy => by rw [hsc₁.inHeap]; exact hin_ne y (List.mem_append_right _ hy)) hnm₂) + rintro md₂ g₃ t₂ ⟨slots₂, hs₂, hp₂, hsc₂, hnm₃, hle₃, hc₂⟩ + simp only [Record.wp_write_bind, Cell.ok, true_and] + refine ⟨fits_zero w, fits_zero w, ?_⟩ + rw [Record.wp_bind] + have hP₃ : (forestNodes slots₂).Perm (forestNodes T.children ++ forestNodes E) := hp₂.trans hP₂ + have hs₄ : SlotInv n (IndexedMinPQ.dom s').card + (view n (Function.update (Function.update g₃ .minRoot 0) .numRoots 0)) slots₂ md₂ := + hs₂.frame rfl fun R hR => (hs₂.2.1 R hR).1.frame_nodes fun _ _ => + ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + refine Record.wp_mono ?_ (wp_gather hfit (md₂ + 1) (d := 0) (gs := []) hs₄ + (fun _ _ => Nat.zero_le _) (by omega) (by simp) (Or.inl ⟨rfl, rfl⟩) rfl + (by simpa using hP₃.nodup_iff.mpr hnd_cE)) + rintro _ g' t₃ ⟨gs', hval', hrl', hnr', hperm', hlen', hcons', hkey', hinh', hmark', hnmk', + hsz', ht₃⟩ + simp only [Record.wp_pure] + simp only [view_update_minRoot, view_update_numRoots] at hkey' hinh' hmark' hnmk' hsz' + -- The new heap. + have hP₄ : (forestNodes gs').Perm (forestNodes T.children ++ forestNodes E) := by + simpa using hperm'.trans (by simpa using hP₃) + have hkeyF : (view n g').key = (view n g).key := by + rw [hkey', hsc₂.key, hsc₁.key, hv₁] + have hinhF : (view n g').inHeap = Function.update (view n g).inHeap m 0 := by + rw [hinh', hsc₂.inHeap, hsc₁.inHeap, hv₁] + have hszF : (view n g').sz = (view n g).sz - 1 := by + rw [hsz', hsc₂.sz, hsc₁.sz, hv₁] + have hdom' : ∀ y, y ∈ forestNodes gs' ↔ (s' y).isSome := fun y => by + rw [hP₄.mem_iff] + by_cases hy : y = m + · subst hy; simp [hs', hm_cs] + · rw [hs', Function.update_of_ne hy, ← hdom y, hfs.mem_iff] + simp [hy] + have hfinal : FibRawInv n K s' (view n g') := by + refine ⟨gs', hval', hP₄.nodup_iff.mpr hnd_cE, hdom', fun y => ?_, fun y ky hy => ?_, ?_, + hnr', ?_, hcons', hrl'⟩ + · rw [hinhF] + by_cases hym : y = m + · subst hym; simp [hs'] + · rw [Function.update_of_ne hym, hs', Function.update_of_ne hym]; exact hin y + · by_cases hym : y = m + · subst hym; simp [hs'] at hy + · rw [hs', Function.update_of_ne hym] at hy; rw [hkeyF]; exact hkeys y ky hy + · rw [hszF, hsz] + have := hcard' + omega + · rw [hnmk', hnm₃] + exact markedCount_congr fun u => by rw [hinh', hmark'] + obtain ⟨hI', habs'⟩ := inv_of_fibRawInv hfinal + refine ⟨?_, hI', ?_⟩ + · rw [habs'] + simp only [IndexedMinPQ.step, hfind, hs', hzn, dite_true, Prod.mk.injEq, Option.some.injEq, + true_and] + rfl + · -- Cost: links are paid by the trees they remove; what remains is logarithmic. + have hdz : T.children.length ≤ 2 * Nat.log 2 (IndexedMinPQ.dom (abs n g)).card + 1 := by + have := (ValidSubtree.deg_bounds (hts T hT).1 (m := (IndexedMinPQ.dom (abs n g)).card) + (by unfold FHTree.size; rw [T.nodes_eq, hcard]; simp; omega)).1 + exact this + have hmd : md₂ ≤ 2 * Nat.log 2 (IndexedMinPQ.dom (abs n g)).card + 1 := by + have h1 := hs₂.2.2.2.2.1 + have h2 : Nat.log 2 (IndexedMinPQ.dom s').card ≤ + Nat.log 2 (IndexedMinPQ.dom (abs n g)).card := Nat.log_mono_right (by omega) + omega + have hF := SlotInv.length_le hs₂ + have hR : ts.length = rtail.length + 1 := by + have := hperm.length_eq; simp at this; omega + have hnmF : (view n g').numMarked ≤ (view n g).numMarked := by + have h1 : (view n g₁).numMarked = (view n g).numMarked := by rw [hv₁] + omega + simp only [Bool.false_eq_true, ite_false, ite_true, List.length_nil] at hc₁ hc₂ hlen' + simp only [potential, credit, extractCharge, hnr'] + change _ ≤ _ + 24 * (g .numRoots + 2 * (view n g).numMarked) + change g .numRoots = ts.length at hnr + rw [hnr] + omega + +end Programs + +end Cslib.DataStructure.PriorityQueue.FibonacciHeap From 6d8804b315209a4cadbf9a1bc25d91464680462e Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 19:55:58 -0500 Subject: [PATCH 15/18] fix(DataStructure): credit Renfei Zhou in the record Fibonacci heap; test records and insert Retain the original authorship of the native WordRAM Fibonacci heap that Basic.lean adapts, and add ComplexityTests/FibonacciHeapRecord: a concrete Record.Layout with a program run through Record.wp and Record.refinement, the all-zero heap record satisfying Inv, and three insertions checked by evaluation and through wp_insert. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../PriorityQueue/FibonacciHeap/Basic.lean | 9 +- ComplexityTests/FibonacciHeapRecord.lean | 125 ++++++++++++++++++ 2 files changed, 132 insertions(+), 2 deletions(-) create mode 100644 ComplexityTests/FibonacciHeapRecord.lean diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean index 29e9c92dd1..0c2da62d68 100644 --- a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/Basic.lean @@ -1,7 +1,7 @@ /- -Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Copyright (c) 2026 Renfei Zhou, Samuel Schlesinger. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Samuel Schlesinger +Authors: Renfei Zhou, Samuel Schlesinger -/ module @@ -34,6 +34,11 @@ The forest reasoning behind `insert` is `RootList.addRoot`, a statement about `R alone: adding a valid root tree to a valid root list. The program-level proofs evaluate the programs with `simp` and apply it. +The module adapts Renfei Zhou's native formalization (`WordRAM/FibonacciHeap`, in particular +`Program.lean` and `BasicOps.lean`) to the record level: his programs `insertCode` and +`addRootAndUpdateMin` become `insert` and `addRoot`, and their forest reasoning becomes +`FibRawInv.insert` and `RootList.addRoot`. + ## Main definitions * `Cell`, `Cell.ok`, `view`: the record's cells and its reading as `RawState n`. diff --git a/ComplexityTests/FibonacciHeapRecord.lean b/ComplexityTests/FibonacciHeapRecord.lean new file mode 100644 index 0000000000..66a312f55b --- /dev/null +++ b/ComplexityTests/FibonacciHeapRecord.lean @@ -0,0 +1,125 @@ +/- +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.Basic + +/-! +# Records and the Fibonacci heap's record, on concrete data + +* A record of two cells placed in memory by a concrete `Record.Layout`: a small program run + through `Record.wp`, and through `Record.refinement` over the memory oracle. +* The all-zero heap record satisfies `Inv`, so the invariant is not vacuous. +* Three insertions from it, two with equal keys: the answers, the minimum root, the counts and the + exact cost of the run, checked by evaluation; and the specifications `wp_insert` applied in + sequence, which give the invariant of the final record and its amortized cost bound. +-/ + +@[expose] public section + +namespace ComplexityTests.FibonacciHeapRecord + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.PriorityQueue + Cslib.DataStructure.PriorityQueue.FibonacciHeap + +/-! ## A record of two cells in memory -/ + +/-- Cell `false` at address `5` and cell `true` at address `3`. -/ +def layout : Record.Layout (fun _ : Bool => True) where + addr b := if b then 3 else 5 + addr_injOn i j _ _ h := by cases i <;> cases j <;> simp_all + +/-- Read cell `false` and write its successor to cell `true`. -/ +def bump : Record.Prog Bool Unit := do + let x ← Record.read false + Record.write true (x + 1) + +/-- Memory holding `6` at address `5`, with six words allocated. -/ +def mem : Memory.State := ⟨fun a => if a = 5 then 6 else 0, 6⟩ + +/-- The record stored in `mem` holds `6` in cell `false`. -/ +example : layout.abs mem false = 6 ∧ layout.abs mem true = 0 := by decide + +/-- The specification of `bump`: two admissible operations, after which cell `true` holds `7`. -/ +theorem bump_spec : Record.wp (fun _ : Bool => True) 4 bump + (fun _ g t => g true = 7 ∧ g false = 6 ∧ t = 2) (layout.abs mem) := by + simp only [bump, Record.wp_read_bind, Record.wp_write] + decide + +/-- Both cells are allocated in `mem`. -/ +theorem mem_inv : (Record.refinement layout 4).inv mem := fun i _ => by cases i <;> decide + +/-- Over memory, `bump` reads address `5` and writes address `3`. -/ +example : ((Memory.spec 4).clientState mem (link (layout.methods 4) bump)).mem 3 = 7 := by decide + +/-- The refinement theorem applies: the memory run is admissible and stores the record that the +record specification computes. -/ +example : (Record.refinement layout 4).abs + ((Memory.spec 4).clientState mem (link (Record.refinement layout 4).methods bump)) = + (Record.spec (fun _ : Bool => True) 4).clientState (layout.abs mem) bump := + ((Record.refinement layout 4).simulates_client bump mem_inv + ((Record.wp_iff _ _ _).mp bump_spec).1).2.2.1 + +/-! ## The heap's record -/ + +/-- The record specification for heaps on three handles at word size `4`. -/ +abbrev heap : StateTransitionSpec := Record.spec (Cell.ok 3) 4 + +/-- The empty heap: every cell zero. -/ +def empty : Cell → ℕ := fun _ => 0 + +/-- **The invariant is not vacuous**: the all-zero record is a valid empty heap. -/ +theorem inv_empty : Inv 3 9 empty := + (inv_of_fibRawInv (WordRAM.FibonacciHeap.FibRawInv.empty (fun _ => rfl) (fun _ _ => rfl) rfl rfl + rfl rfl)).1 + +/-- Insert handle `1` with key `4`, handle `0` with key `7`, and handle `2` with key `4`. -/ +def inserts : Prog Unit := do + insert 1 4 + insert 0 7 + insert 2 4 + +/-- All three handles are present with their keys. -/ +example : abs 3 (heap.clientState empty inserts) = ![some 7, some 4, some 4] := by decide + +/-- The minimum root is handle `1`: it ties with handle `2` on the key and has the smaller handle. +The three handles are roots, and none is marked. -/ +example : (view 3 (heap.clientState empty inserts)).minRoot = 1 + 1 ∧ + (view 3 (heap.clientState empty inserts)).numRoots = 3 ∧ + (view 3 (heap.clientState empty inserts)).numMarked = 0 := by decide + +/-- The run's exact cost: `14` record operations for the first insertion, into an empty root list, +and `18` for each of the others, which leave the minimum root in place. -/ +example : (heap.clientHistory empty inserts).length = 50 := by decide + +/-- **The specifications compose on this run**: three applications of `wp_insert` give the +invariant of the final record, its contents, and the amortized bound `3 * (19 + credit)`. -/ +theorem inserts_spec : Record.wp (Cell.ok 3) 4 inserts (fun _ g t => Inv 3 9 g ∧ + abs 3 g = ![some 7, some 4, some 4] ∧ + t + potential 3 g ≤ 3 * (19 + credit) + potential 3 empty) empty := by + have hn : Fits 4 3 := by decide + have hK : Fits 4 9 := by decide + simp only [inserts, Record.wp_bind] + refine Record.wp_mono ?_ (wp_insert (v := 1) (k := 4) inv_empty (by decide) (by decide) hn hK) + rintro _ g₁ t₁ ⟨habs₁, hI₁, hc₁⟩ + refine Record.wp_mono ?_ (wp_insert (v := 0) (k := 7) hI₁ (by rw [habs₁]; decide) (by decide) + hn hK) + rintro _ g₂ t₂ ⟨habs₂, hI₂, hc₂⟩ + refine Record.wp_mono ?_ (wp_insert (v := 2) (k := 4) hI₂ (by rw [habs₂, habs₁]; decide) + (by decide) hn hK) + rintro _ g₃ t₃ ⟨habs₃, hI₃, hc₃⟩ + refine ⟨hI₃, by rw [habs₃, habs₂, habs₁]; decide, ?_⟩ + omega + +/-- So every operation of the run is admissible, and the record after it satisfies the +invariant. -/ +example : heap.ValidHistory empty (heap.clientHistory empty inserts) ∧ + Inv 3 9 (heap.clientState empty inserts) := + ⟨((Record.wp_iff _ _ _).mp inserts_spec).1, ((Record.wp_iff _ _ _).mp inserts_spec).2.1⟩ + +end ComplexityTests.FibonacciHeapRecord From e1a0cfc93513f39dc5a63c86594680a3250fb4bc Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 19:58:46 -0500 Subject: [PATCH 16/18] fix(DataStructure): credit Renfei Zhou in the record decreaseKey; test a cut and cascading cut Retain the original authorship of the native Cut.lean development that DecreaseKey.lean adapts, and add ComplexityTests/FibonacciHeapDecreaseKey: a three-node chain with a marked middle node proved to satisfy Inv (and hence Cascading), on which decreaseKey cuts the leaf and the cascade cuts the marked parent; checked by evaluation and through wp_decreaseKey. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../FibonacciHeap/DecreaseKey.lean | 9 +- ComplexityTests/FibonacciHeapDecreaseKey.lean | 109 ++++++++++++++++++ 2 files changed, 116 insertions(+), 2 deletions(-) create mode 100644 ComplexityTests/FibonacciHeapDecreaseKey.lean diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean index 932561163e..fdf1021f61 100644 --- a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean @@ -1,7 +1,7 @@ /- -Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Copyright (c) 2026 Renfei Zhou, Samuel Schlesinger. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Samuel Schlesinger +Authors: Renfei Zhou, Samuel Schlesinger -/ module @@ -35,6 +35,11 @@ Each cascading cut costs at most `22` record operations and turns a marked non-r 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/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. 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 From a23cede5e7c0de8a7033e8a860bcd67d59ecc325 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 19:59:29 -0500 Subject: [PATCH 17/18] fix(DataStructure): name the adapted module without a slash path Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../PriorityQueue/FibonacciHeap/DecreaseKey.lean | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean index fdf1021f61..2bf7a342ac 100644 --- a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/DecreaseKey.lean @@ -35,8 +35,8 @@ Each cascading cut costs at most `22` record operations and turns a marked non-r 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/Cut.lean`) to the -record level: his cut (`cutNodeCode_raw`, `cutNode_forest`, with its circular-list uniqueness +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. From cec747925bd75c9b1451356939f7c1463fc203e4 Mon Sep 17 00:00:00 2001 From: Samuel Giuseppe Schlesinger Date: Sun, 1 Nov 2026 20:02:24 -0500 Subject: [PATCH 18/18] fix(DataStructure): credit Renfei Zhou in the record extractMin; test a consolidation Retain the original authorship of the native Program.lean/Consolidate.lean development that ExtractMin.lean adapts, and add ComplexityTests/FibonacciHeapExtractMin: a two-root heap whose minimum root has a marked child, proved to satisfy Inv, on which extractMin promotes the child to an unmarked root and links it after a table collision; checked by evaluation and through wp_extractMin, with empty and one-handle extraction as edge cases. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015DLg8kwPs8yi7ePPdtoNvG --- .../FibonacciHeap/ExtractMin.lean | 10 +- ComplexityTests/FibonacciHeapExtractMin.lean | 159 ++++++++++++++++++ 2 files changed, 167 insertions(+), 2 deletions(-) create mode 100644 ComplexityTests/FibonacciHeapExtractMin.lean diff --git a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean index 91f3bcc64e..afca6e0626 100644 --- a/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean +++ b/Complexity/DataStructure/PriorityQueue/FibonacciHeap/ExtractMin.lean @@ -1,7 +1,7 @@ /- -Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Copyright (c) 2026 Renfei Zhou, Samuel Schlesinger. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Samuel Schlesinger +Authors: Renfei Zhou, Samuel Schlesinger -/ module @@ -43,6 +43,12 @@ each table slot costs at most `13`. With `credit = 24` per root, the roots' cred their scattering, and the amortized cost is at most `92 * (log₂ m + 1)` on a queue of `m` handles (`extractCharge`), by the Fibonacci degree bound. +The module adapts Renfei Zhou's native formalization (`WordRAM/FibonacciHeap`, its +`Program.lean` and `Consolidate.lean`) to the record level: his extraction and consolidation +programs (`extractMinCode`, the scattering and gathering loops) and their forest and table +reasoning become the programs and loop lemmas here, and his table invariant `SlotInv` and its +lemmas are reused unchanged. + ## Main definitions * `linkAs`, `link`, `scatter`, `scatterList`, `gather`, `extractMin`: record programs. diff --git a/ComplexityTests/FibonacciHeapExtractMin.lean b/ComplexityTests/FibonacciHeapExtractMin.lean new file mode 100644 index 0000000000..9d114d0987 --- /dev/null +++ b/ComplexityTests/FibonacciHeapExtractMin.lean @@ -0,0 +1,159 @@ +/- +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.ExtractMin + +/-! +# The record Fibonacci heap's `extractMin` on concrete heaps + +A heap on four handles has two roots: `0` (key `1`), whose children are the leaf `1` (key `5`) +and the marked leaf `2` (key `6`), and the leaf `3` (key `7`). It satisfies `Inv`, proved here +directly. Extracting the minimum returns `(0, 1)`; both children become unmarked roots, and the +second collides with the first in the table's slot of degree `0`, so `2` is linked below `1`; +then `3` takes the emptied slot. The tests check the answer, the keys, the marks, the links, the +cleared table and the exact cost by evaluation, and apply `wp_extractMin`, which gives +admissibility, the invariant of the result and the amortized bound `extractCharge 4 = 276`. + +Two edge cases: extraction from the empty heap, and from a heap with one handle, built by +`insert` and so known valid through `wp_insert`. +-/ + +@[expose] public section + +namespace ComplexityTests.FibonacciHeapExtractMin + +open Cslib.WordRAM Cslib.DataStructure Cslib.DataStructure.PriorityQueue + Cslib.DataStructure.PriorityQueue.FibonacciHeap + Cslib.DataStructure.PriorityQueue.WordRAM.FibonacciHeap + +/-- The record specification for heaps on four handles at word size `4`. -/ +abbrev heap : StateTransitionSpec := Record.spec (Cell.ok 4) 4 + +/-- Roots `0` and `3`; the root `0` has the children `1` and `2`, linked in this order, and `2` +is marked. The root list and the child list are two-element circular lists. -/ +def twoRoots : Cell → ℕ + | .key 0 => 1 | .key 1 => 5 | .key 2 => 6 | .key 3 => 7 + | .par 1 => 0 + 1 | .par 2 => 0 + 1 + | .child 0 => 1 + 1 + | .left 0 => 3 | .right 0 => 3 | .left 3 => 0 | .right 3 => 0 + | .left 1 => 2 | .right 1 => 2 | .left 2 => 1 | .right 2 => 1 + | .deg 0 => 2 + | .mark 2 => 1 + | .inHeap 0 => 1 | .inHeap 1 => 1 | .inHeap 2 => 1 | .inHeap 3 => 1 + | .minRoot => 0 + 1 | .numRoots => 2 | .numMarked => 1 | .sz => 4 + | _ => 0 + +/-- The two trees. The second child `2` may have no children, as its mark makes up its rank. -/ +def trees : List (FHTree 4) := [.node 0 [.node 1 [], .node 2 []], .node 3 []] + +/-- **The invariant has an instance with a marked child of the minimum root.** -/ +theorem inv_twoRoots : Inv 4 9 twoRoots := by + have hleaf : ∀ v : Fin 4, (view 4 twoRoots).inHeap v ≠ 0 → (view 4 twoRoots).mark v ≤ 1 → + (view 4 twoRoots).deg v = 0 → (view 4 twoRoots).child v = 0 → + ValidSubtree (view 4 twoRoots) none (.node v []) := fun v h1 h2 h3 h4 => + .mk h1 h2 h3 (Or.inl ⟨rfl, h4⟩) (by simp) (by simp) (by simp) (by simp) + refine ⟨trees, fun T hT => ?_, 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, [3], rfl, by simp only [IsCircList, ChainLinks]; decide, by decide, by decide⟩⟩ + · simp only [trees, List.mem_cons, List.not_mem_nil, or_false] at hT + rcases hT with rfl | rfl + · refine ⟨.mk (by decide) (by decide) rfl + (Or.inr ⟨1, [2], rfl, by simp only [IsCircList, ChainLinks]; decide, by decide⟩) (by decide) + (by decide) (fun i hi => ?_) fun T hT => ?_, rfl, rfl⟩ + · match i with + | 0 => exact Nat.zero_le _ + | 1 => simp [view, twoRoots] + | _ + 2 => simp at hi + · simp only [List.mem_cons, List.not_mem_nil, or_false] at hT + rcases hT with rfl | rfl <;> exact hleaf _ (by decide) (by decide) rfl rfl + · exact ⟨hleaf _ (by decide) (by decide) rfl rfl, rfl, rfl⟩ + · have hkeys : ∀ v : Fin 4, ∀ k ∈ abs 4 twoRoots v, (view 4 twoRoots).key v = k ∧ k ≤ 9 := by + decide + exact hkeys v k h + +/-- The answer: handle `0` with key `1`. -/ +example : heap.clientResult twoRoots (extractMin 4) = some (0, 1) := by decide + +/-- The final record. -/ +abbrev after : Cell → ℕ := heap.clientState twoRoots (extractMin 4) + +/-- `0` is gone; the other keys are unchanged. -/ +example : abs 4 after = ![none, some 5, some 6, some 7] := by decide + +/-- The marked child `2` was made an unmarked root, collided with `1` in the slot of degree `0`, +and was linked below it: `1` is a root of degree `1` with the child `2`. -/ +example : (view 4 after).par 2 = 1 + 1 ∧ (view 4 after).child 1 = 2 + 1 ∧ + (view 4 after).deg 1 = 1 ∧ (view 4 after).par 1 = 0 ∧ (view 4 after).par 3 = 0 := by decide + +/-- No mark is left, two roots remain, the new minimum root is `1`, and the table is empty. -/ +example : (∀ v : Fin 4, (view 4 after).mark v = 0) ∧ (view 4 after).numMarked = 0 ∧ + (view 4 after).numRoots = 2 ∧ (view 4 after).minRoot = 1 + 1 ∧ + (∀ d ≤ 4, (view 4 after).cons d = 0) := by decide + +/-- The run's exact cost in record operations. -/ +example : (heap.clientHistory twoRoots (extractMin 4)).length = 65 := by decide + +/-- The potential before and after: two roots and one mark, then two roots. -/ +example : potential 4 twoRoots = 96 ∧ potential 4 after = 48 := by decide + +/-- **The specification applies**: `wp_extractMin` on this run. -/ +theorem extract_spec : Record.wp (Cell.ok 4) 4 (extractMin 4) (fun a g' t => + IndexedMinPQ.step (abs 4 twoRoots) .extractMin = (abs 4 g', a) ∧ Inv 4 9 g' ∧ + t + potential 4 g' ≤ extractCharge (IndexedMinPQ.dom (abs 4 twoRoots)).card + + potential 4 twoRoots) twoRoots := + wp_extractMin inv_twoRoots (by decide) + +/-- So the run is admissible, the result is a valid heap, and the cost is within the bound +`extractCharge 4 = 92 * (log₂ 4 + 1) = 276`. -/ +example : heap.ValidHistory twoRoots (heap.clientHistory twoRoots (extractMin 4)) ∧ + Inv 4 9 after ∧ + (heap.clientHistory twoRoots (extractMin 4)).length + potential 4 after ≤ + 276 + potential 4 twoRoots := by + obtain ⟨hv, -, hI, hc⟩ := (Record.wp_iff _ _ _).mp extract_spec + refine ⟨hv, hI, ?_⟩ + have hcard : (IndexedMinPQ.dom (abs 4 twoRoots)).card = 4 := by decide + rw [hcard] at hc + exact hc + +/-! ## Edge cases -/ + +/-- The empty heap: every cell zero. -/ +def empty : Cell → ℕ := fun _ => 0 + +/-- The empty heap is valid. -/ +theorem inv_empty : Inv 4 9 empty := + (inv_of_fibRawInv (FibRawInv.empty (fun _ => rfl) (fun _ _ => rfl) rfl rfl rfl rfl)).1 + +/-- Extraction from the empty heap answers `none` in one operation and changes nothing. -/ +example : heap.clientResult empty (extractMin 4) = none ∧ + heap.clientState empty (extractMin 4) = empty ∧ + (heap.clientHistory empty (extractMin 4)).length = 1 := by + refine ⟨by decide, rfl, by decide⟩ + +/-- One handle, `3` with key `2`, inserted into the empty heap. -/ +abbrev single : Cell → ℕ := heap.clientState empty (insert 3 2) + +/-- It is valid, by `wp_insert`. -/ +theorem inv_single : Inv 4 9 single := + ((Record.wp_iff _ _ _).mp (wp_insert (v := 3) (k := 2) (w := 4) inv_empty (by decide) + (by decide) (by decide) (by decide))).2.2.1 + +/-- Extracting its only handle answers `(3, 2)` and leaves an empty heap with an empty table. -/ +example : heap.clientResult single (extractMin 4) = some (3, 2) ∧ + abs 4 (heap.clientState single (extractMin 4)) = IndexedMinPQ.empty 4 ∧ + (view 4 (heap.clientState single (extractMin 4))).minRoot = 0 ∧ + (view 4 (heap.clientState single (extractMin 4))).numRoots = 0 ∧ + (∀ d ≤ 4, (view 4 (heap.clientState single (extractMin 4))).cons d = 0) := by + decide + +/-- The result satisfies the invariant, by `wp_extractMin`. -/ +example : Inv 4 9 (heap.clientState single (extractMin 4)) := + ((Record.wp_iff _ _ _).mp (wp_extractMin (w := 4) inv_single (by decide))).2.2.1 + +end ComplexityTests.FibonacciHeapExtractMin